diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,109 @@ +1.17.0 +====== +* [!1173](https://gitlab.com/morley-framework/morley/-/merge_requests/1173) + Typechecker fixes + + Remove unused `TypeCheckPack` typechecker mode + + Do not throw `error` in the typechecker + + Set typecheck mode in `typeCheckValue` (don't accept `SELF` inside a pushed + `lambda`) + + Hotfix: Give `IsNotInView` in `TypeCheckTest` mode (fix morley repl + confusingly complaining about views) +* [!1123](https://gitlab.com/morley-framework/morley/-/merge_requests/1123) + Remove deprecated exports +* [!1161](https://gitlab.com/morley-framework/morley/-/merge_requests/1161) + Remove support for `AliasHint` +* [!1169](https://gitlab.com/morley-framework/morley/-/merge_requests/1169) + Support MIN_BLOCK_TIME instruction + + Add `MIN_BLOCK_TIME` typed and untyped instructions. + + `MIN_BLOCK_TIME` accepts any number of any annotations, introduce `AnyAnn` + type for arbitrary annotations. + + Remove unused `SomeAnn` and `SomeTag`. + + Add `ceMinBlockTime` to `ContractEnv` and `eeMinBlockTime` to `ExecutorEnv`. + + Add a corresponding CLI option. +* [!1166](https://gitlab.com/morley-framework/morley/-/merge_requests/1166) + Support transaction rollup jakarta changes. + + Refactor address hash parsing/printing. + * `HashKind` datakind introduced; + * `KeyHash` and `ContractHash` are replaced by `Hash (a :: HashKind)`, + * `KeyHashTag` replaced by `HashTag (a :: HashKind)`; + * `KeyHash`, `KeyHashTag` and `ContractHash` compatibility type synonyms + introduced, + * `formatKeyHash`, `mformatKeyHash`, `parseKeyHash`, `parseKeyHashRaw`, + `keyHashLengthBytes` are renamed to `formatHash`, `mformatHash`, + `parseHash`, `hashLengthBytes`, respectively, + * `contractHashLengthBytes`, `formatContractHash`, `parseContractHash` are + removed (use generic `hashLengthBytes`, `formatHash` and `parseHash`) + * Use `Hash HashContract` instead of `ContractHash` pattern/constructor. + + Add typechecking support for `tx_rollup_l2_address` Michelson type. + * `TxRollupL2Address` type introduced, isomorphic to + `tx_rollup_l2_address`. + * `HashBLS` hash kind introduced; `KeyHashL2` convenience type synonym + introduced. + + Add parsing/printing for `tz4` addresses. + + Add typechecking support and parsing/printing for `txr1` addresses. + * `TransactionRollupAddress` data constructor for `Address` is introduced; + * `HashKindTxRollup` hash kind and `TxRollupHash` type synonym introduced. + + NB: emulator support for transaction rollups is not yet implemented. +* [!1167](https://gitlab.com/morley-framework/morley/-/merge_requests/1167) + Adjust to sapling changes in jakarta + * Update the type of the `SAPLING_VERIFY_UPDATE` instruction. + * Reject contracts with the `sapling_transaction_deprecated` type. + * Support deserializing the `SAPLING_EMPTY_STATE`, `SAPLING_VERIFY_UPDATE`, + `OPEN_CHEST` instructions. + * Fix bug in the deserialization of the `sapling_transaction` type. +* [!1158](https://gitlab.com/morley-framework/morley/-/merge_requests/1158) + Refactor (out) annotation checking support + + Ignore annotations in the morley typechecker + + All typed instructions have `AnnINSTR` constructor, accepting a list of + annotations, and a pattern synonym `INSTR` that ignores annotations. + + `InstrWithVarAnns`, `InstrWithNotes`, `InstrWithVarNotes` + pseudo-constructors removed. + + `(::&+)` pattern synonym removed + + `AnnConvergeError`, `converge`, `convergeAnns`, `convergeDestrAnns`, + `deriveSpecialVN`, `deriveSpecialFNs`, `deriveVN`, `deriveNsOr`, + `deriveNsOption`, `convergeHSTEl`, `convergeHST`, `hstToTs`, `matchHST1`, + `onTypeCheckInstrAnnErr`, `matchTypes`, `WithAnn` pattern, `orAnn`, + `unifyAnn`, `unifyPairFieldAnn`, `convergeVarAnns`, `ifAnnUnified`, + `convAnn`, `starNotesStkEl`, `matchTypes` removed. + + `SomeAnns` and `instrAnns` utility functions to extract annotations of an + instruction added. + + Optimizations will now strip annotations. +* [!1160](https://gitlab.com/morley-framework/morley/-/merge_requests/1160) + Forbid parameter prefix root annotations +* [!1163](https://gitlab.com/morley-framework/morley/-/merge_requests/1163) + Prohibit some operations in views + + New class `IsNotInView`, which is conjured into existence where appropriate. + + `ContractCode` is now a newtype wrapper instead of type synonym; this is + required to avoid accidentally pasting contract code in views. + + New "smart" constructors `mkContractCode` and `mkVLam` which conjure + `IsNotInView` constraint (`mkLam` is needed because operations forbidden in + views are allowed in lambdas inside views) +* [!1088](https://gitlab.com/morley-framework/morley/-/merge_requests/1088) + Add options to specify convenient human-readable contract names for `originate`, `transfer` commands in Morley CLI. +* [!1153](https://gitlab.com/morley-framework/morley/-/merge_requests/1153) + Remove 'OpSize' modules. +* [!1139](https://gitlab.com/morley-framework/morley/-/merge_requests/1139) + Various small improvements. + * Export `eqInstrExt`. + * Add `ConcreteMeta` pattern synonym. +* [!1114](https://gitlab.com/morley-framework/morley/-/merge_requests/1114) + Update to ghc-9.0.2 +* [!1108](https://gitlab.com/morley-framework/morley/-/merge_requests/1108) + Remove support for the deprecated morley extensions +* [!1148](https://gitlab.com/morley-framework/morley/-/merge_requests/1148) + Fix deriveRPC's call to customGeneric' so that field ordering is maintained +* [!1141](https://gitlab.com/morley-framework/morley/-/merge_requests/1141) + Forbid transfers from empty sender on emulator + + This brings the emulator into closer correspondence with the network + + New `ExecutorError` constructor, `EEEmptyImplicitContract`. +* [!1131](https://gitlab.com/morley-framework/morley/-/merge_requests/1131) + Make `dfsTraverseValue` parameterized by `DfsSettings` +* [!1130](https://gitlab.com/morley-framework/morley/-/merge_requests/1130) + Fix deriveRPCWithStrategy on data with type variables + 1.16.4 ====== * [!1135](https://gitlab.com/morley-framework/morley/-/merge_requests/1135) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,12 +3,10 @@ [![Hackage](https://img.shields.io/hackage/v/morley.svg)](https://hackage.haskell.org/package/morley) Morley aims to make writing smart contracts in Michelson pleasant and effective. -It contains 3 major things: +It contains 2 major things: + 1. An [executable](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley#morley-executable) that lets you perform various operations on Michelson smart contracts. 2. A [library](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley#morley-library) with core Tezos and Michelson data types, and functions such as Michelson typechecker and interpreter. -3. A superset of the Michelson language that we call the [Morley language](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley#morley-language). -It relaxes Michelson parser rules, adds some syntax sugar and simple features. -**deprecated** ## Morley executable @@ -52,7 +50,6 @@ - `analyze` a contract and print some statistics about it. - `print` a contract in vanilla Michelson format. It can be useful in some cases: - + You have a smart contract that uses [Morley extensions](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley#morley-language) and want to convert it to vanilla Michelson format that can be handled by Tezos reference implementation. + You have a contract with inconsistent/ugly formatting and want to format it in uniform style. + You want to print a contract on a single line. - `parse` a contract and return its representation in Haskell types. @@ -70,20 +67,10 @@ - [`Morley.Michelson.TypeCheck`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-TypeCheck.html): 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](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyTypechecker.md). - [`Morley.Michelson.Interpret`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Interpret.html): An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyInterpreter.md). - [`Morley.Michelson.Macro`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Macro.html) Types for macros, syntactic sugar, and other extensions that are described in the next chapter. -- [`Morley.Michelson.Parser`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Parser.html) A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT. +- [`Morley.Michelson.Parser`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Parser.html) A parser to turn a `.tz` into a Haskell ADT. - [`Morley.Michelson.Runtime`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Runtime.html): A high-level interface to Morley functionality, see [morleyRuntime.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/morleyRuntime.md). - The `Morley.Micheline.*` hierarchy ([`Morley.Micheline.Binary`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Binary.html), [`Morley.Micheline.Class`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Class.html), [`Morley.Micheline.Expression`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Expression.html), [`Morley.Micheline.Json`](http://hackage.haskell.org/package/morley/docs/Morley-Micheline-Json.html)) contains the representation of Micheline `Expression`s, conversion to/from Michelson values, as well as encoding/decoding to/from JSON and binary format. - The `Morley.Util.*` hierarchy defines various `Morley`-related utilities that are used all over the project. - -## Morley language - -**NOTE:** Morley-the-language is deprecated and support for it will be removed in not-so-distant future. Features of morley-the-language are done better in `lorentz` and in some cases are superseded by new Michelson revisions. - -Morley-the-language is a superset of the Michelson language, which means that each Michelson contract is also a valid Morley contract but not vice versa. -There are several extensions which make it more convenient to write Michelson contracts and test them. -For example, one can write inline assertions in their contracts for testing. -All the details can be found in [the document](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/language/morleyLanguage.md) about these extensions. -A smart contract written in the Morley language can be transpiled to Michelson using the aforementioned `morley print` command. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - module Main ( main ) where @@ -24,14 +21,15 @@ import Morley.Michelson.Optimizer (optimize) import Morley.Michelson.Printer (printSomeContract, printUntypedContract) import Morley.Michelson.Runtime - (TxData(..), originateContract, prepareContract, prepareContractExt, runContract, transfer) + (TxData(..), originateContract, prepareContract, runContract, transfer) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith) import Morley.Michelson.TypeCheck qualified as TypeCheck import Morley.Michelson.TypeCheck.Types (mapSomeContract) -import Morley.Michelson.Typed (Contract'(..), SomeContract(..)) +import Morley.Michelson.Typed (Contract'(..), SomeContract(..), unContractCode) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) +import Morley.Tezos.Address.Alias (AddressOrAlias, Alias) import Morley.Tezos.Core (Mutez, Timestamp(..), tz) import Morley.Tezos.Crypto import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey) @@ -84,6 +82,7 @@ , roVerbose :: Bool , roNow :: Maybe Timestamp , roLevel :: Maybe Natural + , roMinBlockTime :: Maybe Natural , roMaxSteps :: Word64 , roInitBalance :: Mutez , roWrite :: Bool @@ -94,6 +93,7 @@ , ooDBPath :: FilePath , ooTcOptions :: TypeCheck.TypeCheckOptions , ooOriginator :: Address + , ooAlias :: Maybe Alias , ooDelegate :: Maybe KeyHash , ooStorageValue :: U.Value , ooBalance :: Mutez @@ -103,17 +103,18 @@ data TransferOptions = TransferOptions { toDBPath :: FilePath , toTcOptions :: TypeCheck.TypeCheckOptions - , toDestination :: Address + , toDestination :: AddressOrAlias , toTxData :: TxData , toNow :: Maybe Timestamp , toLevel :: Maybe Natural + , toMinBlockTime :: Maybe Natural , toMaxSteps :: Word64 , toVerbose :: Bool , toDryRun :: Bool } -argParser :: Opt.Parser (Bool, CmdLnArgs) -argParser = ((,) <$> enableExtsOption <*>) . subparser $ +argParser :: Opt.Parser CmdLnArgs +argParser = subparser $ printSubCmd <> typecheckSubCmd <> emulateSubCmd <> @@ -122,10 +123,6 @@ createChestSubCmd <> replSubCmd where - enableExtsOption = switch $ - long "deprecated-morley-extensions" <> - help "Enable parsing deprecated Morley extensions" - typecheckSubCmd = mkCommandParser "typecheck" (TypeCheck <$> typeCheckOptions) $ @@ -239,6 +236,7 @@ <*> verboseFlag <*> nowOption <*> levelOption + <*> minBlockTimeOption <*> maxStepsOption <*> mutezOption (Just defaultBalance) (#name :! "balance") (#help :! "Initial balance of this contract") @@ -252,6 +250,7 @@ <*> typeCheckOptionsOption <*> addressOption (Just genesisAddress) (#name :! "originator") (#help :! "Contract's originator") + <*> optional (aliasOption "alias") <*> optional (keyHashOption Nothing (#name :! "delegate") (#help :! "Contract's optional delegate") @@ -266,12 +265,14 @@ transferOptions = do toDBPath <- dbPathOption toTcOptions <- typeCheckOptionsOption - toDestination <- - addressOption Nothing - (#name :! "to") (#help :! "Destination address") + toDestination <- addressOrAliasOption + Nothing + (#name :! "to") + (#help :! "Address or alias of the transfer's destination") toTxData <- txDataOption toNow <- nowOption toLevel <- levelOption + toMinBlockTime <- minBlockTimeOption toMaxSteps <- maxStepsOption toVerbose <- verboseFlag toDryRun <- dryRunFlag @@ -289,9 +290,7 @@ ---------------------------------------------------------------------------- main :: IO () -main = wrapMain $ do - (exts, cmdLnArgs) <- execParser programInfo - run exts cmdLnArgs +main = wrapMain $ run =<< execParser programInfo where programInfo = info (helper <*> versionOption <*> argParser) $ mconcat @@ -304,16 +303,16 @@ versionOption = infoOption ("morley-" <> showVersion version) (long "version" <> help "Show version.") - run :: Bool -> CmdLnArgs -> IO () - run exts args = case args of + run :: CmdLnArgs -> IO () + run args = case args of Print (argF #input -> mInputFile) (argF #output -> mOutputFile) (arg #singleLine -> forceSingleLine) -> do - contract <- prepareContract' mInputFile + contract <- prepareContract mInputFile let write = maybe putStrLn Utf8.writeFile mOutputFile write $ printUntypedContract forceSingleLine contract Optimize OptimizeOptions{..} -> do - untypedContract <- prepareContract' optoContractFile + untypedContract <- prepareContract optoContractFile checkedContract <- either throwM pure . typeCheckingWith laxTcOptions $ typeCheckContract untypedContract @@ -321,13 +320,13 @@ let write = maybe putStrLn Utf8.writeFile optoOutput write $ printSomeContract optoSingleLine optimizedContract Analyze AnalyzeOptions{..} -> do - untypedContract <- prepareContract' aoContractFile + untypedContract <- prepareContract aoContractFile SomeContract contract <- either throwM pure . typeCheckingWith laxTcOptions $ typeCheckContract untypedContract - putTextLn $ pretty $ analyze (cCode contract) + putTextLn $ pretty $ analyze (unContractCode $ cCode contract) TypeCheck TypeCheckOptions{..} -> do - morleyContract <- prepareContract' tcoContractFile + morleyContract <- prepareContract tcoContractFile -- At the moment of writing, 'tcStrict' option does not change anything -- because it affects only values parsing; but this may change contract <- either throwM pure . typeCheckingWith tcoTcOptions @@ -336,17 +335,18 @@ putStrLn $ printSomeContract False contract putTextLn "Contract is well-typed" Run RunOptions {..} -> do - michelsonContract <- prepareContract' roContractFile - void $ runContract roNow roLevel roMaxSteps roInitBalance roDBPath roTcOptions roStorageValue michelsonContract roTxData + michelsonContract <- prepareContract roContractFile + void $ runContract roNow roLevel roMinBlockTime roMaxSteps roInitBalance roDBPath roTcOptions roStorageValue michelsonContract roTxData ! #verbose roVerbose ! #dryRun (not roWrite) Originate OriginateOptions {..} -> do - michelsonContract <- prepareContract' ooContractFile + michelsonContract <- prepareContract ooContractFile addr <- originateContract ooDBPath ooTcOptions ooOriginator + ooAlias ooDelegate ooBalance ooStorageValue @@ -354,7 +354,7 @@ ! #verbose ooVerbose putTextLn $ "Originated contract " <> pretty addr Transfer TransferOptions {..} -> do - transfer toNow toLevel toMaxSteps toDBPath toTcOptions toDestination toTxData + transfer toNow toLevel toMinBlockTime toMaxSteps toDBPath toTcOptions toDestination toTxData ! #verbose toVerbose ! #dryRun toDryRun REPL -> runRepl @@ -362,11 +362,6 @@ (chest, key) <- createChestAndChestKey ccPayload ccTime putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest) putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key) - where - -- TODO [#712]: Remove this next major release - prepareContract' - | exts = prepareContractExt - | otherwise = prepareContract usageDoc :: Maybe Doc diff --git a/app/REPL.hs b/app/REPL.hs --- a/app/REPL.hs +++ b/app/REPL.hs @@ -21,6 +21,7 @@ import Data.ByteString.Base58 qualified as Base58 import Data.ByteString.Lazy qualified as BSL import Data.List (stripPrefix) +import Data.Singletons (fromSing) import Data.Text as T (length, replicate, strip) import Data.Text qualified as T (stripPrefix) import Data.Vinyl (Rec(..)) @@ -32,7 +33,7 @@ import Morley.Michelson.Interpret (interpretInstr) import Morley.Michelson.Macro (ParsedOp, expandList) import Morley.Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_) -import Morley.Michelson.Parser.Types (MichelsonSource(..), noLetEnv) +import Morley.Michelson.Parser.Types (MichelsonSource(..)) import Morley.Michelson.Printer (printDoc, printTypedValue) import Morley.Michelson.Printer.Util (buildRenderDoc, doesntNeedParens) import Morley.Michelson.Runtime.Dummy @@ -99,7 +100,7 @@ let pkh = hashKey pk printResult "Secret Key" (formatSecretKey sk) printResult "Public Key" (formatPublicKey pk) - printResult "Public Key hash" (formatKeyHash pkh) + printResult "Public Key hash" (formatHash pkh) (stripPrefixNonEmpty ":" -> Just cmd) -> printErr $ "Unknown command or argument missing in `:"<> (toText cmd) <> "`. Use :help to see a list of commands" _ -> flip catch (\Interrupt -> putTextLn "Cancelled") $ withInterrupt $ runCode (toText input) @@ -142,6 +143,7 @@ tryParseMichelsonValue @'T.TChainId "Michelson ChainId" parseInput tryParseMichelsonValue @'T.TTimestamp "Michelson Timestamp" parseInput tryParseMichelsonValue @'T.TAddress "Michelson Address" parseInput + tryParseMichelsonValue @'T.TTxRollupL2Address "Michelson Transaction Rollup L2 Address" parseInput tryParseMichelsonValue @'T.TString "Michelson String" parseInput tryParseMichelsonValue @'T.TInt "Michelson Int" parseInput tryParseMichelsonValue @'T.TNat "Michelson Nat" parseInput @@ -165,10 +167,14 @@ Right p -> do printResult "Secret Key" $ formatSecretKey p Left _ -> pass - case parseKeyHash parseInput of + case parseHash @'HashKindPublicKey parseInput of Right p -> do - printResult "KeyHash" $ formatKeyHash p + printResult "KeyHash" $ formatHash p Left _ -> pass + case parseHash @'HashKindL2PublicKey parseInput of + Right p -> do + printResult "KeyHash" $ formatHash p + Left _ -> pass case Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 parseInput) of Just p -> do printResult "Base58 Encoded Bytes" $ "0x" <> (encodeHex p) @@ -224,7 +230,7 @@ parseInstructions :: Text -> Either Text [ParsedOp] parseInstructions src = - case parseNoEnv @() ops MSUnspecified src of + case parseNoEnv ops MSUnspecified src of Right p -> Right p Left err -> Left (toText $ errorBundlePretty err) @@ -243,17 +249,17 @@ -> Either Text (T.Dict (T.SingI (t ': xs)), HST (t ': xs)) addValueToHST v hstIn = case T.valueTypeSanity v of T.Dict -> case T.getWTP @t of - Right wtpDict -> Right (T.Dict, (T.starNotes @t, wtpDict, U.noAnn) ::& hstIn) + Right wtpDict -> Right (T.Dict, (T.sing @t, wtpDict) ::& hstIn) Left (T.NotWellTyped t cause) -> let U.Ty t' tann = T.toUType t in Left $ "Value of type '" <> (renderT t' (U.fullAnnSet [tann] [] [])) <> "' is not well typed in the provided Value because it " <> pretty cause <> "." -renderType :: T.Notes t -> U.VarAnn -> Text -renderType notes vann = let - U.Ty t tann = T.mkUType notes - in renderT t (U.fullAnnSet [tann] [] [vann]) +renderType :: T.SingT t -> Text +renderType notes = let + U.Ty t tann = T.toUType (fromSing notes) + in renderT t (U.fullAnnSet [tann] [] []) renderT :: U.T -> U.AnnotationSet -> Text renderT t annSet = toText $ printDoc True $ U.renderType t True doesntNeedParens annSet @@ -285,10 +291,10 @@ -- | Dump stack as a lit of tuples that represent (value, type) pairs. dumpStack :: forall t. Rec T.Value t -> HST t -> Either Text [(Text, Text)] dumpStack RNil _ = Right [] -dumpStack ((v :: T.Value a) :& rst) ((notes, _, vann) ::& rHst) = case T.valueTypeSanity v of +dumpStack ((v :: T.Value a) :& rst) ((notes, _) ::& rHst) = case T.valueTypeSanity v of T.Dict -> case T.checkOpPresence (T.sing @a) of T.OpAbsent -> case dumpStack rst rHst of - Right t -> Right ((toText $ printTypedValue True v, renderType notes vann) : t) + Right t -> Right ((toText $ printTypedValue True v, renderType notes) : t) Left e -> Left e T.OpPresent -> Left "Cannot dump stack with operations" @@ -300,7 +306,7 @@ buildStack :: Either Text SomeStack -> (Text, Text) -> Either Text SomeStack buildStack (Left err) _ = Left err buildStack (Right (SomeStack stk hst)) (txVal, txTyp) = case - (parseExpandValue "stack" txVal, parse (runReaderT type_ noLetEnv) "" txTyp) of + (parseExpandValue "stack" txVal, parse type_ "" txTyp) of (Right val, Right typ) -> case typeCheckingWith tcOptions $ typeCheckParameter mempty typ val of Right (T.SomeValue tVal) -> @@ -313,7 +319,7 @@ showStack :: forall t. Rec T.Value t -> HST t -> Text showStack RNil _ = "--" -showStack ((v :: T.Value a) :& rst) ((notes, _, vann) ::& rHst) = case T.valueTypeSanity v of +showStack ((v :: T.Value a) :& rst) ((notes, _) ::& rHst) = case T.valueTypeSanity v of T.Dict -> case T.checkOpPresence (T.sing @a) of T.OpAbsent -> -- print nice if value has no operations addSuffix (toText $ printTypedValue True v) @@ -322,4 +328,4 @@ (T.VList [], T.STList T.STOperation) -> "{ } :: list operation\n" <> showStack rst rHst _ -> addSuffix $ "(operations container:" <> pretty v <> ")" where - addSuffix val = val <>" :: " <> renderType notes vann <> "\n" <> showStack rst rHst + addSuffix val = val <>" :: " <> renderType notes <> "\n" <> showStack rst rHst diff --git a/docs/language/morleyInstructions.md b/docs/language/morleyInstructions.md deleted file mode 100644 --- a/docs/language/morleyInstructions.md +++ /dev/null @@ -1,78 +0,0 @@ - - -**NOTE:** Morley extended instructions are _deprecated_. The internal representation still uses instructions described here, as those are used by Lorentz, but parsing contracts using these instructions is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future. - -# Morley Ext Instructions - -Morley adds some additional instructions of its own to the existing set of -Michelson instructions. These instructions are not macros and have no effect on -a contract's execution. That is, they cannot write or alter any value on the -stack, but simply provide a mechanism to pass additional -information to Morley's typechecker or runtime. - -## `STACKTYPE` - -The `STACKTYPE` instruction allows us to assert that the stack has a given type -signature. For example, `STACKTYPE '[]` asserts that the stack is the empty -stack, and tells the typechecker to fail the contract otherwise. - -### Stack Type Signature - -A stack signature can be either an empty stack, a list of types, or a pattern -match on the head of the stack: - -``` -Empty stack: '[] -stack of three int: '[int, int, int] -A pattern match on a stack with two int at the top: '[int, int, ...] -``` - -More formally, a stack signature is like a `cons` list with two distinct -`nil`-like terminators: - -``` - := "'[" ( | | ) - := "]" - := "...]" - := ( | "_" ) (("," ( | ) -``` - -## PRINT - -`PRINT` instructs Morley to print a comment during execution, optionally with -a reference into the stack. For example, `PRINT "hello"` will print `hello`. - -Stack references may be written within the print-comment as `%[n]`, replacing -`n` with any natural number, which prints the `n`-th stack element from the -head. - -For example, `PRINT "Head is: %[0]"` on `'[1, ...]` will print - -``` -Head is: int 1 -``` - -## TEST_ASSERT - -The `TEST_ASSERT` instruction allows us to declare an inline test assertion, which is -a labeled sequence of instructions that runs on a copy of the current stack. -That is, an assertion has no actual effect on the program but can return the -result of some computation on the stack. - -For example, suppose we want to verify that the sum of two numbers is greater -than 10: - -``` -parameter unit; -storage unit; -code { DROP; - PUSH int 2; - PUSH int 10; - TEST_ASSERT Test1 "%[0] + %[1] > 10" {ADD; PUSH int 10; COMPARE;LT;}; - DROP; DROP; UNIT; NIL operation; PAIR; }; - -``` diff --git a/docs/language/morleyLanguage.md b/docs/language/morleyLanguage.md deleted file mode 100644 --- a/docs/language/morleyLanguage.md +++ /dev/null @@ -1,43 +0,0 @@ - - -**NOTE:** Morley language is _deprecated_. The internal representation still uses some of the extended instructions, as those are used by Lorentz, but parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future. - -# Morley Language - -The Morley Language is a low-level syntactic sugar over the core Michelson -instructions (core Michelson being the instructions which are actually executed -in the Tezos blockchain, as opposed to the various syntactic conveniences -provided by the OCaml reference client: `tezos-client`). - -The general principle is that any syntactically valid core Michelson expression -will also be a valid Morley expression, i.e. Morley is a superset of -Michelson. Any language extensions that break this principle must be explicitly -enabled. - -## Syntax Sugar - -[See `morleySyntaxSugar.md`](./morleySyntaxSugar.md). - -## Instruction and type names - -In Michelson, all letters in all instructions must be CAPITAL and all letters in types and type constructors must be lowercase. -In Morley, one can also use lowercase letters in instructions. -For example, `ABS` and `abs` are both valid names of the same instruction. - -Types and type constructors can start with a capital letter (like in Haskell). -For example, both `Unit` and `unit` are valid names of the unit type. - -## Macros and Type synonyms - -[See `morleyMacros.md`](./morleyMacros.md). - -## Extended NOP Instructions - -[See `morleyInstructions.md`](./morleyInstructions.md). - -## Let-block Definitions - -[See `morleyLet.md`](./morleyLet.md). diff --git a/docs/language/morleyLet.md b/docs/language/morleyLet.md deleted file mode 100644 --- a/docs/language/morleyLet.md +++ /dev/null @@ -1,170 +0,0 @@ - - -**NOTE:** Morley language is _deprecated_, which includes let-block definitions. Parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future. - -# Let-block Definitions - -In addition to the built-in macros defined in the Michelson specification, -Morley allows the programmer to define their own custom macros, as well as value -and type synonyms in a new top-level block: - -``` -let { - type num = int; - Three :: int = 3; - add3 :: '[int] -> '[int] = {push int 3; add;}; - add3 :: '[int] -> '[int] = {push num Three; add;}; - add :: '[int, int] -> '[int] = {sub;}; - stkRest :: '[int, ...] -> '[int, ...] = {push int 3; ADD;}; -}; - -parameter unit; -storage unit; -code { DROP; - PUSH nat Three; - drop; - PUSH num Three; - push Three; - add; - stacktype '[int, ...]; - stkRest; - DROP; - UNIT; NIL operation; PAIR; }; -``` - -More formally: - -``` -let {}; - - := type = type; - | :: = ; - | :: = {op}; -``` - -As a concrete example: - -``` -let { - type num = int; - Three :: int = 3; - add3 :: '[int] -> '[int] = {push int 3; add;}; -}; -``` - -There are three distinct types of let: - -- Type synonyms -- Constants -- Macros - -## Constants - -Constants may be pushed directly to the stack like so: - -``` -let { - Three :: int = 3; -}; -... -code { - ... - push Three; - ... - } -``` - -At present, constants are not checked statically, only when pushed. - -## Type Synonyms - -Type synonyms allow for labeling types. A synonym can be referred to anywhere a -type would be expected: - -``` -let { - type num = int; -} -code { - ... - push num 3; - ... - } -``` - -This `push num 3` instruction pushes the value 3 with the type `int :num` onto -the stack. - -Note that type synonyms with names `Parameter` and `Storage` are prohibited, these -names are used for implicit contracts parameter and storage types. - -The interaction between type synonyms and type annotations is that if the -synonym's definition contains no annotation, the name of the synonym will be -used. If the synonym definition does contain a type annotation, the annotation -takes precedence and will be preserved: - -``` -type color = int; ~> int :color -type color = int :rgb ~> int :rgb -``` - -## Let Macros - -``` -add3 :: '[int] -> '[int] = {push int 3; add;}; -``` - -The first line of the macro declaration is the type signature, which denotes the -stack transformation the macro performs. - -Crucially, if both input and output stack types contain a `` -pattern match (syntactically `...]`), then the stack type captured by both -pattern matches must be identical. - -For example, the type signature of - -``` -add3 :: '[int, ...] -> '[int, ...] = {push int 3; add;} -``` - -would be written using the type notation from the Michelson specification as: - -``` -add3 :: int : 'S -> int : 'S -``` - -meaning that the pattern match must be universally quantified over the same -stack-type `'S`. - -Furthermore, type signatures can also have universally quantified type -parameters, which must be declared in a `forall`: - -For instance, the type of the primitive `SWAP` instruction could be notated as: - -``` -swap :: forall a b. '[a, b, ...] -> '[b, a, ...] -``` - -It is important to note that type variables are not checked statically (at -present), but rather concretized in-place during type-checking. That is, the -typechecker replaces any unbound type parameter with the concrete type at that -position in the stack, and checks for consistency with any other instances of -that parameter. - -## Non-recursive References - -These definitions allow for non-recursive references to other definitions, -so one can define: - -``` -let { - foo :: '[unit] -> '[unit, unit] = {unit;}; - bar :: '[unit] -> '[unit] = {foo; drop;}; -}; -``` - -A reference must always come after the let it refers to in the block. diff --git a/docs/language/morleyMacros.md b/docs/language/morleyMacros.md deleted file mode 100644 --- a/docs/language/morleyMacros.md +++ /dev/null @@ -1,71 +0,0 @@ - - -**NOTE:** Morley language is _deprecated_, which includes these macros. Parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future. - -# Morley Language: Macros and Type synonyms - -Morley language supports all macros from the OCaml reference implementation and additionally introduces some extra macros and type synonyms. - -## A1 macros - -First group of macros implemented in Morley consists of macros proposed in [A1 TZIP](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md). -In order to avoid duplication of documentation we don't copy it here, please refer to the A1 document for more information. - -## Macros to work with tuples - -Large tuples are desugared as right-balanced trees of `Pair`, thus working with them manually is inconvenient and produces fragile code. -The following macros can be used to work with tuples without caring about their actual Michelson representation. - -### ACCESS - -This macro retrieves an element of a tuple. -It accepts two arguments - 0-based index of desired element and overall tuple size. -For now `ACCESS` is just a macro, not a full-featured morley instruction, thus programmer has to specify tuple size explicitly. - -Example: -``` -push (int, bool, string, unit) (1, False, "", ()); -access 1 4; -# Now stack contains `False` at the top -``` - -### SET - -Modifies single element of a tuple. -This macro has signature similar to one of `ACCESS`, and accepts two stack arguments - original tuple and new value. - -Example: -``` -push (int, bool, string, unit) (1, False, "", ()); -push bool True; -set 1 4; -# Now stack contains `(1, True, "", ())` at the top -``` - -### CONSTRUCT - -Builds a tuple. -For each position of the tuple you provide a code block which builds an element for that position. - -Example: -``` -construct - { push int 1 } - { sender } - { unit; some } -# Pushes `(1, , some ())` on stack -``` - -Each code block has access to the stack at the moment of `construct` call and eventually have to push exactly one element to stack. This will also work: -``` -push 5 -construct - { dup } - { push int 3 } - { dup; push int 3; add } -# Now stack is [(5, 3, 8), 5, ...] -``` diff --git a/docs/language/morleySyntaxSugar.md b/docs/language/morleySyntaxSugar.md deleted file mode 100644 --- a/docs/language/morleySyntaxSugar.md +++ /dev/null @@ -1,140 +0,0 @@ - - -**NOTE:** Morley language is _deprecated_, which includes the syntax sugar described here. Parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future. - -# Morley Language: Syntax Sugar - -## Summary - -| type | Sugar | Desugar | -|--------|-----------------------------------------|-------------------------------------------| -| pair | `(a ,b)` | `(pair a b)` | -| pair | `(a, b) :t %f` | `(pair :t %f a b)` | -| pair | `(a,b,c)` | `(a,(b,c))` | -| pair | `(a, b, c) :t %f` | `(a, (b, c)) :t %f` | -| pair | `(a :ta %fa, b :tb %fb, c :tc %fc)` | `(a :ta %fa, (b :tb %fb, c :tc %fc))` | -| or | `(a \| b)` | `(or a b)` | -| or | `(a \| b) :t %f` | `(or :t %f a b)` | -| or | `(a \| b \| c)` | `(a \| (b \| c))` | -| or | `(a \| b \| c) :t %f` | `(a \| (b \| c)) :t %f` | -| or | `(a :ta %fa \| b :tb %fb \| c :tc %fc)` | `(a :ta %fa \| (b :tb %fb \| c :tc %fc))` | -| unit | `()` | `unit` | -| lambda | `(\ a -> b)` | `lambda a b` | -| list | `[a]` | `list a` | -| set | `{a}` | `set a` | - - - -| Value | Sugar | Desugar | -|-------|-------------|--------------| -| Pair | `(a, b)` | `(Pair a b)` | -| Pair | `(a, b, c)` | `(a,(b,c))` | -| Unit | `()` | `Unit` | - -## Pairs - -### Type Syntax -`pair` types may be written using Haskell-style tuples: - -``` -(a, b) ~ (pair a b) -(a, b) :t %f ~ (pair :t %f a b) -``` - -When tuples are nested, parenthesis may be omitted: - -``` -(a,b,c) ~ (a,(b,c)) -``` - -Unsugaring will be performed in a way which provides the best average access time. -In essence, the tuple is split so that the left part has less by one -or the same size as the right part, these parts are recursively split -until one element remains, and resulting pieces are merged into an `Pair` tree. - -For instance: - -``` -(a, b, c, d, e) ~ ((a, b), (c, (d, e))) -``` - -For nested tuples, only the outer pair may be annotated: - -``` -(a, b, c) :t %f ~ (a, (b, c)) :t %f -``` - -Inner types may be annotated as usual: - -``` -(a :ta %fa, b :tb %fb, c :tc %fc) ~ (a :ta %fa, (b :tb %fb, c :tc %fc)) -``` - -### Value Syntax - -`Pair` values may also be written with tuples: - -``` -(a, b) ~ (Pair a b) -(a, b, c) ~ (a,(b,c)) -``` - -## Unions - -### Type Syntax - -`or` types may be written using the `|` character: - -``` -(or a b) ~ (a | b) -(or :t %f a b) ~ (a | b) :t %f -``` - -When bars are nested, parenthesis may be omitted: - -``` -(a | b | c) ~ (a | (b | c)) -``` - -As for tuples, desugaring large unions produces right-balanced trees of `Or`s. - -Annotations follow the same pattern as Tuples: -``` -(a | b | c) :t %f ~ (a | (b | c)) :t %f -(a :ta %fa | b :tb %fb | c :tc %fc) ~ (a :ta %fa | (b :tb %fb | c :tc %fc)) -``` - -## Unit - -The `unit` type may be written as a `0`-tuple - -``` -unit ~ () -``` - -The `Unit` value may also be written this way: - -``` -Unit ~ () -``` - -## Lambda: - -They `lambda` type may be written: - -``` -(lambda a b) ~ (\ a -> b) -``` - -## Containers - -The `list` and `set` types may be written: - -``` -(list a) ~ [a] -(set a) ~ {a} -``` diff --git a/docs/morleyTypechecker.md b/docs/morleyTypechecker.md --- a/docs/morleyTypechecker.md +++ b/docs/morleyTypechecker.md @@ -8,9 +8,7 @@ In Morley, we have a typechecker for the core Michelson language, i. e. without macros. It is located in `Morley.Michelson.TypeCheck` and designed in the following way: -* It takes a core Michelson contract extended with `EXT` instruction - to support additional instructions described in the - [`morleyInstructions.md`](language/morleyInstructions.md) document. +* It takes a core Michelson contract. * The contract passed to the typechecker uses [untyped representation](./michelsonTypes.md). * During typechecking, we verify that instructions are well-typed and diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morley -version: 1.16.4 +version: 1.17.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 @@ -25,11 +25,6 @@ docs/morleyInterpreter.md docs/morleyRuntime.md docs/morleyTypechecker.md - docs/language/morleyInstructions.md - docs/language/morleyLanguage.md - docs/language/morleyLet.md - docs/language/morleyMacros.md - docs/language/morleySyntaxSugar.md source-repository head type: git @@ -44,6 +39,7 @@ Morley.Micheline.Binary.Internal Morley.Micheline.Class Morley.Micheline.Expression + Morley.Micheline.Expression.WithMeta Morley.Micheline.Json Morley.Michelson.Analyzer Morley.Michelson.Doc @@ -53,17 +49,14 @@ Morley.Michelson.Interpret.Pack Morley.Michelson.Interpret.Unpack Morley.Michelson.Interpret.Utils - Morley.Michelson.Let Morley.Michelson.Macro Morley.Michelson.Optimizer Morley.Michelson.Parser Morley.Michelson.Parser.Annotations Morley.Michelson.Parser.Common Morley.Michelson.Parser.Error - Morley.Michelson.Parser.Ext Morley.Michelson.Parser.Helpers Morley.Michelson.Parser.Instr - Morley.Michelson.Parser.Let Morley.Michelson.Parser.Lexer Morley.Michelson.Parser.Macro Morley.Michelson.Parser.Type @@ -111,7 +104,6 @@ Morley.Michelson.Typed.Haskell.Value Morley.Michelson.Typed.Instr Morley.Michelson.Typed.Operation - Morley.Michelson.Typed.OpSize Morley.Michelson.Typed.Polymorphic Morley.Michelson.Typed.Scope Morley.Michelson.Typed.Sing @@ -127,11 +119,11 @@ Morley.Michelson.Untyped.Entrypoints Morley.Michelson.Untyped.Ext Morley.Michelson.Untyped.Instr - Morley.Michelson.Untyped.OpSize Morley.Michelson.Untyped.Type Morley.Michelson.Untyped.Value Morley.Michelson.Untyped.View Morley.Tezos.Address + Morley.Tezos.Address.Alias Morley.Tezos.Core Morley.Tezos.Crypto Morley.Tezos.Crypto.BLS12381 @@ -161,7 +153,6 @@ Morley.Util.Named Morley.Util.Peano Morley.Util.PeanoNatural - Morley.Util.Positive Morley.Util.Sing Morley.Util.SizedList Morley.Util.SizedList.Types @@ -237,6 +228,7 @@ , aeson-pretty , base-noprelude >=4.7 && <5 , base58-bytestring + , bimap , binary , bytestring , constraints >=0.11 @@ -264,6 +256,7 @@ , semigroups >=0.19.1 , show-type , singletons + , singletons-base , syb , template-haskell , text @@ -354,6 +347,7 @@ , morley-prelude , named , optparse-applicative + , singletons , text , vinyl , with-utf8 diff --git a/src/Morley/AsRPC.hs b/src/Morley/AsRPC.hs --- a/src/Morley/AsRPC.hs +++ b/src/Morley/AsRPC.hs @@ -29,13 +29,16 @@ import Control.Lens.Plated (universe) import Data.Constraint (Dict(..), (***), (:-)(Sub), (\\)) +import Data.Generics (everything, mkQ) import Data.List qualified as List ((\\)) +import Data.Map qualified as Map import Data.Singletons (Sing, withSingI) +import Data.Text qualified as T import GHC.Generics qualified as G import Language.Haskell.TH (Con(InfixC, NormalC, RecC), Cxt, Dec(DataD, NewtypeD, TySynD, TySynInstD), DerivStrategy(AnyclassStrategy), Info(TyConI), Kind, Loc(loc_module), Name, Q, TyLit(StrTyLit), - TySynEqn(..), TyVarBndr, Type(..), cxt, instanceD, location, mkName, nameBase, ppr, reify, + TySynEqn(..), TyVarBndr(..), Type(..), cxt, instanceD, location, mkName, nameBase, ppr, reify, reifyInstances, standaloneDerivWithStrategyD) import Language.Haskell.TH.ReifyMany (reifyManyTyCons) import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames) @@ -47,11 +50,12 @@ HasNoContract, HasNoNestedBigMaps, HasNoOp, IsoValue, Notes(..), OpPresence(..), Operation, SingI(sing), SingT(..), StorageScope, T(..), ToT, Value, Value'(..), WellTyped, checkContractTypePresence, checkOpPresence, toVal, withDict) -import Morley.Tezos.Address (Address) +import Morley.Tezos.Address (Address, TxRollupL2Address) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto import Morley.Util.CustomGeneric - (GenericStrategy, customGeneric', deriveFullType, haskellBalanced, reifyDataType) + (GenericStrategy, customGeneric', deriveFullType, haskellBalanced, + mangleGenericStrategyConstructors, mangleGenericStrategyFields, reifyDataType) import Morley.Util.Named hiding (Name) import Morley.Util.TH (isTypeAlias, lookupTypeNameOrFail) @@ -137,6 +141,7 @@ TAsRPC 'TBls12381G2 = 'TBls12381G2 TAsRPC 'TChest = 'TChest TAsRPC 'TChestKey = 'TChestKey + TAsRPC 'TTxRollupL2Address = 'TTxRollupL2Address TAsRPC ('TSaplingState n) = ('TSaplingState n) TAsRPC ('TSaplingTransaction n) = ('TSaplingTransaction n) @@ -261,6 +266,8 @@ type AsRPC Chest = Chest instance HasRPCRepr ChestKey where type AsRPC ChestKey = ChestKey +instance HasRPCRepr TxRollupL2Address where + type AsRPC TxRollupL2Address = TxRollupL2Address ---------------------------------------------------------------------------- -- MaybeRPC @@ -422,14 +429,21 @@ -- that doesn't use `reify` (it should be easy enough). repInstance <- reifyRepInstance typeName derivedType currentModuleName <- loc_module <$> location - let repTypeRPC = convertRep currentModuleName repInstance + let repTypeRPC = convertRep currentModuleName repInstance tyVars typeDecOfRPC <- mkTypeDeclaration typeName decCxt typeNameRPC tyVars mKind constructorsRPC + -- Slightly modify the deriving strategy so that the field/constructor + -- reordering function from original strategy acts on input field names in + -- RPC type after stripping RPC suffix. Fix for #811 + let + gs' = mangleGenericStrategyFields dropRPCSuffix $ + mangleGenericStrategyConstructors dropRPCSuffix gs + mconcat <$> sequence [ pure . one $ typeDecOfRPC , one <$> mkAsRPCInstance fieldTypes derivedType derivedTypeRPC , mkIsoValueInstance fieldTypesRPC derivedTypeRPC - , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs + , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs' ] where @@ -440,6 +454,9 @@ convertNameStr :: String -> String convertNameStr s = s <> "RPC" + dropRPCSuffix :: Text -> Text + dropRPCSuffix = fromMaybe (error "Unexpected field/constructor without RPC suffix") . T.stripSuffix "RPC" + convertName :: Name -> Name convertName = mkName . convertNameStr . nameBase @@ -469,7 +486,7 @@ InfixC field1 _ field2 -> pure [snd field1, snd field2] constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show (ppr constr) - mkTypeDeclaration :: Name -> Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [Con] -> Q Dec + mkTypeDeclaration :: Name -> Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> [Con] -> Q Dec mkTypeDeclaration tyName decCxt typeNameRPC tyVars mKind constructorsRPC = do typeInfo <- reify tyName case typeInfo of @@ -485,9 +502,16 @@ -- 1. Inspect its metadata and append @RPC@ to the type/constructor/field names. -- 2. Convert field types (e.g. @T@ becomes @AsRPC T@). -- 3. Replace the Rep's module name with the name of the module of where this Q is being spliced. - convertRep :: String -> TySynEqn -> Type - convertRep currentModuleName (TySynEqn _tyVars _lhs rhs) = go rhs + convertRep :: String -> TySynEqn -> [TyVarBndr a] -> Type + convertRep currentModuleName (TySynEqn _tyVars lhs rhs) tvs = go rhs where + varMap = Map.fromList $ zip lhsTvs $ tvs <&> \case + PlainTV vName _ -> vName + KindedTV vName _ _ -> vName + lhsTvs = everything (<>) (mempty `mkQ` (maybe mempty pure . varTName)) lhs + varTName = \case + VarT v -> Just v + _ -> Nothing go :: Type -> Type go = \case -- Rename type name and module name @@ -505,8 +529,11 @@ -- Replace field type @T@ with @AsRPC T@ ConT x `AppT` fieldType | x == ''G.Rec0 - -> ConT x `AppT` convertFieldType fieldType + -> ConT x `AppT` (convertFieldType $ replaceVars fieldType) x `AppT` y -> go x `AppT` go y + x -> replaceVars x + replaceVars = \case + VarT v -> VarT $ fromMaybe v $ Map.lookup v varMap x -> x -- | Lookup the generic 'Rep' type instance for the given type. @@ -611,6 +638,7 @@ VBls12381Fr {} -> v VBls12381G1 {} -> v VBls12381G2 {} -> v + VTxRollupL2Address {} -> v -- | Replaces all bigmap IDs with their corresponding bigmap values. -- This is the inverse of `valueAsRPC`. @@ -629,6 +657,7 @@ (STChainId {}, _) -> pure v (STChest {}, _) -> pure v (STChestKey {}, _) -> pure v + (STTxRollupL2Address {}, _) -> pure v (STOption sMaybe, VOption vMaybe) -> withSingI sMaybe $ VOption <$> traverse (go sMaybe) vMaybe @@ -701,6 +730,7 @@ NTBls12381G1 {} -> notes NTBls12381G2 {} -> notes NTNever {} -> notes + NTTxRollupL2Address {} -> notes NTSaplingState {} -> notes NTSaplingTransaction {} -> notes @@ -750,6 +780,7 @@ STTimestamp {} -> Dict STAddress {} -> Dict STNever {} -> Dict + STTxRollupL2Address {} -> Dict STSaplingState _ -> Dict STSaplingTransaction _ -> Dict @@ -792,6 +823,7 @@ STChest {} -> Dict STChestKey {} -> Dict STNever {} -> Dict + STTxRollupL2Address {} -> Dict STSaplingState _ -> Dict STSaplingTransaction _ -> Dict @@ -835,6 +867,7 @@ STBls12381G2 {} -> Dict STTimestamp {} -> Dict STAddress {} -> Dict + STTxRollupL2Address {} -> Dict STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict @@ -877,6 +910,7 @@ STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict + STTxRollupL2Address {} -> Dict -- | A proof that @AsRPC (Value t)@ does not contain big_maps. rpcHasNoNestedBigMapsEvi @@ -922,6 +956,7 @@ STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict + STTxRollupL2Address {} -> Dict -- | A proof that if @t@ does not contain any contract values, then neither does @TAsRPC t@. rpcHasNoContractEvi @@ -970,6 +1005,7 @@ STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict + STTxRollupL2Address {} -> Dict -- | A proof that if @t@ is a valid storage type, then so is @TAsRPC t@. rpcStorageScopeEvi :: forall (t :: T). StorageScope t :- StorageScope (TAsRPC t) diff --git a/src/Morley/CLI.hs b/src/Morley/CLI.hs --- a/src/Morley/CLI.hs +++ b/src/Morley/CLI.hs @@ -12,6 +12,7 @@ , contractFileOption , nowOption , levelOption + , minBlockTimeOption , maxStepsOption , dbPathOption , txDataOption @@ -20,6 +21,8 @@ , valueOption , mutezOption , addressOption + , aliasOption + , addressOrAliasOption , onelineOption , entrypointOption , mTextOption @@ -42,6 +45,7 @@ import Morley.Michelson.Untyped (EpName) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) +import Morley.Tezos.Address.Alias (AddressOrAlias(..), Alias(..)) import Morley.Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds) import Morley.Tezos.Crypto import Morley.Util.CLI @@ -113,6 +117,14 @@ where parser = Opt.maybeReader (Just . read) +minBlockTimeOption :: Opt.Parser (Maybe Natural) +minBlockTimeOption = optional $ option parser $ + long "min-block-time" <> + metavar "NATURAL" <> + help "Minimum time between blocks" + where + parser = Opt.maybeReader (Just . read) + -- | Parser for gas limit on contract execution. maxStepsOption :: Opt.Parser Word64 maxStepsOption = mkCLOptionParser @@ -129,6 +141,20 @@ help "Path to DB with data which is used instead of real blockchain data" <> Opt.showDefault +aliasOption :: String -> Opt.Parser Alias +aliasOption key = fmap Alias . Opt.strOption $ + long key <> + metavar "ALIAS" <> + help "An alias to be associated with the originated contract's address, e.g: 'alice', 'bob'" + +-- | Generic parser to read an option of 'AddressOrAlias' type. +addressOrAliasOption + :: Maybe AddressOrAlias + -> "name" :! String + -> "help" :! String + -> Opt.Parser AddressOrAlias +addressOrAliasOption = mkCLOptionParser + -- | Parser for transaction parameters. txDataOption :: Opt.Parser TxData txDataOption = @@ -150,7 +176,7 @@ , tdAmount = amount } --- | Generic parser to read an option of 'KeyHash' type. +-- | Generic parser to read an option of t'KeyHash' type. keyHashOption :: Maybe KeyHash -> "name" :! String -> "help" :! String -> Opt.Parser KeyHash keyHashOption = mkCLOptionParser diff --git a/src/Morley/Micheline/Binary.hs b/src/Morley/Micheline/Binary.hs --- a/src/Morley/Micheline/Binary.hs +++ b/src/Morley/Micheline/Binary.hs @@ -37,8 +37,8 @@ buildExpr :: Expression -> Bi.Builder buildExpr = \case - ExpressionSeq xs -> buildWord8 2 <> buildDynamic buildList (DynamicSize xs) - ExpressionPrim (MichelinePrimAp prim args annots) -> case (args, annots) of + ExpSeq () xs -> buildWord8 2 <> buildDynamic buildList (DynamicSize xs) + ExpPrim () (MichelinePrimAp prim args annots) -> case (args, annots) of ([], []) -> buildWord8 3 <> buildPrim prim ([], _) -> buildWord8 4 <> buildPrim prim <> buildAnnotationList annots ([arg1], []) -> buildWord8 5 <> buildPrim prim <> buildExpr arg1 @@ -46,9 +46,9 @@ ([arg1, arg2], []) -> buildWord8 7 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2 ([arg1, arg2], _) -> buildWord8 8 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2 <> buildAnnotationList annots _ -> buildWord8 9 <> buildPrim prim <> buildDynamic buildList (DynamicSize args) <> buildAnnotationList annots - ExpressionString x -> buildWord8 1 <> buildDynamic buildText (DynamicSize x) - ExpressionInt x -> buildWord8 0 <> buildInteger x - ExpressionBytes x -> buildWord8 10 <> buildDynamic buildByteString (DynamicSize x) + ExpString () x -> buildWord8 1 <> buildDynamic buildText (DynamicSize x) + ExpInt () x -> buildWord8 0 <> buildInteger x + ExpBytes () x -> buildWord8 10 <> buildDynamic buildByteString (DynamicSize x) buildList :: [Expression] -> Bi.Builder buildList = foldMap buildExpr @@ -75,17 +75,17 @@ getExpr :: Bi.Get Expression getExpr = Bi.getWord8 >>= \case - 0 -> ExpressionInt <$> getInteger - 1 -> ExpressionString . unDynamicSize <$> (getDynamic getText) - 2 -> ExpressionSeq . unDynamicSize <$> (getDynamic getList) - 3 -> ExpressionPrim . (\pn -> MichelinePrimAp pn [] []) <$> getPrim - 4 -> ExpressionPrim <$> (flip MichelinePrimAp [] <$> getPrim <*> getAnnotationList) - 5 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (one <$> getExpr) <*> pure []) - 6 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (one <$> getExpr) <*> getAnnotationList) - 7 -> ExpressionPrim <$> ((\n a -> MichelinePrimAp n a []) <$> getPrim <*> replicateM 2 getExpr) - 8 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> replicateM 2 getExpr <*> getAnnotationList) - 9 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (unDynamicSize <$> (getDynamic getList)) <*> getAnnotationList) - 10 -> ExpressionBytes . unDynamicSize <$> (getDynamic getByteString) + 0 -> ExpInt () <$> getInteger + 1 -> ExpString () . unDynamicSize <$> (getDynamic getText) + 2 -> ExpSeq () . unDynamicSize <$> (getDynamic getList) + 3 -> ExpPrim () . (\pn -> MichelinePrimAp pn [] []) <$> getPrim + 4 -> ExpPrim () <$> (flip MichelinePrimAp [] <$> getPrim <*> getAnnotationList) + 5 -> ExpPrim () <$> (MichelinePrimAp <$> getPrim <*> (one <$> getExpr) <*> pure []) + 6 -> ExpPrim () <$> (MichelinePrimAp <$> getPrim <*> (one <$> getExpr) <*> getAnnotationList) + 7 -> ExpPrim () <$> ((\n a -> MichelinePrimAp n a []) <$> getPrim <*> replicateM 2 getExpr) + 8 -> ExpPrim () <$> (MichelinePrimAp <$> getPrim <*> replicateM 2 getExpr <*> getAnnotationList) + 9 -> ExpPrim () <$> (MichelinePrimAp <$> getPrim <*> (unDynamicSize <$> (getDynamic getList)) <*> getAnnotationList) + 10 -> ExpBytes () . unDynamicSize <$> (getDynamic getByteString) _ -> fail "invalid Micheline expression tag" getList :: Bi.Get [Expression] diff --git a/src/Morley/Micheline/Class.hs b/src/Morley/Micheline/Class.hs --- a/src/Morley/Micheline/Class.hs +++ b/src/Morley/Micheline/Class.hs @@ -5,991 +5,1024 @@ -- Micheline representation. module Morley.Micheline.Class ( ToExpression (..) - , FromExpressionError (..) - , FromExpression (..) - ) where - -import Control.Lens ((<>~)) -import Data.Bits (toIntegralSized) -import Data.Default (def) -import Data.Singletons (SingI(..), demote) -import Fmt (Buildable(..), indentF, pretty, unlinesF) - -import Morley.Micheline.Expression - (Annotation(..), Expression(..), MichelinePrimAp(..), _ExpressionPrim, isAnnotationField, - isAnnotationType, isAnnotationVariable, mkAnns, mpaAnnotsL, toAnnSet) -import Morley.Michelson.Text (mkMText, unMText) -import Morley.Michelson.TypeCheck - (TypeCheckMode(..), TypeCheckOptions(..), runTypeCheck, typeCheckingWith) -import Morley.Michelson.TypeCheck.Instr (typeCheckValue) -import Morley.Michelson.Typed - (Contract, HasNoOp, Instr, Notes(..), T(..), Value, Value'(..), fromUType, mkUType, rfAnyInstr, - toUType) -import Morley.Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized) -import Morley.Michelson.Untyped qualified as Untyped -import Morley.Michelson.Untyped.Annotation - (AnnotationSet(..), FieldAnn, FieldTag, RootAnn, TypeAnn, TypeTag, VarAnn, VarTag, annsCount, - emptyAnnSet, firstAnn, noAnn, secondAnn) -import Morley.Michelson.Untyped.Contract (ContractBlock(..), orderContractBlock) -import Morley.Michelson.Untyped.Instr (ExpandedInstr, ExpandedOp(..), InstrAbstract(..)) -import Morley.Michelson.Untyped.Type (Ty(..)) -import Morley.Michelson.Untyped.View - --- | Type class that provides an ability to convert --- something to Micheline Expression. -class ToExpression a where - toExpression :: a -> Expression - -instance (HasNoOp t) => ToExpression (Value t) where - toExpression = toExpression . untypeValueOptimized - -instance ToExpression Untyped.Value where - toExpression = \case - Untyped.ValueInt v -> ExpressionInt v - Untyped.ValueString s -> ExpressionString $ unMText s - Untyped.ValueBytes (Untyped.InternalByteString bs) -> ExpressionBytes bs - Untyped.ValueUnit -> PrimExpr "Unit" [] [] - Untyped.ValueTrue -> PrimExpr "True" [] [] - Untyped.ValueFalse -> PrimExpr "False" [] [] - Untyped.ValuePair l r -> - PrimExpr "Pair" [toExpression l, toExpression r] [] - Untyped.ValueLeft v -> PrimExpr "Left" [toExpression v] [] - Untyped.ValueRight v -> PrimExpr "Right" [toExpression v] [] - Untyped.ValueSome v -> PrimExpr "Some" [toExpression v] [] - Untyped.ValueNone -> PrimExpr "None" [] [] - Untyped.ValueNil -> ExpressionSeq [] - Untyped.ValueSeq vs -> toExpression vs - Untyped.ValueMap elts -> toExpression $ eltToExpr <$> elts - Untyped.ValueLambda ops -> toExpression ops - where - eltToExpr :: Untyped.Elt ExpandedOp -> Expression - eltToExpr (Untyped.Elt l r) = PrimExpr "Elt" - [toExpression l, toExpression r] [] - - -instance ToExpression (Instr inp out) where - toExpression = toExpression . instrToOpsOptimized - -instance ToExpression T where - toExpression = toExpression . toUType - -instance ToExpression (Notes t) where - toExpression = toExpression . mkUType - -instance ToExpression Untyped.T where - toExpression = \case - Untyped.TKey -> PrimExpr "key" [] [] - Untyped.TUnit -> PrimExpr "unit" [] [] - Untyped.TSignature -> PrimExpr "signature" [] [] - Untyped.TChainId -> PrimExpr "chain_id" [] [] - Untyped.TOption arg -> PrimExpr "option" [toExpression arg] [] - Untyped.TList arg -> PrimExpr "list" [toExpression arg] [] - Untyped.TSet arg -> PrimExpr "set" [toExpression arg] [] - Untyped.TOperation -> PrimExpr "operation" [] [] - Untyped.TContract arg -> PrimExpr "contract" [toExpression arg] [] - Untyped.TTicket arg -> PrimExpr "ticket" [toExpression arg] [] - t@Untyped.TPair{} -> PrimExpr "pair" - (rightCombedPairToList (Ty t noAnn) (noAnn, noAnn)) [] - Untyped.TOr fa1 fa2 l r -> - let exprL = addTrimmedAnns (toExpression l) [] [fa1] [] - exprR = addTrimmedAnns (toExpression r) [] [fa2] [] - in PrimExpr "or" [exprL, exprR] [] - Untyped.TLambda inp out -> - PrimExpr "lambda" [toExpression inp, toExpression out] [] - Untyped.TMap k v -> - PrimExpr "map" [toExpression k, toExpression v] [] - Untyped.TBigMap k v -> - PrimExpr "big_map" [toExpression k, toExpression v] [] - Untyped.TInt -> PrimExpr "int" [] [] - Untyped.TNat -> PrimExpr "nat" [] [] - Untyped.TString -> PrimExpr "string" [] [] - Untyped.TBytes -> PrimExpr "bytes" [] [] - Untyped.TMutez -> PrimExpr "mutez" [] [] - Untyped.TBool -> PrimExpr "bool" [] [] - Untyped.TKeyHash -> PrimExpr "key_hash" [] [] - Untyped.TBls12381Fr -> PrimExpr "bls12_381_fr" [] [] - Untyped.TBls12381G1 -> PrimExpr "bls12_381_g1" [] [] - Untyped.TBls12381G2 -> PrimExpr "bls12_381_g2" [] [] - Untyped.TTimestamp -> PrimExpr "timestamp" [] [] - Untyped.TAddress -> PrimExpr "address" [] [] - Untyped.TChest -> PrimExpr "chest" [] [] - Untyped.TChestKey -> PrimExpr "chest_key" [] [] - Untyped.TNever -> PrimExpr "never" [] [] - Untyped.TSaplingState n -> PrimExpr "sapling_state" [naturalToExpr n] [] - Untyped.TSaplingTransaction n -> PrimExpr "sapling_transaction" [naturalToExpr n] [] - - where - addAnns :: Expression -> [Annotation] -> Expression - addAnns e anns = - e & _ExpressionPrim . mpaAnnotsL <>~ anns - - rightCombedPairToList :: Ty -> (FieldAnn, VarAnn) -> [Expression] - rightCombedPairToList ty (fa, va) = case (ty, fa) of - (Ty (Untyped.TPair fa1 fa2 va1 va2 l r) (Untyped.Annotation ""), Untyped.Annotation "") -> - let annsL = mkAnns [] [fa1] [va1] - exprL = toExpression l `addAnns` annsL - in exprL : (rightCombedPairToList r (fa2, va2)) - _ -> - let anns = mkAnns [] [fa] [va] - in one $ toExpression ty `addAnns` anns - -instance ToExpression Ty where - toExpression (Ty t ta) = addTrimmedAnns (toExpression t) [ta] [] [] - -instance (ToExpression a) => ToExpression [a] where - toExpression xs = ExpressionSeq $ toExpression <$> xs - -instance (ToExpression a) => ToExpression (NonEmpty a) where - toExpression = toExpression . toList - -instance ToExpression Expression where - toExpression = id - -instance ToExpression ExpandedOp where - toExpression = \case - PrimEx instr -> toExpression instr - SeqEx s -> ExpressionSeq $ toExpression <$> s - WithSrcEx _ op -> toExpression op - -instance ToExpression ViewName where - toExpression (ViewName s) = ExpressionString s - -instance ToExpression ExpandedInstr where - toExpression = \case - PUSH va ty v -> PrimExpr "PUSH" [toExpression ty, toExpression v] $ - mkAnns [] [] [va] - DROP -> PrimExpr "DROP" [] [] - DROPN n -> PrimExpr "DROP" [wordToExpr n] [] - DUP va -> PrimExpr "DUP" [] $ mkAnns [] [] [va] - DUPN va n -> PrimExpr "DUP" [wordToExpr n] $ mkAnns [] [] [va] - SWAP -> PrimExpr "SWAP" [] [] - DIG n -> PrimExpr "DIG" [wordToExpr n] [] - DUG n -> PrimExpr "DUG" [wordToExpr n] [] - SOME ta va -> - PrimExpr "SOME" [] $ mkAnns [ta] [] [va] - NONE ta va ty -> PrimExpr "NONE" [toExpression ty] $ mkAnns [ta] [] [va] - UNIT ta va -> PrimExpr "UNIT" [] $ mkAnns [ta] [] [va] - IF_NONE ops1 ops2 -> - PrimExpr "IF_NONE" [toExpression ops1, toExpression ops2] [] - PAIR ta va fa1 fa2 -> PrimExpr "PAIR" [] $ mkAnns [ta] [fa1, fa2] [va] - UNPAIR va1 va2 fa1 fa2 -> PrimExpr "UNPAIR" [] $ - mkAnns [] [fa1, fa2] [va1, va2] - PAIRN va n -> PrimExpr "PAIR" [wordToExpr n] $ mkAnns [] [] [va] - UNPAIRN n -> PrimExpr "UNPAIR" [wordToExpr n] [] - CAR va fa -> PrimExpr "CAR" [] $ mkAnns [] [fa] [va] - CDR va fa -> PrimExpr "CDR" [] $ mkAnns [] [fa] [va] - LEFT ta va fa1 fa2 ty -> PrimExpr "LEFT" [toExpression ty] $ - mkAnns [ta] [fa1, fa2] [va] - RIGHT ta va fa1 fa2 ty -> PrimExpr "RIGHT" [toExpression ty] $ - mkAnns [ta] [fa1, fa2] [va] - IF_LEFT ops1 ops2 -> - PrimExpr "IF_LEFT" [toExpression ops1, toExpression ops2] [] - NIL ta va ty -> PrimExpr "NIL" [toExpression ty] $ - mkAnns [ta] [] [va] - CONS va -> PrimExpr "CONS" [] $ mkAnns [] [] [va] - IF_CONS ops1 ops2 -> - PrimExpr "IF_CONS" [toExpression ops1, toExpression ops2] [] - SIZE va -> PrimExpr "SIZE" [] $ mkAnns [] [] [va] - EMPTY_SET ta va ty -> PrimExpr "EMPTY_SET" [toExpression ty] $ - mkAnns [ta] [] [va] - EMPTY_MAP ta va kty vty -> - PrimExpr "EMPTY_MAP" [toExpression kty, toExpression vty] $ - mkAnns [ta] [] [va] - EMPTY_BIG_MAP ta va kty vty -> - PrimExpr "EMPTY_BIG_MAP" [toExpression kty, toExpression vty] $ - mkAnns [ta] [] [va] - MAP va ops -> PrimExpr "MAP" [toExpression ops] $ mkAnns [] [] [va] - ITER ops -> PrimExpr "ITER" [toExpression ops] [] - MEM va -> PrimExpr "MEM" [] $ mkAnns [] [] [va] - GET va -> PrimExpr "GET" [] $ mkAnns [] [] [va] - GETN va n -> PrimExpr "GET" [wordToExpr n] $ mkAnns [] [] [va] - UPDATE va -> PrimExpr "UPDATE" [] $ mkAnns [] [] [va] - UPDATEN va n -> PrimExpr "UPDATE" [wordToExpr n] $ mkAnns [] [] [va] - GET_AND_UPDATE va -> PrimExpr "GET_AND_UPDATE" [] $ mkAnns [] [] [va] - IF ops1 ops2 -> - PrimExpr "IF" [toExpression ops1, toExpression ops2] [] - LOOP ops -> PrimExpr "LOOP" [toExpression ops] [] - LOOP_LEFT ops -> PrimExpr "LOOP_LEFT" [toExpression ops] [] - LAMBDA va tyin tyout ops -> - PrimExpr "LAMBDA" [ toExpression tyin - , toExpression tyout - , toExpression ops - ] $ mkAnns [] [] [va] - EXEC va -> PrimExpr "EXEC" [] $ mkAnns [] [] [va] - APPLY va -> PrimExpr "APPLY" [] $ mkAnns [] [] [va] - DIP ops -> PrimExpr "DIP" [toExpression ops] [] - DIPN n ops -> PrimExpr "DIP" [wordToExpr n, toExpression ops] [] - FAILWITH -> PrimExpr "FAILWITH" [] [] - CAST va ty -> PrimExpr "CAST" [toExpression ty] $ mkAnns [] [] [va] - RENAME va -> PrimExpr "RENAME" [] $ mkAnns [] [] [va] - PACK va -> PrimExpr "PACK" [] $ mkAnns [] [] [va] - UNPACK ta va ty -> PrimExpr "UNPACK" [toExpression ty] $ - mkAnns [ta] [] [va] - CONCAT va -> PrimExpr "CONCAT" [] $ mkAnns [] [] [va] - SLICE va -> PrimExpr "SLICE" [] $ mkAnns [] [] [va] - ISNAT va -> PrimExpr "ISNAT" [] $ mkAnns [] [] [va] - ADD va -> PrimExpr "ADD" [] $ mkAnns [] [] [va] - SUB va -> PrimExpr "SUB" [] $ mkAnns [] [] [va] - SUB_MUTEZ va -> PrimExpr "SUB_MUTEZ" [] $ mkAnns [] [] [va] - MUL va -> PrimExpr "MUL" [] $ mkAnns [] [] [va] - EDIV va -> PrimExpr "EDIV" [] $ mkAnns [] [] [va] - ABS va -> PrimExpr "ABS" [] $ mkAnns [] [] [va] - NEG va -> PrimExpr "NEG" [] $ mkAnns [] [] [va] - LSL va -> PrimExpr "LSL" [] $ mkAnns [] [] [va] - LSR va -> PrimExpr "LSR" [] $ mkAnns [] [] [va] - OR va -> PrimExpr "OR" [] $ mkAnns [] [] [va] - AND va -> PrimExpr "AND" [] $ mkAnns [] [] [va] - XOR va -> PrimExpr "XOR" [] $ mkAnns [] [] [va] - NOT va -> PrimExpr "NOT" [] $ mkAnns [] [] [va] - COMPARE va -> PrimExpr "COMPARE" [] $ mkAnns [] [] [va] - Untyped.EQ va -> PrimExpr "EQ" [] $ mkAnns [] [] [va] - NEQ va -> PrimExpr "NEQ" [] $ mkAnns [] [] [va] - Untyped.LT va -> PrimExpr "LT" [] $ mkAnns [] [] [va] - Untyped.GT va -> PrimExpr "GT" [] $ mkAnns [] [] [va] - LE va -> PrimExpr "LE" [] $ mkAnns [] [] [va] - GE va -> PrimExpr "GE" [] $ mkAnns [] [] [va] - INT va -> PrimExpr "INT" [] $ mkAnns [] [] [va] - VIEW va n t -> PrimExpr "VIEW" [toExpression n, toExpression t] $ - mkAnns [] [] [va] - SELF va fa -> PrimExpr "SELF" [] $ mkAnns [] [fa] [va] - CONTRACT va fa ty -> PrimExpr "CONTRACT" [toExpression ty] $ - mkAnns [] [fa] [va] - TRANSFER_TOKENS va -> PrimExpr "TRANSFER_TOKENS" [] $ mkAnns [] [] [va] - SET_DELEGATE va -> PrimExpr "SET_DELEGATE" [] $ mkAnns [] [] [va] - CREATE_CONTRACT va1 va2 c -> - PrimExpr "CREATE_CONTRACT" [toExpression c] $ - mkAnns [] [] [va1, va2] - IMPLICIT_ACCOUNT va -> PrimExpr "IMPLICIT_ACCOUNT" [] $ - mkAnns [] [] [va] - NOW va -> PrimExpr "NOW" [] $ mkAnns [] [] [va] - AMOUNT va -> PrimExpr "AMOUNT" [] $ mkAnns [] [] [va] - BALANCE va -> PrimExpr "BALANCE" [] $ mkAnns [] [] [va] - VOTING_POWER va -> PrimExpr "VOTING_POWER" [] $ mkAnns [] [] [va] - TOTAL_VOTING_POWER va -> PrimExpr "TOTAL_VOTING_POWER" [] $ - mkAnns [] [] [va] - CHECK_SIGNATURE va -> PrimExpr "CHECK_SIGNATURE" [] $ mkAnns [] [] [va] - SHA256 va -> PrimExpr "SHA256" [] $ mkAnns [] [] [va] - SHA512 va -> PrimExpr "SHA512" [] $ mkAnns [] [] [va] - BLAKE2B va -> PrimExpr "BLAKE2B" [] $ mkAnns [] [] [va] - SHA3 va -> PrimExpr "SHA3" [] $ mkAnns [] [] [va] - KECCAK va -> PrimExpr "KECCAK" [] $ mkAnns [] [] [va] - HASH_KEY va -> PrimExpr "HASH_KEY" [] $ mkAnns [] [] [va] - PAIRING_CHECK va -> PrimExpr "PAIRING_CHECK" [] $ mkAnns [] [] [va] - SOURCE va -> PrimExpr "SOURCE" [] $ mkAnns [] [] [va] - SENDER va -> PrimExpr "SENDER" [] $ mkAnns [] [] [va] - ADDRESS va -> PrimExpr "ADDRESS" [] $ mkAnns [] [] [va] - CHAIN_ID va -> PrimExpr "CHAIN_ID" [] $ mkAnns [] [] [va] - LEVEL va -> PrimExpr "LEVEL" [] $ mkAnns [] [] [va] - SELF_ADDRESS va -> PrimExpr "SELF_ADDRESS" [] $ mkAnns [] [] [va] - TICKET va -> PrimExpr "TICKET" [] $ mkAnns [] [] [va] - READ_TICKET va -> PrimExpr "READ_TICKET" [] $ mkAnns [] [] [va] - SPLIT_TICKET va -> PrimExpr "SPLIT_TICKET" [] $ mkAnns [] [] [va] - JOIN_TICKETS va -> PrimExpr "JOIN_TICKETS" [] $ mkAnns [] [] [va] - OPEN_CHEST va -> PrimExpr "OPEN_CHEST" [] $ mkAnns [] [] [va] - NEVER -> PrimExpr "NEVER" [] [] - EXT _ -> ExpressionSeq [] - SAPLING_EMPTY_STATE va n -> PrimExpr "SAPLING_EMPTY_STATE" [naturalToExpr n] $ mkAnns [] [] [va] - SAPLING_VERIFY_UPDATE va -> PrimExpr "SAPLING_VERIFY_UPDATE" [] $ mkAnns [] [] [va] - -instance ToExpression Untyped.Contract where - toExpression contract - = ExpressionSeq $ Untyped.mapEntriesOrdered contract - (\(Untyped.ParameterType ty rootAnn) -> PrimExpr "parameter" - [insertRootAnn (toExpression ty) rootAnn] []) - (\storage -> PrimExpr "storage" [toExpression storage] []) - (\code -> PrimExpr "code" [toExpression code] []) - (\Untyped.View{..} -> PrimExpr "view" - [toExpression viewName, toExpression viewArgument, toExpression viewReturn, toExpression viewCode] [] - ) - -instance ToExpression (Contract cp st) where - toExpression = toExpression . convertContract - --- | Errors that can happen when we convert an 'Expression' to our --- data type. -data FromExpressionError = FromExpressionError Expression Text - deriving stock (Show, Eq) - -instance Buildable FromExpressionError where - build (FromExpressionError expr err) = - unlinesF - [ "Failed to convert expression:" - , indentF 2 $ build expr - , "" - , "Error:" - , indentF 2 $ build err - ] - -instance Exception FromExpressionError where - displayException = pretty - --- | Type class that provides the ability to convert --- something from a Micheline Expression. -class FromExpression a where - fromExpression :: Expression -> Either FromExpressionError a - -instance (SingI t) => FromExpression (Value t) where - fromExpression expr = - case fromExpression @Untyped.Value expr of - Right uv -> case typeCheck uv of - Left tcErr -> Left $ FromExpressionError expr $ - pretty $ unlinesF - [ "Failed to typecheck expression as a value of type:" - , indentF 2 $ build $ demote @t - , "" - , "Typechecker error:" - , indentF 2 $ build tcErr - ] - Right tv -> Right tv - Left e -> Left e - where - typeCheck uv = typeCheckingWith (TypeCheckOptions False False) $ - (runTypeCheck $ TypeCheckValue (uv, demote @t)) $ - usingReaderT def $ - typeCheckValue uv - -instance FromExpression Untyped.Value where - fromExpression e = case e of - ExpressionInt v -> pure $ Untyped.ValueInt v - ExpressionString s -> first (FromExpressionError e) - (Untyped.ValueString <$> mkMText s) - ExpressionBytes bs -> pure $ Untyped.ValueBytes $ Untyped.InternalByteString bs - PrimExpr "Unit" [] [] -> pure Untyped.ValueUnit - PrimExpr "True" [] [] -> pure Untyped.ValueTrue - PrimExpr "False" [] [] -> pure Untyped.ValueFalse - PrimExpr "Pair" [l, r] [] -> do - l' <- fromExpression l - r' <- fromExpression r - pure $ Untyped.ValuePair l' r' - PrimExpr "Pair" args [] -> - case (nonEmpty args) >>= forbidSingletonList of - Nothing -> Left $ FromExpressionError e - "Expected a pair with at least 2 arguments" - Just args' -> fromExpression $ seqToPairExpr args' "Pair" - PrimExpr "Left" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.ValueLeft arg' - PrimExpr "Right" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.ValueRight arg' - PrimExpr "Some" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.ValueSome arg' - PrimExpr "None" [] [] -> pure Untyped.ValueNone - ExpressionSeq [] -> pure Untyped.ValueNil - ExpressionSeq (h : t) -> - case fromExpression @Untyped.ExpandedOp h of - Right op -> do - ops <- traverse (fromExpression @Untyped.ExpandedOp) t - pure . Untyped.ValueLambda $ op :| ops - Left _ -> case exprToElt h of - Right elt -> do - elts <- traverse exprToElt t - pure . Untyped.ValueMap $ elt :| elts - Left _ -> case fromExpression h of - Left (FromExpressionError err _) -> Left $ FromExpressionError err - "Value, instruction or 'Elt' expression expected" - Right h' -> do - t' <- traverse fromExpression t - pure . Untyped.ValueSeq $ h' :| t' - _ -> Left $ FromExpressionError e "Expected a value" - where - exprToElt :: Expression -> Either FromExpressionError (Untyped.Elt ExpandedOp) - exprToElt ex = case ex of - PrimExpr "Elt" [l, r] [] -> do - l' <- fromExpression l - r' <- fromExpression r - pure $ Untyped.Elt l' r' - PrimExpr "Elt" _ [] -> Left $ FromExpressionError ex - "Expected 'Elt' expression with exactly 2 elements" - PrimExpr "Elt" _ _ -> Left $ FromExpressionError ex - "Expected 'Elt' expression without annotations" - _ -> Left $ FromExpressionError ex "Expected 'Elt' expression" - -instance (FromExpression a) => FromExpression [a] where - fromExpression = \case - ExpressionSeq exprs -> traverse fromExpression exprs - e -> Left $ FromExpressionError e "'ExpressionSeq' expected" - -instance FromExpression ExpandedOp where - fromExpression = \case - ExpressionSeq s -> SeqEx <$> traverse fromExpression s - e -> PrimEx <$> fromExpression e - -instance FromExpression ExpandedInstr where - fromExpression e = let annSet = getAnnSet e in case e of - PrimExpr "DROP" [n] [] -> do - n' <- intExprToWord n - pure $ DROPN n' - PrimExpr "DROP" [] _ -> pure $ DROP - PrimExpr "DUP" [n] _ -> do - checkAnnsCount e annSet (0, 0, 1) - let va = firstAnn @VarTag annSet - n' <- intExprToWord n - pure $ DUPN va n' - PrimExpr "DUP" [] _ -> - let va = firstAnn @VarTag annSet - in checkAnnsCount e annSet (0, 0, 1) $> DUP va - PrimExpr "SWAP" [] [] -> pure $ SWAP - PrimExpr "DIG" [n] [] -> do - n' <- intExprToWord n - pure $ DIG $ n' - PrimExpr "DUG" [n] [] -> do - n' <- intExprToWord n - pure $ DUG n' - PrimExpr "PUSH" [t, v] _ -> do - checkAnnsCount e annSet (0, 0, 1) - let va = firstAnn @VarTag annSet - t' <- fromExpression @Ty t - v' <- fromExpression @Untyped.Value v - pure $ PUSH va t' v' - PrimExpr "SOME" [] _ -> - let ta = firstAnn @TypeTag annSet - va = firstAnn @VarTag annSet - in checkAnnsCount e annSet (1, 0, 1) $> SOME ta va - PrimExpr "NONE" [t] _ -> do - checkAnnsCount e annSet (1, 0, 1) - let ta = firstAnn @TypeTag annSet - let va = firstAnn @VarTag annSet - t' <- fromExpression @Ty t - pure $ NONE ta va t' - PrimExpr "UNIT" [] _ -> - let ta = firstAnn @TypeTag annSet - va = firstAnn @VarTag annSet - in checkAnnsCount e annSet (1, 0, 1) $> UNIT ta va - PrimExpr "IF_NONE" [ops1, ops2] [] -> do - ops1' <- fromExpression @([ExpandedOp]) ops1 - ops2' <- fromExpression @([ExpandedOp]) ops2 - pure $ IF_NONE ops1' ops2' - PrimExpr "PAIR" [] _ -> - let ta = firstAnn @TypeTag annSet - va = firstAnn @VarTag annSet - fa1 = firstAnn @FieldTag annSet - fa2 = secondAnn @FieldTag annSet - in (checkAnnsCount e annSet (1, 2, 1)) $> PAIR ta va fa1 fa2 - PrimExpr "UNPAIR" [] _ -> - let va1 = firstAnn @VarTag annSet - va2 = secondAnn @VarTag annSet - fa1 = firstAnn @FieldTag annSet - fa2 = secondAnn @FieldTag annSet - in checkAnnsCount e annSet (0, 2, 2) $> UNPAIR va1 va2 fa1 fa2 - PrimExpr "PAIR" [n] _ -> do - checkAnnsCount e annSet (0, 0, 1) - n' <- intExprToWord n - let va = firstAnn @VarTag annSet - pure $ PAIRN va n' - PrimExpr "UNPAIR" [n] [] -> do - n' <- intExprToWord n - pure $ UNPAIRN n' - PrimExpr "CAR" [] _ -> - let va = firstAnn @VarTag annSet - fa = firstAnn @FieldTag annSet - in checkAnnsCount e annSet (0, 1, 1) $> CAR va fa - PrimExpr "CDR" [] _ -> - let va = firstAnn @VarTag annSet - fa = firstAnn @FieldTag annSet - in checkAnnsCount e annSet (0, 1, 1) $> CDR va fa - PrimExpr "LEFT" [t] _ -> do - checkAnnsCount e annSet (1, 2, 1) - t' <- fromExpression @Ty t - let ta = firstAnn @TypeTag annSet - let va = firstAnn @VarTag annSet - let fa1 = firstAnn @FieldTag annSet - let fa2 = secondAnn @FieldTag annSet - pure $ LEFT ta va fa1 fa2 t' - PrimExpr "RIGHT" [t] _ -> do - checkAnnsCount e annSet (1, 2, 1) - t' <- fromExpression @Ty t - let ta = firstAnn @TypeTag annSet - let va = firstAnn @VarTag annSet - let fa1 = firstAnn @FieldTag annSet - let fa2 = secondAnn @FieldTag annSet - pure $ RIGHT ta va fa1 fa2 t' - PrimExpr "IF_LEFT" [ops1, ops2] [] -> do - ops1' <- fromExpression @([ExpandedOp]) ops1 - ops2' <- fromExpression @([ExpandedOp]) ops2 - pure $ IF_LEFT ops1' ops2' - PrimExpr "NIL" [t] _ -> do - checkAnnsCount e annSet (1, 0, 1) - t' <- fromExpression @Ty t - let va = firstAnn @VarTag annSet - let ta = firstAnn @TypeTag annSet - pure $ NIL ta va t' - PrimExpr "CONS" [] anns -> mkInstrWithVarAnn CONS anns - PrimExpr "IF_CONS" [ops1, ops2] [] -> do - ops1' <- fromExpression @([ExpandedOp]) ops1 - ops2' <- fromExpression @([ExpandedOp]) ops2 - pure $ IF_CONS ops1' ops2' - PrimExpr "SIZE" [] anns -> mkInstrWithVarAnn SIZE anns - PrimExpr "EMPTY_SET" [t] _ -> do - checkAnnsCount e annSet (1, 0, 1) - t' <- fromExpression @Ty t - let va = firstAnn @VarTag annSet - let ta = firstAnn @TypeTag annSet - pure $ EMPTY_SET ta va t' - PrimExpr "EMPTY_MAP" [kt, vt] _ -> do - checkAnnsCount e annSet (1, 0, 1) - kt' <- fromExpression @Ty kt - vt' <- fromExpression @Ty vt - let va = firstAnn @VarTag annSet - let ta = firstAnn @TypeTag annSet - pure $ EMPTY_MAP ta va kt' vt' - PrimExpr "EMPTY_BIG_MAP" [kt, vt] _ -> do - checkAnnsCount e annSet (1, 0, 1) - kt' <- fromExpression @Ty kt - vt' <- fromExpression @Ty vt - let va = firstAnn @VarTag annSet - let ta = firstAnn @TypeTag annSet - pure $ EMPTY_BIG_MAP ta va kt' vt' - PrimExpr "MAP" [ops] _ -> do - checkAnnsCount e annSet (0, 0, 1) - ops' <- fromExpression @([ExpandedOp]) ops - let va = firstAnn @VarTag annSet - pure $ MAP va ops' - PrimExpr "ITER" [ops] [] -> do - ops' <- fromExpression @([ExpandedOp]) ops - pure $ ITER ops' - PrimExpr "MEM" [] anns -> mkInstrWithVarAnn MEM anns - PrimExpr "GET" [] anns -> mkInstrWithVarAnn GET anns - PrimExpr "GET" [n] _ -> do - checkAnnsCount e annSet (0, 0, 1) - n' <- intExprToWord n - let va = firstAnn @VarTag annSet - pure $ GETN va n' - PrimExpr "UPDATE" [] anns -> mkInstrWithVarAnn UPDATE anns - PrimExpr "UPDATE" [n] _ -> do - checkAnnsCount e annSet (0, 0, 1) - n' <- intExprToWord n - let va = firstAnn @VarTag annSet - pure $ UPDATEN va n' - PrimExpr "GET_AND_UPDATE" [] anns -> - mkInstrWithVarAnn GET_AND_UPDATE anns - PrimExpr "IF" [ops1, ops2] [] -> do - ops1' <- fromExpression @([ExpandedOp]) ops1 - ops2' <- fromExpression @([ExpandedOp]) ops2 - pure $ IF ops1' ops2' - PrimExpr "LOOP" [ops] [] -> do - ops' <- fromExpression @([ExpandedOp]) ops - pure $ LOOP ops' - PrimExpr "LOOP_LEFT" [ops] [] -> do - ops' <- fromExpression @([ExpandedOp]) ops - pure $ LOOP_LEFT ops' - PrimExpr "LAMBDA" [inp, out, ops] _ -> do - checkAnnsCount e annSet (0, 0, 1) - inp' <- fromExpression @Ty inp - out' <- fromExpression @Ty out - ops' <- fromExpression @([ExpandedOp]) ops - let va = firstAnn @VarTag annSet - pure $ LAMBDA va inp' out' ops' - PrimExpr "EXEC" [] anns -> mkInstrWithVarAnn EXEC anns - PrimExpr "APPLY" [] anns -> mkInstrWithVarAnn APPLY anns - PrimExpr "DIP" [ops] [] -> do - ops' <- fromExpression @([ExpandedOp]) ops - pure $ DIP ops' - PrimExpr "DIP" [n, ops] [] -> do - n' <- intExprToWord n - ops' <- fromExpression @([ExpandedOp]) ops - pure $ DIPN n' ops' - PrimExpr "FAILWITH" [] [] -> pure FAILWITH - PrimExpr "CAST" [t] _ -> do - checkAnnsCount e annSet (0, 0, 1) - t' <- fromExpression @Ty t - let va = firstAnn @VarTag annSet - pure $ CAST va t' - PrimExpr "RENAME" [] anns -> mkInstrWithVarAnn RENAME anns - PrimExpr "PACK" [] anns -> mkInstrWithVarAnn PACK anns - PrimExpr "UNPACK" [t] _ -> do - checkAnnsCount e annSet (1, 0, 1) - t' <- fromExpression @Ty t - let ta = firstAnn @TypeTag annSet - let va = firstAnn @VarTag annSet - pure $ UNPACK ta va t' - PrimExpr "CONCAT" [] anns -> mkInstrWithVarAnn CONCAT anns - PrimExpr "SLICE" [] anns -> mkInstrWithVarAnn SLICE anns - PrimExpr "ISNAT" [] anns -> mkInstrWithVarAnn ISNAT anns - PrimExpr "ADD" [] anns -> mkInstrWithVarAnn ADD anns - PrimExpr "SUB" [] anns -> mkInstrWithVarAnn SUB anns - PrimExpr "SUB_MUTEZ" [] anns -> mkInstrWithVarAnn SUB_MUTEZ anns - PrimExpr "MUL" [] anns -> mkInstrWithVarAnn MUL anns - PrimExpr "EDIV" [] anns -> mkInstrWithVarAnn EDIV anns - PrimExpr "ABS" [] anns -> mkInstrWithVarAnn ABS anns - PrimExpr "NEG" [] anns -> mkInstrWithVarAnn NEG anns - PrimExpr "LSL" [] anns -> mkInstrWithVarAnn LSL anns - PrimExpr "LSR" [] anns -> mkInstrWithVarAnn LSR anns - PrimExpr "OR" [] anns -> mkInstrWithVarAnn OR anns - PrimExpr "AND" [] anns -> mkInstrWithVarAnn AND anns - PrimExpr "XOR" [] anns -> mkInstrWithVarAnn XOR anns - PrimExpr "NOT" [] anns -> mkInstrWithVarAnn NOT anns - PrimExpr "COMPARE" [] anns -> mkInstrWithVarAnn COMPARE anns - PrimExpr "EQ" [] anns -> mkInstrWithVarAnn Untyped.EQ anns - PrimExpr "NEQ" [] anns -> mkInstrWithVarAnn NEQ anns - PrimExpr "LT" [] anns -> mkInstrWithVarAnn Untyped.LT anns - PrimExpr "GT" [] anns -> mkInstrWithVarAnn Untyped.GT anns - PrimExpr "LE" [] anns -> mkInstrWithVarAnn LE anns - PrimExpr "GE" [] anns -> mkInstrWithVarAnn GE anns - PrimExpr "INT" [] anns -> mkInstrWithVarAnn INT anns - PrimExpr "VIEW" [name, t] _ -> do - let va = firstAnn @VarTag annSet - name' <- fromExpression @ViewName name - t' <- fromExpression @Ty t - checkAnnsCount e annSet (0, 0, 1) $> VIEW va name' t' - PrimExpr "SELF" [] _ -> - let fa = firstAnn @FieldTag annSet - va = firstAnn @VarTag annSet - in checkAnnsCount e annSet (0, 1, 1) $> SELF va fa - PrimExpr "CONTRACT" [t] _ -> do - checkAnnsCount e annSet (0, 1, 1) - t' <- fromExpression @Ty t - let va = firstAnn @VarTag annSet - let fa = firstAnn @FieldTag annSet - pure $ CONTRACT va fa t' - PrimExpr "TRANSFER_TOKENS" [] anns -> - mkInstrWithVarAnn TRANSFER_TOKENS anns - PrimExpr "SET_DELEGATE" [] anns -> - mkInstrWithVarAnn SET_DELEGATE anns - PrimExpr "CREATE_CONTRACT" [c] _ -> do - checkAnnsCount e annSet (0, 0, 2) - c' <- fromExpression @Untyped.Contract c - let va1 = firstAnn @VarTag annSet - let va2 = secondAnn @VarTag annSet - pure $ CREATE_CONTRACT va1 va2 c' - PrimExpr "IMPLICIT_ACCOUNT" [] anns -> - mkInstrWithVarAnn IMPLICIT_ACCOUNT anns - PrimExpr "NOW" [] anns -> mkInstrWithVarAnn NOW anns - PrimExpr "AMOUNT" [] anns -> mkInstrWithVarAnn AMOUNT anns - PrimExpr "BALANCE" [] anns -> mkInstrWithVarAnn BALANCE anns - PrimExpr "VOTING_POWER" [] anns -> - mkInstrWithVarAnn VOTING_POWER anns - PrimExpr "TOTAL_VOTING_POWER" [] anns -> - mkInstrWithVarAnn TOTAL_VOTING_POWER anns - PrimExpr "CHECK_SIGNATURE" [] anns -> - mkInstrWithVarAnn CHECK_SIGNATURE anns - PrimExpr "SHA256" [] anns -> mkInstrWithVarAnn SHA256 anns - PrimExpr "SHA512" [] anns -> mkInstrWithVarAnn SHA512 anns - PrimExpr "BLAKE2B" [] anns -> mkInstrWithVarAnn BLAKE2B anns - PrimExpr "SHA3" [] anns -> mkInstrWithVarAnn SHA3 anns - PrimExpr "KECCAK" [] anns -> mkInstrWithVarAnn KECCAK anns - PrimExpr "HASH_KEY" [] anns -> mkInstrWithVarAnn HASH_KEY anns - PrimExpr "PAIRING_CHECK" [] anns -> - mkInstrWithVarAnn PAIRING_CHECK anns - PrimExpr "SOURCE" [] anns -> mkInstrWithVarAnn SOURCE anns - PrimExpr "SENDER" [] anns -> mkInstrWithVarAnn SENDER anns - PrimExpr "ADDRESS" [] anns -> mkInstrWithVarAnn ADDRESS anns - PrimExpr "CHAIN_ID" [] anns -> mkInstrWithVarAnn CHAIN_ID anns - PrimExpr "LEVEL" [] anns -> mkInstrWithVarAnn LEVEL anns - PrimExpr "SELF_ADDRESS" [] anns -> - mkInstrWithVarAnn SELF_ADDRESS anns - PrimExpr "NEVER" [] [] -> pure NEVER - PrimExpr "TICKET" [] anns -> mkInstrWithVarAnn TICKET anns - PrimExpr "READ_TICKET" [] anns -> - mkInstrWithVarAnn READ_TICKET anns - PrimExpr "SPLIT_TICKET" [] anns -> - mkInstrWithVarAnn SPLIT_TICKET anns - PrimExpr "JOIN_TICKETS" [] anns -> - mkInstrWithVarAnn JOIN_TICKETS anns - _ -> Left $ FromExpressionError e "Expected an instruction" - - where - mkInstrWithVarAnn - :: (VarAnn -> ExpandedInstr) - -> [Annotation] - -> Either FromExpressionError ExpandedInstr - mkInstrWithVarAnn ctor anns = - let annSet = toAnnSet anns - va = firstAnn @VarTag annSet - in checkAnnsCount e annSet (0, 0, 1) $> ctor va - - getAnnSet :: Expression -> AnnotationSet - getAnnSet = \case - PrimExpr _ _ anns -> toAnnSet anns - _ -> emptyAnnSet - -instance FromExpression Untyped.Contract where - fromExpression blocks = case blocks of - ExpressionSeq bs -> do - bs' <- mapM exprToCB bs - maybeToRight (FromExpressionError blocks "Something's wrong with top-level contract blocks") - (orderContractBlock bs') - expr -> Left $ FromExpressionError expr "Failed to parse contract, expected sequence" - where - exprToCB - :: Expression - -> Either FromExpressionError (ContractBlock ExpandedOp) - exprToCB e = case e of - PrimExpr "parameter" args anns -> mkCbParam e args anns - PrimExpr "storage" args anns -> mkCBStorage e args anns - PrimExpr "code" args anns -> mkCBCode e args anns - PrimExpr "view" args anns -> mkCBView e args anns - _ -> - Left $ FromExpressionError e "Unexpected primitive at contract top-level" - - mkCbParam - :: Expression - -> [Expression] - -> [Annotation] - -> Either FromExpressionError (ContractBlock ExpandedOp) - mkCbParam e args anns = case (args, anns) of - ([p], []) -> do - let annSet = toAnnSet (p ^. _ExpressionPrim . mpaAnnotsL) - let rootAnn = firstAnn @FieldTag annSet - unless (secondAnn @FieldTag annSet == noAnn) $ - Left $ FromExpressionError p - "Expected parameter with at most 1 root annotation" - p' <- fromExpression @Ty - (p & _ExpressionPrim . mpaAnnotsL %~ filter (not . isAnnotationField)) - pure $ CBParam $ Untyped.ParameterType p' rootAnn - _ -> Left $ FromExpressionError e - "Expected 'parameter' block without annotations and exactly 1 argument" - - mkCBStorage - :: Expression - -> [Expression] - -> [Annotation] - -> Either FromExpressionError (ContractBlock ExpandedOp) - mkCBStorage e args anns = case (args, anns) of - ([s], []) -> do - s' <- fromExpression @Ty s - pure $ CBStorage s' - _ -> Left $ FromExpressionError e - "Expected 'storage' block without annotations and exactly 1 argument" - - mkCBCode - :: Expression - -> [Expression] - -> [Annotation] - -> Either FromExpressionError (ContractBlock ExpandedOp) - mkCBCode e args anns = case (args, anns) of - ([ops], []) -> do - ops' <- fromExpression @([ExpandedOp]) ops - pure $ CBCode ops' - _ -> Left $ FromExpressionError e - "Expected 'code' block without annotations" - - mkCBView - :: Expression - -> [Expression] - -> [Annotation] - -> Either FromExpressionError (ContractBlock ExpandedOp) - mkCBView e args anns = case (args, anns) of - ([name, arg, ret, ops], []) -> do - name' <- fromExpression name - arg' <- fromExpression arg - ret' <- fromExpression ret - ops' <- fromExpression @[ExpandedOp] ops - pure $ CBView $ Untyped.View name' arg' ret' ops' - (_, _ : _) -> - Left $ FromExpressionError e - "Expected 'view' block without annotations" - (_, []) -> - Left $ FromExpressionError e - "Invalid 'view' block, expected 4 expressions in it" - -instance FromExpression Untyped.T where - fromExpression e = case e of - PrimExpr "key" [] [] -> pure Untyped.TKey - PrimExpr "unit" [] [] -> pure Untyped.TUnit - PrimExpr "signature" [] [] -> pure Untyped.TSignature - PrimExpr "chain_id" [] [] -> pure Untyped.TChainId - PrimExpr "option" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.TOption arg' - PrimExpr "list" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.TList arg' - PrimExpr "set" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.TSet arg' - PrimExpr "operation" [] [] -> pure Untyped.TOperation - PrimExpr "contract" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.TContract arg' - PrimExpr "ticket" [arg] [] -> do - arg' <- fromExpression arg - pure $ Untyped.TTicket arg' - PrimExpr "or" [arg1, arg2] [] -> do - let as1 = toAnnSet $ arg1 ^. _ExpressionPrim . mpaAnnotsL - let as2 = toAnnSet $ arg2 ^. _ExpressionPrim . mpaAnnotsL - checkAnnsCount e as1 (1, 1, 0) - checkAnnsCount e as2 (1, 1, 0) - let fa1 = firstAnn @FieldTag as1 - let fa2 = firstAnn @FieldTag as2 - l <- fromExpression $ removeAnns arg1 isAnnotationField - r <- fromExpression $ removeAnns arg2 isAnnotationField - pure $ Untyped.TOr fa1 fa2 l r - PrimExpr "pair" [arg1, arg2] [] -> do - let as1 = toAnnSet $ arg1 ^. _ExpressionPrim . mpaAnnotsL - let as2 = toAnnSet $ arg2 ^. _ExpressionPrim . mpaAnnotsL - checkAnnsCount e as1 (1, 1, 1) - checkAnnsCount e as2 (1, 1, 1) - let fa1 = firstAnn @FieldTag as1 - let fa2 = firstAnn @FieldTag as2 - let va1 = firstAnn @VarTag as1 - let va2 = firstAnn @VarTag as2 - l <- fromExpression $ removeAnns arg1 - (isAnnotationField || isAnnotationVariable) - r <- fromExpression $ removeAnns arg2 - (isAnnotationField || isAnnotationVariable) - pure $ Untyped.TPair fa1 fa2 va1 va2 l r - PrimExpr "pair" args [] -> - case (nonEmpty args) >>= forbidSingletonList of - Nothing -> Left $ FromExpressionError e - "Expected a pair with at least 2 arguments" - Just args' -> fromExpression $ seqToPairExpr args' "pair" - PrimExpr "lambda" args [] -> mkDoubleParamType Untyped.TLambda args e - "Expected a lambda with input and output types" - PrimExpr "map" args [] -> mkDoubleParamType Untyped.TMap args e - "Expected a map with key and value types" - PrimExpr "big_map" args [] -> mkDoubleParamType Untyped.TBigMap args e - "Expected a big_map with key and value types" - PrimExpr "int" [] [] -> pure Untyped.TInt - PrimExpr "nat" [] [] -> pure Untyped.TNat - PrimExpr "string" [] [] -> pure Untyped.TString - PrimExpr "bytes" [] [] -> pure Untyped.TBytes - PrimExpr "mutez" [] [] -> pure Untyped.TMutez - PrimExpr "bool" [] [] -> pure Untyped.TBool - PrimExpr "key_hash" [] [] -> pure Untyped.TKeyHash - PrimExpr "bls12_381_fr" [] [] -> pure Untyped.TBls12381Fr - PrimExpr "bls12_381_g1" [] [] -> pure Untyped.TBls12381G1 - PrimExpr "bls12_381_g2" [] [] -> pure Untyped.TBls12381G2 - PrimExpr "timestamp" [] [] -> pure Untyped.TTimestamp - PrimExpr "address" [] [] -> pure Untyped.TAddress - PrimExpr "chest" [] [] -> pure Untyped.TChest - PrimExpr "chest_key" [] [] -> pure Untyped.TChestKey - PrimExpr "never" [] [] -> pure Untyped.TNever - PrimExpr "sapling_state" [n] [] -> do - n' <- natExprToNatural n - pure $ Untyped.TSaplingState n' - PrimExpr "sapling_transaction" [n] [] -> do - n' <- natExprToNatural n - pure $ Untyped.TSaplingState n' - _ -> Left $ FromExpressionError e "Expected a type" - where - mkDoubleParamType - :: (Ty -> Ty -> Untyped.T) - -> [Expression] - -> Expression - -> Text - -> Either FromExpressionError Untyped.T - mkDoubleParamType ctor args expr msg = do - case args of - [arg1, arg2] -> do - arg1' <- fromExpression arg1 - arg2' <- fromExpression arg2 - pure $ ctor arg1' arg2' - _ -> Left $ FromExpressionError expr msg - - removeAnns :: Expression -> (Annotation -> Bool) -> Expression - removeAnns expr p = - expr & _ExpressionPrim . mpaAnnotsL %~ filter (not . p) - -instance FromExpression Ty where - fromExpression e = case e of - PrimExpr primName args anns -> do - let annSet = toAnnSet anns - let ta = firstAnn @TypeTag annSet - when (secondAnn @TypeTag annSet /= noAnn) $ - Left $ FromExpressionError e - "Expected expression with at most 1 type annotation" - t <- fromExpression @Untyped.T $ PrimExpr primName args $ filter - (not . isAnnotationType) anns - pure $ Ty t ta - _ -> Left $ FromExpressionError e "Expected a type" - -instance FromExpression T where - fromExpression = - second fromUType . fromExpression @Untyped.Ty - --- Note: we should generalize this to work for any instruction, --- not just lambdas (i.e. instructions with one input and one output). -instance (SingI inp, SingI out) => FromExpression (Instr '[inp] '[out]) where - fromExpression expr = - fromExpression @(Value ('TLambda inp out)) expr <&> \case - VLam instr -> rfAnyInstr instr - -instance FromExpression ViewName where - fromExpression e = case e of - ExpressionString s -> - first (FromExpressionError e . pretty) $ mkViewName s - _ -> Left $ FromExpressionError e "Expected view name" - ----------------------------------------------------------------------------- --- Helpers ----------------------------------------------------------------------------- - --- | Converts a sequence of expression to the right combed pair. -seqToPairExpr :: NonEmpty Expression -> Text -> Expression -seqToPairExpr e name = foldr1 (\x xs -> PrimExpr name [x, xs] []) e - --- | Adds annotations to the expression, after removing empty annotations --- at the end of each list. -addTrimmedAnns - :: Expression - -> [TypeAnn] - -> [FieldAnn] - -> [VarAnn] - -> Expression -addTrimmedAnns e tas fas vas = - e & _ExpressionPrim . mpaAnnotsL <>~ mkAnns tas fas vas - --- | Inserts the root annotation into the contract parameter. -insertRootAnn :: HasCallStack => Expression -> RootAnn -> Expression -insertRootAnn expr rootAnn = case expr of - ExpressionPrim p - -- The order of annotations is important iff there are - -- multiple annotations of the same kind or there are - -- other kinds of annotations in the list. - -- Prepending root field annotation is okay because - -- there can not be more than one root annotation. - | rootAnn /= noAnn -> ExpressionPrim p - { mpaAnnots = AnnotationField rootAnn : mpaAnnots p - } - | otherwise -> expr - -- Currently this error can't happen because parameter type - -- must be a Micheline primitive. If it ever changes, we - -- would like to notice it ASAP and update this place. - _ -> error $ "parameter is not a primitive: " <> pretty expr - --- | Checks for a given expression that the number of annotations --- of each type in it doesn't exceed the specified threshold. -checkAnnsCount - :: Expression - -> AnnotationSet - -> (Int, Int, Int) - -> Either FromExpressionError () -checkAnnsCount e annSet maxCount@(maxTas, maxFas, maxVas) = - let actualCount@(tasCnt, fasCnt, vasCnt) = annsCount annSet - in unless (actualCount <= maxCount) $ - Left $ FromExpressionError e $ pretty $ unlinesF - [ "Expected at most" - , indentF 2 $ build maxTas <> " type annotations," - , indentF 2 $ build maxFas <> " field annotations," - , indentF 2 $ build maxVas <> " variable annotations" - , "but found:" - , indentF 2 $ build tasCnt <> " type annotations," - , indentF 2 $ build fasCnt <> " field annotations," - , indentF 2 $ build vasCnt <> " variable annotations." - ] - -forbidSingletonList :: NonEmpty a -> Maybe (NonEmpty a) -forbidSingletonList = \case - _ :| [] -> Nothing - x -> Just x - -wordToExpr :: Word -> Expression -wordToExpr = toExpression @(Value 'TInt) . VInt . fromIntegral @Word @Integer - -intExprToWord :: Expression -> Either FromExpressionError Word -intExprToWord n = do - v <- fromExpression @(Value 'TInt) n - case v of - VInt n' -> maybeToRight (FromExpressionError n "Value is out of bounds") - (toIntegralSized @Integer @Word n') - -naturalToExpr :: Natural -> Expression -naturalToExpr = toExpression @(Value 'TNat) . VNat - -natExprToNatural :: Expression -> Either FromExpressionError Natural -natExprToNatural n = do - v <- fromExpression @(Value 'TNat) n - case v of - VNat n' -> Right n' + , FromExpError (..) + , FromExpressionError + , FromExp (..) + , FromExpression + , fromExpression + ) where + +import Control.Lens ((<>~)) +import Data.Bits (Bits) +import Data.Default (def) +import Data.Singletons (SingI(..), demote) +import Fmt (Buildable(..), indentF, pretty, unlinesF) + +import Morley.Micheline.Expression +import Morley.Michelson.Text (mkMText, unMText) +import Morley.Michelson.TypeCheck + (TypeCheckMode(..), TypeCheckOptions(..), runTypeCheck, typeCheckingWith) +import Morley.Michelson.TypeCheck.Instr (typeCheckValue) +import Morley.Michelson.Typed + (Contract, HasNoOp, Instr, Notes(..), T(..), Value, Value'(..), fromUType, mkUType, rfAnyInstr, + toUType) +import Morley.Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized) +import Morley.Michelson.Untyped qualified as Untyped +import Morley.Michelson.Untyped.Annotation + (AnnotationSet(..), FieldAnn, FieldTag, RootAnn, TypeAnn, TypeTag, VarAnn, VarTag, annsCount, + emptyAnnSet, firstAnn, noAnn, secondAnn) +import Morley.Michelson.Untyped.Contract (ContractBlock(..), orderContractBlock) +import Morley.Michelson.Untyped.Instr (ExpandedInstr, ExpandedOp(..), InstrAbstract(..)) +import Morley.Michelson.Untyped.Type (Ty(..)) +import Morley.Michelson.Untyped.View + +-- ToExpression +---------------------------------------------------------------------------- + +-- | Type class that provides an ability to convert +-- something to Micheline Expression. +class ToExpression a where + toExpression :: a -> Expression + +instance (HasNoOp t) => ToExpression (Value t) where + toExpression = toExpression . untypeValueOptimized + +instance ToExpression Untyped.Value where + toExpression = \case + Untyped.ValueInt v -> expressionInt v + Untyped.ValueString s -> expressionString $ unMText s + Untyped.ValueBytes (Untyped.InternalByteString bs) -> expressionBytes bs + Untyped.ValueUnit -> expressionPrim' "Unit" [] [] + Untyped.ValueTrue -> expressionPrim' "True" [] [] + Untyped.ValueFalse -> expressionPrim' "False" [] [] + Untyped.ValuePair l r -> + expressionPrim' "Pair" [toExpression l, toExpression r] [] + Untyped.ValueLeft v -> expressionPrim' "Left" [toExpression v] [] + Untyped.ValueRight v -> expressionPrim' "Right" [toExpression v] [] + Untyped.ValueSome v -> expressionPrim' "Some" [toExpression v] [] + Untyped.ValueNone -> expressionPrim' "None" [] [] + Untyped.ValueNil -> expressionSeq [] + Untyped.ValueSeq vs -> toExpression vs + Untyped.ValueMap elts -> toExpression $ eltToExpr <$> elts + Untyped.ValueLambda ops -> toExpression ops + where + eltToExpr :: Untyped.Elt ExpandedOp -> Expression + eltToExpr (Untyped.Elt l r) = expressionPrim' "Elt" + [toExpression l, toExpression r] [] + + +instance ToExpression (Instr inp out) where + toExpression = toExpression . instrToOpsOptimized + +instance ToExpression T where + toExpression = toExpression . toUType + +instance ToExpression (Notes t) where + toExpression = toExpression . mkUType + +instance ToExpression Untyped.T where + toExpression = \case + Untyped.TKey -> expressionPrim' "key" [] [] + Untyped.TUnit -> expressionPrim' "unit" [] [] + Untyped.TSignature -> expressionPrim' "signature" [] [] + Untyped.TChainId -> expressionPrim' "chain_id" [] [] + Untyped.TOption arg -> expressionPrim' "option" [toExpression arg] [] + Untyped.TList arg -> expressionPrim' "list" [toExpression arg] [] + Untyped.TSet arg -> expressionPrim' "set" [toExpression arg] [] + Untyped.TOperation -> expressionPrim' "operation" [] [] + Untyped.TContract arg -> expressionPrim' "contract" [toExpression arg] [] + Untyped.TTicket arg -> expressionPrim' "ticket" [toExpression arg] [] + t@Untyped.TPair{} -> expressionPrim' "pair" + (rightCombedPairToList (Ty t noAnn) (noAnn, noAnn)) [] + Untyped.TOr fa1 fa2 l r -> + let exprL = addTrimmedAnns (toExpression l) [] [fa1] [] + exprR = addTrimmedAnns (toExpression r) [] [fa2] [] + in expressionPrim' "or" [exprL, exprR] [] + Untyped.TLambda inp out -> + expressionPrim' "lambda" [toExpression inp, toExpression out] [] + Untyped.TMap k v -> + expressionPrim' "map" [toExpression k, toExpression v] [] + Untyped.TBigMap k v -> + expressionPrim' "big_map" [toExpression k, toExpression v] [] + Untyped.TInt -> expressionPrim' "int" [] [] + Untyped.TNat -> expressionPrim' "nat" [] [] + Untyped.TString -> expressionPrim' "string" [] [] + Untyped.TBytes -> expressionPrim' "bytes" [] [] + Untyped.TMutez -> expressionPrim' "mutez" [] [] + Untyped.TBool -> expressionPrim' "bool" [] [] + Untyped.TKeyHash -> expressionPrim' "key_hash" [] [] + Untyped.TBls12381Fr -> expressionPrim' "bls12_381_fr" [] [] + Untyped.TBls12381G1 -> expressionPrim' "bls12_381_g1" [] [] + Untyped.TBls12381G2 -> expressionPrim' "bls12_381_g2" [] [] + Untyped.TTimestamp -> expressionPrim' "timestamp" [] [] + Untyped.TAddress -> expressionPrim' "address" [] [] + Untyped.TChest -> expressionPrim' "chest" [] [] + Untyped.TChestKey -> expressionPrim' "chest_key" [] [] + Untyped.TTxRollupL2Address -> expressionPrim' "tx_rollup_l2_address" [] [] + Untyped.TNever -> expressionPrim' "never" [] [] + Untyped.TSaplingState n -> expressionPrim' "sapling_state" [integralToExpr n] [] + Untyped.TSaplingTransaction n -> expressionPrim' "sapling_transaction" [integralToExpr n] [] + + where + addAnns :: Expression -> [Annotation] -> Expression + addAnns e anns = + e & _ExpressionPrim . mpaAnnotsL <>~ anns + + rightCombedPairToList :: Ty -> (FieldAnn, VarAnn) -> [Expression] + rightCombedPairToList ty (fa, va) = case (ty, fa) of + (Ty (Untyped.TPair fa1 fa2 va1 va2 l r) (Untyped.Annotation ""), Untyped.Annotation "") -> + let annsL = mkAnns [] [fa1] [va1] + exprL = toExpression l `addAnns` annsL + in exprL : (rightCombedPairToList r (fa2, va2)) + _ -> + let anns = mkAnns [] [fa] [va] + in one $ toExpression ty `addAnns` anns + +instance ToExpression Ty where + toExpression (Ty t ta) = addTrimmedAnns (toExpression t) [ta] [] [] + +instance (ToExpression a) => ToExpression [a] where + toExpression xs = expressionSeq $ toExpression <$> xs + +instance (ToExpression a) => ToExpression (NonEmpty a) where + toExpression = toExpression . toList + +instance ToExpression Expression where + toExpression = id + +instance ToExpression ExpandedOp where + toExpression = \case + PrimEx instr -> toExpression instr + SeqEx s -> expressionSeq $ toExpression <$> s + WithSrcEx _ op -> toExpression op + +instance ToExpression ViewName where + toExpression (ViewName s) = expressionString s + +instance ToExpression ExpandedInstr where + toExpression = \case + PUSH va ty v -> expressionPrim' "PUSH" [toExpression ty, toExpression v] $ + mkAnns [] [] [va] + DROP -> expressionPrim' "DROP" [] [] + DROPN n -> expressionPrim' "DROP" [integralToExpr n] [] + DUP va -> expressionPrim' "DUP" [] $ mkAnns [] [] [va] + DUPN va n -> expressionPrim' "DUP" [integralToExpr n] $ mkAnns [] [] [va] + SWAP -> expressionPrim' "SWAP" [] [] + DIG n -> expressionPrim' "DIG" [integralToExpr n] [] + DUG n -> expressionPrim' "DUG" [integralToExpr n] [] + SOME ta va -> + expressionPrim' "SOME" [] $ mkAnns [ta] [] [va] + NONE ta va ty -> expressionPrim' "NONE" [toExpression ty] $ mkAnns [ta] [] [va] + UNIT ta va -> expressionPrim' "UNIT" [] $ mkAnns [ta] [] [va] + IF_NONE ops1 ops2 -> + expressionPrim' "IF_NONE" [toExpression ops1, toExpression ops2] [] + PAIR ta va fa1 fa2 -> expressionPrim' "PAIR" [] $ mkAnns [ta] [fa1, fa2] [va] + UNPAIR va1 va2 fa1 fa2 -> expressionPrim' "UNPAIR" [] $ + mkAnns [] [fa1, fa2] [va1, va2] + PAIRN va n -> expressionPrim' "PAIR" [integralToExpr n] $ mkAnns [] [] [va] + UNPAIRN n -> expressionPrim' "UNPAIR" [integralToExpr n] [] + CAR va fa -> expressionPrim' "CAR" [] $ mkAnns [] [fa] [va] + CDR va fa -> expressionPrim' "CDR" [] $ mkAnns [] [fa] [va] + LEFT ta va fa1 fa2 ty -> expressionPrim' "LEFT" [toExpression ty] $ + mkAnns [ta] [fa1, fa2] [va] + RIGHT ta va fa1 fa2 ty -> expressionPrim' "RIGHT" [toExpression ty] $ + mkAnns [ta] [fa1, fa2] [va] + IF_LEFT ops1 ops2 -> + expressionPrim' "IF_LEFT" [toExpression ops1, toExpression ops2] [] + NIL ta va ty -> expressionPrim' "NIL" [toExpression ty] $ + mkAnns [ta] [] [va] + CONS va -> expressionPrim' "CONS" [] $ mkAnns [] [] [va] + IF_CONS ops1 ops2 -> + expressionPrim' "IF_CONS" [toExpression ops1, toExpression ops2] [] + SIZE va -> expressionPrim' "SIZE" [] $ mkAnns [] [] [va] + EMPTY_SET ta va ty -> expressionPrim' "EMPTY_SET" [toExpression ty] $ + mkAnns [ta] [] [va] + EMPTY_MAP ta va kty vty -> + expressionPrim' "EMPTY_MAP" [toExpression kty, toExpression vty] $ + mkAnns [ta] [] [va] + EMPTY_BIG_MAP ta va kty vty -> + expressionPrim' "EMPTY_BIG_MAP" [toExpression kty, toExpression vty] $ + mkAnns [ta] [] [va] + MAP va ops -> expressionPrim' "MAP" [toExpression ops] $ mkAnns [] [] [va] + ITER ops -> expressionPrim' "ITER" [toExpression ops] [] + MEM va -> expressionPrim' "MEM" [] $ mkAnns [] [] [va] + GET va -> expressionPrim' "GET" [] $ mkAnns [] [] [va] + GETN va n -> expressionPrim' "GET" [integralToExpr n] $ mkAnns [] [] [va] + UPDATE va -> expressionPrim' "UPDATE" [] $ mkAnns [] [] [va] + UPDATEN va n -> expressionPrim' "UPDATE" [integralToExpr n] $ mkAnns [] [] [va] + GET_AND_UPDATE va -> expressionPrim' "GET_AND_UPDATE" [] $ mkAnns [] [] [va] + IF ops1 ops2 -> + expressionPrim' "IF" [toExpression ops1, toExpression ops2] [] + LOOP ops -> expressionPrim' "LOOP" [toExpression ops] [] + LOOP_LEFT ops -> expressionPrim' "LOOP_LEFT" [toExpression ops] [] + LAMBDA va tyin tyout ops -> + expressionPrim' "LAMBDA" [ toExpression tyin + , toExpression tyout + , toExpression ops + ] $ mkAnns [] [] [va] + EXEC va -> expressionPrim' "EXEC" [] $ mkAnns [] [] [va] + APPLY va -> expressionPrim' "APPLY" [] $ mkAnns [] [] [va] + DIP ops -> expressionPrim' "DIP" [toExpression ops] [] + DIPN n ops -> expressionPrim' "DIP" [integralToExpr n, toExpression ops] [] + FAILWITH -> expressionPrim' "FAILWITH" [] [] + CAST va ty -> expressionPrim' "CAST" [toExpression ty] $ mkAnns [] [] [va] + RENAME va -> expressionPrim' "RENAME" [] $ mkAnns [] [] [va] + PACK va -> expressionPrim' "PACK" [] $ mkAnns [] [] [va] + UNPACK ta va ty -> expressionPrim' "UNPACK" [toExpression ty] $ + mkAnns [ta] [] [va] + CONCAT va -> expressionPrim' "CONCAT" [] $ mkAnns [] [] [va] + SLICE va -> expressionPrim' "SLICE" [] $ mkAnns [] [] [va] + ISNAT va -> expressionPrim' "ISNAT" [] $ mkAnns [] [] [va] + ADD va -> expressionPrim' "ADD" [] $ mkAnns [] [] [va] + SUB va -> expressionPrim' "SUB" [] $ mkAnns [] [] [va] + SUB_MUTEZ va -> expressionPrim' "SUB_MUTEZ" [] $ mkAnns [] [] [va] + MUL va -> expressionPrim' "MUL" [] $ mkAnns [] [] [va] + EDIV va -> expressionPrim' "EDIV" [] $ mkAnns [] [] [va] + ABS va -> expressionPrim' "ABS" [] $ mkAnns [] [] [va] + NEG va -> expressionPrim' "NEG" [] $ mkAnns [] [] [va] + LSL va -> expressionPrim' "LSL" [] $ mkAnns [] [] [va] + LSR va -> expressionPrim' "LSR" [] $ mkAnns [] [] [va] + OR va -> expressionPrim' "OR" [] $ mkAnns [] [] [va] + AND va -> expressionPrim' "AND" [] $ mkAnns [] [] [va] + XOR va -> expressionPrim' "XOR" [] $ mkAnns [] [] [va] + NOT va -> expressionPrim' "NOT" [] $ mkAnns [] [] [va] + COMPARE va -> expressionPrim' "COMPARE" [] $ mkAnns [] [] [va] + Untyped.EQ va -> expressionPrim' "EQ" [] $ mkAnns [] [] [va] + NEQ va -> expressionPrim' "NEQ" [] $ mkAnns [] [] [va] + Untyped.LT va -> expressionPrim' "LT" [] $ mkAnns [] [] [va] + Untyped.GT va -> expressionPrim' "GT" [] $ mkAnns [] [] [va] + LE va -> expressionPrim' "LE" [] $ mkAnns [] [] [va] + GE va -> expressionPrim' "GE" [] $ mkAnns [] [] [va] + INT va -> expressionPrim' "INT" [] $ mkAnns [] [] [va] + VIEW va n t -> expressionPrim' "VIEW" [toExpression n, toExpression t] $ + mkAnns [] [] [va] + SELF va fa -> expressionPrim' "SELF" [] $ mkAnns [] [fa] [va] + CONTRACT va fa ty -> expressionPrim' "CONTRACT" [toExpression ty] $ + mkAnns [] [fa] [va] + TRANSFER_TOKENS va -> expressionPrim' "TRANSFER_TOKENS" [] $ mkAnns [] [] [va] + SET_DELEGATE va -> expressionPrim' "SET_DELEGATE" [] $ mkAnns [] [] [va] + CREATE_CONTRACT va1 va2 c -> + expressionPrim' "CREATE_CONTRACT" [toExpression c] $ + mkAnns [] [] [va1, va2] + IMPLICIT_ACCOUNT va -> expressionPrim' "IMPLICIT_ACCOUNT" [] $ + mkAnns [] [] [va] + NOW va -> expressionPrim' "NOW" [] $ mkAnns [] [] [va] + AMOUNT va -> expressionPrim' "AMOUNT" [] $ mkAnns [] [] [va] + BALANCE va -> expressionPrim' "BALANCE" [] $ mkAnns [] [] [va] + VOTING_POWER va -> expressionPrim' "VOTING_POWER" [] $ mkAnns [] [] [va] + TOTAL_VOTING_POWER va -> expressionPrim' "TOTAL_VOTING_POWER" [] $ + mkAnns [] [] [va] + CHECK_SIGNATURE va -> expressionPrim' "CHECK_SIGNATURE" [] $ mkAnns [] [] [va] + SHA256 va -> expressionPrim' "SHA256" [] $ mkAnns [] [] [va] + SHA512 va -> expressionPrim' "SHA512" [] $ mkAnns [] [] [va] + BLAKE2B va -> expressionPrim' "BLAKE2B" [] $ mkAnns [] [] [va] + SHA3 va -> expressionPrim' "SHA3" [] $ mkAnns [] [] [va] + KECCAK va -> expressionPrim' "KECCAK" [] $ mkAnns [] [] [va] + HASH_KEY va -> expressionPrim' "HASH_KEY" [] $ mkAnns [] [] [va] + PAIRING_CHECK va -> expressionPrim' "PAIRING_CHECK" [] $ mkAnns [] [] [va] + SOURCE va -> expressionPrim' "SOURCE" [] $ mkAnns [] [] [va] + SENDER va -> expressionPrim' "SENDER" [] $ mkAnns [] [] [va] + ADDRESS va -> expressionPrim' "ADDRESS" [] $ mkAnns [] [] [va] + CHAIN_ID va -> expressionPrim' "CHAIN_ID" [] $ mkAnns [] [] [va] + LEVEL va -> expressionPrim' "LEVEL" [] $ mkAnns [] [] [va] + SELF_ADDRESS va -> expressionPrim' "SELF_ADDRESS" [] $ mkAnns [] [] [va] + TICKET va -> expressionPrim' "TICKET" [] $ mkAnns [] [] [va] + READ_TICKET va -> expressionPrim' "READ_TICKET" [] $ mkAnns [] [] [va] + SPLIT_TICKET va -> expressionPrim' "SPLIT_TICKET" [] $ mkAnns [] [] [va] + JOIN_TICKETS va -> expressionPrim' "JOIN_TICKETS" [] $ mkAnns [] [] [va] + OPEN_CHEST va -> expressionPrim' "OPEN_CHEST" [] $ mkAnns [] [] [va] + NEVER -> expressionPrim' "NEVER" [] [] + EXT _ -> expressionSeq [] + SAPLING_EMPTY_STATE va n -> expressionPrim' "SAPLING_EMPTY_STATE" [integralToExpr n] $ mkAnns [] [] [va] + SAPLING_VERIFY_UPDATE va -> expressionPrim' "SAPLING_VERIFY_UPDATE" [] $ mkAnns [] [] [va] + MIN_BLOCK_TIME va -> expressionPrim' "MIN_BLOCK_TIME" [] $ mkAnnsFromAny va + +instance ToExpression Untyped.Contract where + toExpression contract + = expressionSeq $ Untyped.mapEntriesOrdered contract + (\(Untyped.ParameterType ty rootAnn) -> expressionPrim' "parameter" + [insertRootAnn (toExpression ty) rootAnn] []) + (\storage -> expressionPrim' "storage" [toExpression storage] []) + (\code -> expressionPrim' "code" [toExpression code] []) + (\Untyped.View{..} -> expressionPrim' "view" + [toExpression viewName, toExpression viewArgument, toExpression viewReturn, toExpression viewCode] [] + ) + +instance ToExpression (Contract cp st) where + toExpression = toExpression . convertContract + +-- FromExpression +---------------------------------------------------------------------------- + +-- | Errors that can happen when we convert an 'Exp' to our +-- data type. +data FromExpError x = FromExpError (Exp x) Text + +deriving stock instance Show (Exp x) => Show (FromExpError x) +deriving stock instance Eq (Exp x) => Eq (FromExpError x) + +-- | Error in case of vanilla expression. +type FromExpressionError = FromExpError RegularExp + +instance Buildable FromExpressionError where + build (FromExpError expr err) = + unlinesF + [ "Failed to convert expression:" + , indentF 2 $ build expr + , "" + , "Error:" + , indentF 2 $ build err + ] + +instance Exception FromExpressionError where + displayException = pretty + +-- | Type class that provides the ability to convert +-- something from a Micheline Expression. +class FromExp x a where + fromExp :: Exp x -> Either (FromExpError x) a + +type FromExpression = FromExp RegularExp + +-- | Parse vanilla expression to something. +fromExpression + :: FromExp RegularExp a + => Expression -> Either FromExpressionError a +fromExpression = fromExp + +instance (FromExp x Untyped.Value, SingI t) => FromExp x (Value t) where + fromExp expr = + case fromExp @_ @Untyped.Value expr of + Right uv -> case typeCheck uv of + Left tcErr -> Left $ FromExpError expr $ + pretty $ unlinesF + [ "Failed to typecheck expression as a value of type:" + , indentF 2 $ build $ demote @t + , "" + , "Typechecker error:" + , indentF 2 $ build tcErr + ] + Right tv -> Right tv + Left e -> Left e + where + typeCheck uv = typeCheckingWith (TypeCheckOptions False False) $ + (runTypeCheck $ TypeCheckValue (uv, demote @t)) $ + usingReaderT def $ + typeCheckValue uv + +instance FromExp x op => FromExp x (Untyped.Value' op) where + fromExp e = case e of + ExpInt _ v -> pure $ Untyped.ValueInt v + ExpString _ s -> first (FromExpError e) + (Untyped.ValueString <$> mkMText s) + ExpBytes _ bs -> pure $ Untyped.ValueBytes $ Untyped.InternalByteString bs + ExpPrim' _ "Unit" [] [] -> pure Untyped.ValueUnit + ExpPrim' _ "True" [] [] -> pure Untyped.ValueTrue + ExpPrim' _ "False" [] [] -> pure Untyped.ValueFalse + ExpPrim' _ "Pair" args [] -> + case nonEmpty args >>= forbidSingletonList of + Nothing -> Left $ FromExpError e + "Expected a pair with at least 2 arguments" + Just args' -> do + tys <- mapM fromExp args' + return $ foldr1 Untyped.ValuePair tys + ExpPrim' _ "Left" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.ValueLeft arg' + ExpPrim' _ "Right" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.ValueRight arg' + ExpPrim' _ "Some" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.ValueSome arg' + ExpPrim' _ "None" [] [] -> pure Untyped.ValueNone + ExpSeq _ [] -> pure Untyped.ValueNil + ExpSeq _ (h : t) -> + case fromExp @x @op h of + Right op -> do + ops <- traverse (fromExp @x @op) t + pure . Untyped.ValueLambda $ op :| ops + Left _ -> case exprToElt h of + Right elt -> do + elts <- traverse exprToElt t + pure . Untyped.ValueMap $ elt :| elts + Left _ -> case fromExp h of + Left (FromExpError err _) -> Left $ FromExpError err + "Value, instruction or 'Elt' expression expected" + Right h' -> do + t' <- traverse fromExp t + pure . Untyped.ValueSeq $ h' :| t' + _ -> Left $ FromExpError e "Expected a value" + where + exprToElt :: Exp x -> Either (FromExpError x) (Untyped.Elt op) + exprToElt ex = case ex of + ExpPrim' _ "Elt" [l, r] [] -> do + l' <- fromExp l + r' <- fromExp r + pure $ Untyped.Elt l' r' + ExpPrim' _ "Elt" _ [] -> Left $ FromExpError ex + "Expected 'Elt' expression with exactly 2 elements" + ExpPrim' _ "Elt" _ _ -> Left $ FromExpError ex + "Expected 'Elt' expression without annotations" + _ -> Left $ FromExpError ex "Expected 'Elt' expression" + +instance FromExp x a => FromExp x [a] where + fromExp = \case + ExpSeq _ exprs -> traverse fromExp exprs + e -> Left $ FromExpError e "'ExpressionSeq' expected" + +instance FromExp RegularExp ExpandedOp where + fromExp = \case + ExpSeq _ s -> SeqEx <$> traverse fromExp s + e -> PrimEx <$> fromExp e + +instance FromExp x op => + FromExp x (InstrAbstract op) where + fromExp e = let annSet = getAnnSet e in case e of + ExpPrim' _ "DROP" [n] [] -> do + n' <- integralFromExpr n + pure $ DROPN n' + ExpPrim' _ "DROP" [] _ -> pure $ DROP + ExpPrim' _ "DUP" [n] _ -> do + checkAnnsCount e annSet (0, 0, 1) + let va = firstAnn @VarTag annSet + n' <- integralFromExpr n + pure $ DUPN va n' + ExpPrim' _ "DUP" [] _ -> + let va = firstAnn @VarTag annSet + in checkAnnsCount e annSet (0, 0, 1) $> DUP va + ExpPrim' _ "SWAP" [] [] -> pure $ SWAP + ExpPrim' _ "DIG" [n] [] -> do + n' <- integralFromExpr n + pure $ DIG $ n' + ExpPrim' _ "DUG" [n] [] -> do + n' <- integralFromExpr n + pure $ DUG n' + ExpPrim' _ "PUSH" [t, v] _ -> do + checkAnnsCount e annSet (0, 0, 1) + let va = firstAnn @VarTag annSet + t' <- fromExp @x @Ty t + v' <- fromExp @x @(Untyped.Value' op) v + pure $ PUSH va t' v' + ExpPrim' _ "SOME" [] _ -> + let ta = firstAnn @TypeTag annSet + va = firstAnn @VarTag annSet + in checkAnnsCount e annSet (1, 0, 1) $> SOME ta va + ExpPrim' _ "NONE" [t] _ -> do + checkAnnsCount e annSet (1, 0, 1) + let ta = firstAnn @TypeTag annSet + let va = firstAnn @VarTag annSet + t' <- fromExp @x @Ty t + pure $ NONE ta va t' + ExpPrim' _ "UNIT" [] _ -> + let ta = firstAnn @TypeTag annSet + va = firstAnn @VarTag annSet + in checkAnnsCount e annSet (1, 0, 1) $> UNIT ta va + ExpPrim' _ "IF_NONE" [ops1, ops2] [] -> do + ops1' <- fromExp @x @[op] ops1 + ops2' <- fromExp @x @[op] ops2 + pure $ IF_NONE ops1' ops2' + ExpPrim' _ "PAIR" [] _ -> + let ta = firstAnn @TypeTag annSet + va = firstAnn @VarTag annSet + fa1 = firstAnn @FieldTag annSet + fa2 = secondAnn @FieldTag annSet + in (checkAnnsCount e annSet (1, 2, 1)) $> PAIR ta va fa1 fa2 + ExpPrim' _ "UNPAIR" [] _ -> + let va1 = firstAnn @VarTag annSet + va2 = secondAnn @VarTag annSet + fa1 = firstAnn @FieldTag annSet + fa2 = secondAnn @FieldTag annSet + in checkAnnsCount e annSet (0, 2, 2) $> UNPAIR va1 va2 fa1 fa2 + ExpPrim' _ "PAIR" [n] _ -> do + checkAnnsCount e annSet (0, 0, 1) + n' <- integralFromExpr n + let va = firstAnn @VarTag annSet + pure $ PAIRN va n' + ExpPrim' _ "UNPAIR" [n] [] -> do + n' <- integralFromExpr n + pure $ UNPAIRN n' + ExpPrim' _ "CAR" [] _ -> + let va = firstAnn @VarTag annSet + fa = firstAnn @FieldTag annSet + in checkAnnsCount e annSet (0, 1, 1) $> CAR va fa + ExpPrim' _ "CDR" [] _ -> + let va = firstAnn @VarTag annSet + fa = firstAnn @FieldTag annSet + in checkAnnsCount e annSet (0, 1, 1) $> CDR va fa + ExpPrim' _ "LEFT" [t] _ -> do + checkAnnsCount e annSet (1, 2, 1) + t' <- fromExp @x @Ty t + let ta = firstAnn @TypeTag annSet + let va = firstAnn @VarTag annSet + let fa1 = firstAnn @FieldTag annSet + let fa2 = secondAnn @FieldTag annSet + pure $ LEFT ta va fa1 fa2 t' + ExpPrim' _ "RIGHT" [t] _ -> do + checkAnnsCount e annSet (1, 2, 1) + t' <- fromExp @x @Ty t + let ta = firstAnn @TypeTag annSet + let va = firstAnn @VarTag annSet + let fa1 = firstAnn @FieldTag annSet + let fa2 = secondAnn @FieldTag annSet + pure $ RIGHT ta va fa1 fa2 t' + ExpPrim' _ "IF_LEFT" [ops1, ops2] [] -> do + ops1' <- fromExp @x @[op] ops1 + ops2' <- fromExp @x @[op] ops2 + pure $ IF_LEFT ops1' ops2' + ExpPrim' _ "NIL" [t] _ -> do + checkAnnsCount e annSet (1, 0, 1) + t' <- fromExp @x @Ty t + let va = firstAnn @VarTag annSet + let ta = firstAnn @TypeTag annSet + pure $ NIL ta va t' + ExpPrim' _ "CONS" [] anns -> mkInstrWithVarAnn CONS anns + ExpPrim' _ "IF_CONS" [ops1, ops2] [] -> do + ops1' <- fromExp @x @[op] ops1 + ops2' <- fromExp @x @[op] ops2 + pure $ IF_CONS ops1' ops2' + ExpPrim' _ "SIZE" [] anns -> mkInstrWithVarAnn SIZE anns + ExpPrim' _ "EMPTY_SET" [t] _ -> do + checkAnnsCount e annSet (1, 0, 1) + t' <- fromExp @x @Ty t + let va = firstAnn @VarTag annSet + let ta = firstAnn @TypeTag annSet + pure $ EMPTY_SET ta va t' + ExpPrim' _ "EMPTY_MAP" [kt, vt] _ -> do + checkAnnsCount e annSet (1, 0, 1) + kt' <- fromExp @x @Ty kt + vt' <- fromExp @x @Ty vt + let va = firstAnn @VarTag annSet + let ta = firstAnn @TypeTag annSet + pure $ EMPTY_MAP ta va kt' vt' + ExpPrim' _ "EMPTY_BIG_MAP" [kt, vt] _ -> do + checkAnnsCount e annSet (1, 0, 1) + kt' <- fromExp @x @Ty kt + vt' <- fromExp @x @Ty vt + let va = firstAnn @VarTag annSet + let ta = firstAnn @TypeTag annSet + pure $ EMPTY_BIG_MAP ta va kt' vt' + ExpPrim' _ "MAP" [ops] _ -> do + checkAnnsCount e annSet (0, 0, 1) + ops' <- fromExp @x @[op] ops + let va = firstAnn @VarTag annSet + pure $ MAP va ops' + ExpPrim' _ "ITER" [ops] [] -> do + ops' <- fromExp @x @[op] ops + pure $ ITER ops' + ExpPrim' _ "MEM" [] anns -> mkInstrWithVarAnn MEM anns + ExpPrim' _ "GET" [] anns -> mkInstrWithVarAnn GET anns + ExpPrim' _ "GET" [n] _ -> do + checkAnnsCount e annSet (0, 0, 1) + n' <- integralFromExpr n + let va = firstAnn @VarTag annSet + pure $ GETN va n' + ExpPrim' _ "UPDATE" [] anns -> mkInstrWithVarAnn UPDATE anns + ExpPrim' _ "UPDATE" [n] _ -> do + checkAnnsCount e annSet (0, 0, 1) + n' <- integralFromExpr n + let va = firstAnn @VarTag annSet + pure $ UPDATEN va n' + ExpPrim' _ "GET_AND_UPDATE" [] anns -> + mkInstrWithVarAnn GET_AND_UPDATE anns + ExpPrim' _ "IF" [ops1, ops2] [] -> do + ops1' <- fromExp @x @[op] ops1 + ops2' <- fromExp @x @[op] ops2 + pure $ IF ops1' ops2' + ExpPrim' _ "LOOP" [ops] [] -> do + ops' <- fromExp @x @[op] ops + pure $ LOOP ops' + ExpPrim' _ "LOOP_LEFT" [ops] [] -> do + ops' <- fromExp @x @[op] ops + pure $ LOOP_LEFT ops' + ExpPrim' _ "LAMBDA" [inp, out, ops] _ -> do + checkAnnsCount e annSet (0, 0, 1) + inp' <- fromExp @x @Ty inp + out' <- fromExp @x @Ty out + ops' <- fromExp @x @[op] ops + let va = firstAnn @VarTag annSet + pure $ LAMBDA va inp' out' ops' + ExpPrim' _ "EXEC" [] anns -> mkInstrWithVarAnn EXEC anns + ExpPrim' _ "APPLY" [] anns -> mkInstrWithVarAnn APPLY anns + ExpPrim' _ "DIP" [ops] [] -> do + ops' <- fromExp @x @[op] ops + pure $ DIP ops' + ExpPrim' _ "DIP" [n, ops] [] -> do + n' <- integralFromExpr n + ops' <- fromExp @x @[op] ops + pure $ DIPN n' ops' + ExpPrim' _ "FAILWITH" [] [] -> pure FAILWITH + ExpPrim' _ "CAST" [t] _ -> do + checkAnnsCount e annSet (0, 0, 1) + t' <- fromExp @x @Ty t + let va = firstAnn @VarTag annSet + pure $ CAST va t' + ExpPrim' _ "RENAME" [] anns -> mkInstrWithVarAnn RENAME anns + ExpPrim' _ "PACK" [] anns -> mkInstrWithVarAnn PACK anns + ExpPrim' _ "UNPACK" [t] _ -> do + checkAnnsCount e annSet (1, 0, 1) + t' <- fromExp @x @Ty t + let ta = firstAnn @TypeTag annSet + let va = firstAnn @VarTag annSet + pure $ UNPACK ta va t' + ExpPrim' _ "CONCAT" [] anns -> mkInstrWithVarAnn CONCAT anns + ExpPrim' _ "SLICE" [] anns -> mkInstrWithVarAnn SLICE anns + ExpPrim' _ "ISNAT" [] anns -> mkInstrWithVarAnn ISNAT anns + ExpPrim' _ "ADD" [] anns -> mkInstrWithVarAnn ADD anns + ExpPrim' _ "SUB" [] anns -> mkInstrWithVarAnn SUB anns + ExpPrim' _ "SUB_MUTEZ" [] anns -> mkInstrWithVarAnn SUB_MUTEZ anns + ExpPrim' _ "MUL" [] anns -> mkInstrWithVarAnn MUL anns + ExpPrim' _ "EDIV" [] anns -> mkInstrWithVarAnn EDIV anns + ExpPrim' _ "ABS" [] anns -> mkInstrWithVarAnn ABS anns + ExpPrim' _ "NEG" [] anns -> mkInstrWithVarAnn NEG anns + ExpPrim' _ "LSL" [] anns -> mkInstrWithVarAnn LSL anns + ExpPrim' _ "LSR" [] anns -> mkInstrWithVarAnn LSR anns + ExpPrim' _ "OR" [] anns -> mkInstrWithVarAnn OR anns + ExpPrim' _ "AND" [] anns -> mkInstrWithVarAnn AND anns + ExpPrim' _ "XOR" [] anns -> mkInstrWithVarAnn XOR anns + ExpPrim' _ "NOT" [] anns -> mkInstrWithVarAnn NOT anns + ExpPrim' _ "COMPARE" [] anns -> mkInstrWithVarAnn COMPARE anns + ExpPrim' _ "EQ" [] anns -> mkInstrWithVarAnn Untyped.EQ anns + ExpPrim' _ "NEQ" [] anns -> mkInstrWithVarAnn NEQ anns + ExpPrim' _ "LT" [] anns -> mkInstrWithVarAnn Untyped.LT anns + ExpPrim' _ "GT" [] anns -> mkInstrWithVarAnn Untyped.GT anns + ExpPrim' _ "LE" [] anns -> mkInstrWithVarAnn LE anns + ExpPrim' _ "GE" [] anns -> mkInstrWithVarAnn GE anns + ExpPrim' _ "INT" [] anns -> mkInstrWithVarAnn INT anns + ExpPrim' _ "VIEW" [name, t] _ -> do + let va = firstAnn @VarTag annSet + name' <- fromExp @x @ViewName name + t' <- fromExp @x @Ty t + checkAnnsCount e annSet (0, 0, 1) $> VIEW va name' t' + ExpPrim' _ "SELF" [] _ -> + let fa = firstAnn @FieldTag annSet + va = firstAnn @VarTag annSet + in checkAnnsCount e annSet (0, 1, 1) $> SELF va fa + ExpPrim' _ "CONTRACT" [t] _ -> do + checkAnnsCount e annSet (0, 1, 1) + t' <- fromExp @x @Ty t + let va = firstAnn @VarTag annSet + let fa = firstAnn @FieldTag annSet + pure $ CONTRACT va fa t' + ExpPrim' _ "TRANSFER_TOKENS" [] anns -> + mkInstrWithVarAnn TRANSFER_TOKENS anns + ExpPrim' _ "SET_DELEGATE" [] anns -> + mkInstrWithVarAnn SET_DELEGATE anns + ExpPrim' _ "CREATE_CONTRACT" [c] _ -> do + checkAnnsCount e annSet (0, 0, 2) + c' <- fromExp @x @(Untyped.Contract' op) c + let va1 = firstAnn @VarTag annSet + let va2 = secondAnn @VarTag annSet + pure $ CREATE_CONTRACT va1 va2 c' + ExpPrim' _ "IMPLICIT_ACCOUNT" [] anns -> + mkInstrWithVarAnn IMPLICIT_ACCOUNT anns + ExpPrim' _ "NOW" [] anns -> mkInstrWithVarAnn NOW anns + ExpPrim' _ "AMOUNT" [] anns -> mkInstrWithVarAnn AMOUNT anns + ExpPrim' _ "BALANCE" [] anns -> mkInstrWithVarAnn BALANCE anns + ExpPrim' _ "VOTING_POWER" [] anns -> + mkInstrWithVarAnn VOTING_POWER anns + ExpPrim' _ "TOTAL_VOTING_POWER" [] anns -> + mkInstrWithVarAnn TOTAL_VOTING_POWER anns + ExpPrim' _ "CHECK_SIGNATURE" [] anns -> + mkInstrWithVarAnn CHECK_SIGNATURE anns + ExpPrim' _ "SHA256" [] anns -> mkInstrWithVarAnn SHA256 anns + ExpPrim' _ "SHA512" [] anns -> mkInstrWithVarAnn SHA512 anns + ExpPrim' _ "BLAKE2B" [] anns -> mkInstrWithVarAnn BLAKE2B anns + ExpPrim' _ "SHA3" [] anns -> mkInstrWithVarAnn SHA3 anns + ExpPrim' _ "KECCAK" [] anns -> mkInstrWithVarAnn KECCAK anns + ExpPrim' _ "HASH_KEY" [] anns -> mkInstrWithVarAnn HASH_KEY anns + ExpPrim' _ "PAIRING_CHECK" [] anns -> + mkInstrWithVarAnn PAIRING_CHECK anns + ExpPrim' _ "SOURCE" [] anns -> mkInstrWithVarAnn SOURCE anns + ExpPrim' _ "SENDER" [] anns -> mkInstrWithVarAnn SENDER anns + ExpPrim' _ "ADDRESS" [] anns -> mkInstrWithVarAnn ADDRESS anns + ExpPrim' _ "CHAIN_ID" [] anns -> mkInstrWithVarAnn CHAIN_ID anns + ExpPrim' _ "LEVEL" [] anns -> mkInstrWithVarAnn LEVEL anns + ExpPrim' _ "SELF_ADDRESS" [] anns -> + mkInstrWithVarAnn SELF_ADDRESS anns + ExpPrim' _ "NEVER" [] [] -> pure NEVER + ExpPrim' _ "TICKET" [] anns -> mkInstrWithVarAnn TICKET anns + ExpPrim' _ "READ_TICKET" [] anns -> + mkInstrWithVarAnn READ_TICKET anns + ExpPrim' _ "SPLIT_TICKET" [] anns -> + mkInstrWithVarAnn SPLIT_TICKET anns + ExpPrim' _ "JOIN_TICKETS" [] anns -> + mkInstrWithVarAnn JOIN_TICKETS anns + ExpPrim' _ "OPEN_CHEST" [] anns -> + mkInstrWithVarAnn OPEN_CHEST anns + ExpPrim' _ "SAPLING_EMPTY_STATE" [n] _ -> do + checkAnnsCount e annSet (0, 0, 1) + n' <- integralFromExpr n + let va = firstAnn @VarTag annSet + pure $ SAPLING_EMPTY_STATE va n' + ExpPrim' _ "SAPLING_VERIFY_UPDATE" [] anns -> + mkInstrWithVarAnn SAPLING_VERIFY_UPDATE anns + ExpPrim' _ "MIN_BLOCK_TIME" [] anns -> pure $ mkInstrWithAnyAnns MIN_BLOCK_TIME anns + _ -> Left $ FromExpError e "Expected an instruction" + + where + mkInstrWithVarAnn + :: (VarAnn -> InstrAbstract op) + -> [Annotation] + -> Either (FromExpError x) (InstrAbstract op) + mkInstrWithVarAnn ctor anns = + let annSet = toAnnSet anns + va = firstAnn @VarTag annSet + in checkAnnsCount e annSet (0, 0, 1) $> ctor va + + mkInstrWithAnyAnns + :: ([Untyped.AnyAnn] -> InstrAbstract op) + -> [Annotation] + -> InstrAbstract op + mkInstrWithAnyAnns ctor anns = ctor $ anns <&> \case + AnnotationType x -> Untyped.AnyAnnType x + AnnotationField x -> Untyped.AnyAnnField x + AnnotationVariable x -> Untyped.AnyAnnVar x + + getAnnSet :: Exp d -> AnnotationSet + getAnnSet = \case + ExpPrim' _ _ _ anns -> toAnnSet anns + _ -> emptyAnnSet + +instance (FromExp x op) => FromExp x (Untyped.Contract' op) where + fromExp blocks = case blocks of + ExpSeq _ bs -> do + bs' <- mapM exprToCB bs + maybeToRight (FromExpError blocks "Something's wrong with top-level contract blocks") + (orderContractBlock bs') + expr -> Left $ FromExpError expr "Failed to parse contract, expected sequence" + where + exprToCB + :: Exp x + -> Either (FromExpError x) (ContractBlock op) + exprToCB e = case e of + ExpPrim' _ "parameter" args anns -> mkCbParam e args anns + ExpPrim' _ "storage" args anns -> mkCBStorage e args anns + ExpPrim' _ "code" args anns -> mkCBCode e args anns + ExpPrim' _ "view" args anns -> mkCBView e args anns + _ -> + Left $ FromExpError e "Unexpected primitive at contract top-level" + + mkCbParam + :: Exp x + -> [Exp x] + -> [Annotation] + -> Either (FromExpError x) (ContractBlock op) + mkCbParam e args anns = case (args, anns) of + ([p], []) -> do + let annSet = toAnnSet (p ^. _ExpPrim . _2 . mpaAnnotsL) + let rootAnn = firstAnn @FieldTag annSet + unless (secondAnn @FieldTag annSet == noAnn) $ + Left $ FromExpError p + "Expected parameter with at most 1 root annotation" + p' <- fromExp @x @Ty + (p & _ExpPrim . _2 . mpaAnnotsL %~ filter (not . isAnnotationField)) + pure $ CBParam $ Untyped.ParameterType p' rootAnn + _ -> Left $ FromExpError e + "Expected 'parameter' block without annotations and exactly 1 argument" + + mkCBStorage + :: Exp x + -> [Exp x] + -> [Annotation] + -> Either (FromExpError x) (ContractBlock op) + mkCBStorage e args anns = case (args, anns) of + ([s], []) -> do + s' <- fromExp @x @Ty s + pure $ CBStorage s' + _ -> Left $ FromExpError e + "Expected 'storage' block without annotations and exactly 1 argument" + + mkCBCode + :: Exp x + -> [Exp x] + -> [Annotation] + -> Either (FromExpError x) (ContractBlock op) + mkCBCode e args anns = case (args, anns) of + ([ops], []) -> do + ops' <- fromExp @x @[op] ops + pure $ CBCode ops' + _ -> Left $ FromExpError e + "Expected 'code' block without annotations" + + mkCBView + :: Exp x + -> [Exp x] + -> [Annotation] + -> Either (FromExpError x) (ContractBlock op) + mkCBView e args anns = case (args, anns) of + ([name, arg, ret, ops], []) -> do + name' <- fromExp name + arg' <- fromExp arg + ret' <- fromExp ret + ops' <- fromExp @x @[op] ops + pure $ CBView $ Untyped.View name' arg' ret' ops' + (_, _ : _) -> + Left $ FromExpError e + "Expected 'view' block without annotations" + (_, []) -> + Left $ FromExpError e + "Invalid 'view' block, expected 4 expressions in it" + +instance FromExp x Untyped.T where + fromExp e = case e of + ExpPrim' _ "key" [] [] -> pure Untyped.TKey + ExpPrim' _ "unit" [] [] -> pure Untyped.TUnit + ExpPrim' _ "signature" [] [] -> pure Untyped.TSignature + ExpPrim' _ "chain_id" [] [] -> pure Untyped.TChainId + ExpPrim' _ "option" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.TOption arg' + ExpPrim' _ "list" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.TList arg' + ExpPrim' _ "set" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.TSet arg' + ExpPrim' _ "operation" [] [] -> pure Untyped.TOperation + ExpPrim' _ "contract" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.TContract arg' + ExpPrim' _ "ticket" [arg] [] -> do + arg' <- fromExp arg + pure $ Untyped.TTicket arg' + ExpPrim' _ "or" [arg1, arg2] [] -> do + let as1 = toAnnSet $ arg1 ^. _ExpPrim . _2 . mpaAnnotsL + let as2 = toAnnSet $ arg2 ^. _ExpPrim . _2 . mpaAnnotsL + checkAnnsCount e as1 (1, 1, 0) + checkAnnsCount e as2 (1, 1, 0) + let fa1 = firstAnn @FieldTag as1 + let fa2 = firstAnn @FieldTag as2 + l <- fromExp $ removeAnns arg1 isAnnotationField + r <- fromExp $ removeAnns arg2 isAnnotationField + pure $ Untyped.TOr fa1 fa2 l r + ExpPrim' _ "pair" args [] -> do + args2 <- case nonEmpty args >>= forbidSingletonList of + Nothing -> Left $ FromExpError e + "Expected a pair with at least 2 arguments" + Just as -> pure as + -- Check and extract annotations info + tyInfos <- forM args2 \arg -> do + let as = toAnnSet $ arg ^. _ExpPrim . _2 . mpaAnnotsL + checkAnnsCount e as (1, 1, 1) + let fa = firstAnn @FieldTag as + let va = firstAnn @VarTag as + ty <- fromExp $ removeAnns arg + (isAnnotationField || isAnnotationVariable) + return (ty, fa, va) + -- Make a right-comb pairs tree + let combiner (ty1, fa1, va1) (ty2, fa2, va2) = + ( Ty (Untyped.TPair fa1 fa2 va1 va2 ty1 ty2) noAnn + , noAnn + , noAnn + ) + let (Ty tRes _, _, _) = foldr1 combiner tyInfos + return tRes + ExpPrim' _ "lambda" args [] -> mkDoubleParamType Untyped.TLambda args e + "Expected a lambda with input and output types" + ExpPrim' _ "map" args [] -> mkDoubleParamType Untyped.TMap args e + "Expected a map with key and value types" + ExpPrim' _ "big_map" args [] -> mkDoubleParamType Untyped.TBigMap args e + "Expected a big_map with key and value types" + ExpPrim' _ "int" [] [] -> pure Untyped.TInt + ExpPrim' _ "nat" [] [] -> pure Untyped.TNat + ExpPrim' _ "string" [] [] -> pure Untyped.TString + ExpPrim' _ "bytes" [] [] -> pure Untyped.TBytes + ExpPrim' _ "mutez" [] [] -> pure Untyped.TMutez + ExpPrim' _ "bool" [] [] -> pure Untyped.TBool + ExpPrim' _ "key_hash" [] [] -> pure Untyped.TKeyHash + ExpPrim' _ "bls12_381_fr" [] [] -> pure Untyped.TBls12381Fr + ExpPrim' _ "bls12_381_g1" [] [] -> pure Untyped.TBls12381G1 + ExpPrim' _ "bls12_381_g2" [] [] -> pure Untyped.TBls12381G2 + ExpPrim' _ "timestamp" [] [] -> pure Untyped.TTimestamp + ExpPrim' _ "address" [] [] -> pure Untyped.TAddress + ExpPrim' _ "chest" [] [] -> pure Untyped.TChest + ExpPrim' _ "chest_key" [] [] -> pure Untyped.TChestKey + ExpPrim' _ "tx_rollup_l2_address" [] [] -> pure Untyped.TTxRollupL2Address + ExpPrim' _ "never" [] [] -> pure Untyped.TNever + ExpPrim' _ "sapling_state" [n] [] -> do + n' <- integralFromExpr n + pure $ Untyped.TSaplingState n' + ExpPrim' _ "sapling_transaction" [n] [] -> do + n' <- integralFromExpr n + pure $ Untyped.TSaplingTransaction n' + ExpPrim' _ "sapling_transaction_deprecated" _ _ -> do + Left $ FromExpError e "Use of deprecated type: sapling_transaction_deprecated" + _ -> Left $ FromExpError e "Expected a type" + where + mkDoubleParamType + :: (Ty -> Ty -> Untyped.T) + -> [Exp x] + -> Exp x + -> Text + -> Either (FromExpError x) Untyped.T + mkDoubleParamType ctor args expr msg = do + case args of + [arg1, arg2] -> do + arg1' <- fromExp arg1 + arg2' <- fromExp arg2 + pure $ ctor arg1' arg2' + _ -> Left $ FromExpError expr msg + + removeAnns :: Exp x -> (Annotation -> Bool) -> Exp x + removeAnns expr p = + expr & _ExpPrim . _2 . mpaAnnotsL %~ filter (not . p) + +instance FromExp x Ty where + fromExp e = case e of + ExpPrim' ex primName args anns -> do + let annSet = toAnnSet anns + let ta = firstAnn @TypeTag annSet + when (secondAnn @TypeTag annSet /= noAnn) $ + Left $ FromExpError e + "Expected expression with at most 1 type annotation" + t <- fromExp @x @Untyped.T $ ExpPrim' ex primName args $ filter + (not . isAnnotationType) anns + pure $ Ty t ta + _ -> Left $ FromExpError e "Expected a type" + +instance FromExp x T where + fromExp = + second fromUType . fromExp @x @Untyped.Ty + +-- Note: we should generalize this to work for any instruction, +-- not just lambdas (i.e. instructions with one input and one output). +instance (SingI inp, SingI out) => FromExp RegularExp (Instr '[inp] '[out]) where + fromExp expr = + fromExpression @(Value ('TLambda inp out)) expr <&> \case + VLam instr -> rfAnyInstr instr + +instance FromExp x ViewName where + fromExp e = case e of + ExpString _ s -> + first (FromExpError e . pretty) $ mkViewName s + _ -> Left $ FromExpError e "Expected view name" + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +-- | Adds annotations to the expression, after removing empty annotations +-- at the end of each list. +addTrimmedAnns + :: Exp x + -> [TypeAnn] + -> [FieldAnn] + -> [VarAnn] + -> Exp x +addTrimmedAnns e tas fas vas = + e & _ExpPrim . _2 . mpaAnnotsL <>~ mkAnns tas fas vas + +-- | Inserts the root annotation into the contract parameter. +insertRootAnn :: HasCallStack => Expression -> RootAnn -> Expression +insertRootAnn expr rootAnn = case expr of + ExpPrim () p + -- The order of annotations is important iff there are + -- multiple annotations of the same kind or there are + -- other kinds of annotations in the list. + -- Prepending root field annotation is okay because + -- there can not be more than one root annotation. + | rootAnn /= noAnn -> expressionPrim p + { mpaAnnots = AnnotationField rootAnn : mpaAnnots p + } + | otherwise -> expr + -- Currently this error can't happen because parameter type + -- must be a Micheline primitive. If it ever changes, we + -- would like to notice it ASAP and update this place. + _ -> error $ "parameter is not a primitive: " <> pretty expr + +-- | Checks for a given expression that the number of annotations +-- of each type in it doesn't exceed the specified threshold. +checkAnnsCount + :: Exp x + -> AnnotationSet + -> (Int, Int, Int) + -> Either (FromExpError x) () +checkAnnsCount e annSet maxCount@(maxTas, maxFas, maxVas) = + let actualCount@(tasCnt, fasCnt, vasCnt) = annsCount annSet + in unless (actualCount <= maxCount) $ + Left $ FromExpError e $ pretty $ unlinesF + [ "Expected at most" + , indentF 2 $ build maxTas <> " type annotations," + , indentF 2 $ build maxFas <> " field annotations," + , indentF 2 $ build maxVas <> " variable annotations" + , "but found:" + , indentF 2 $ build tasCnt <> " type annotations," + , indentF 2 $ build fasCnt <> " field annotations," + , indentF 2 $ build vasCnt <> " variable annotations." + ] + +forbidSingletonList :: NonEmpty a -> Maybe (NonEmpty a) +forbidSingletonList = \case + _ :| [] -> Nothing + x -> Just x + +integralToExpr :: Integral i => i -> Expression +integralToExpr = expressionInt . toInteger + +integralFromExpr :: (Integral i, Bits i) => Exp x -> Either (FromExpError x) i +integralFromExpr e = case e of + ExpInt _ v -> + maybeToRight (FromExpError e "Value is out of bounds") + (fromIntegralMaybe @Integer v) + _ -> Left $ FromExpError e "Expected a number here" diff --git a/src/Morley/Micheline/Expression.hs b/src/Morley/Micheline/Expression.hs --- a/src/Morley/Micheline/Expression.hs +++ b/src/Morley/Micheline/Expression.hs @@ -8,11 +8,30 @@ -- | Module that defines Expression type, its related types -- and its JSON instance. module Morley.Micheline.Expression - ( Expression(.., PrimExpr) + ( Exp + ( .. + , ExpPrim' + ) + , expressionInt + , expressionString + , expressionBytes + , expressionSeq + , expressionPrim + , expressionPrim' + , RegularExp + , Expression , MichelinePrimAp(..) , MichelinePrimitive(..) , michelsonPrimitive + , ExpExtensionDescriptorKind + , ExpExtensionDescriptor (..) + , ExpExtrasConstrained + , ExpAllExtrasConstrainted + , ExpExtras (..) + , mkUniformExpExtras + , hoistExpExtras + , Annotation (..) , annotToText , annotFromText @@ -22,8 +41,14 @@ , isNoAnn , mkAnns , toAnnSet + , mkAnnsFromAny -- * Prisms + , _ExpInt + , _ExpString + , _ExpBytes + , _ExpSeq + , _ExpPrim , _ExpressionInt , _ExpressionString , _ExpressionBytes @@ -39,16 +64,16 @@ , mpaAnnotsL ) where -import Control.Lens (Plated) +import Control.Lens (Iso', Plated, Prism', iso, prism') import Control.Lens.TH (makeLensesWith, makePrisms) import Data.Aeson (FromJSON, ToJSON, object, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:), (.:?), (.=)) import Data.Aeson.Encoding.Internal qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types qualified as Aeson import Data.Data (Data) -import Data.HashMap.Strict qualified as HashMap import Data.Sequence qualified as Seq import Data.Text qualified as T (uncons) import Fmt (Buildable(..), pretty, (+|), (|+)) @@ -64,7 +89,7 @@ import Morley.Util.Lens (postfixLFields) newtype MichelinePrimitive = MichelinePrimitive Text - deriving newtype (Eq, Ord, ToJSON, FromJSON) + deriving newtype (Eq, Ord, IsString, ToJSON, FromJSON) deriving stock (Show, Data, Lift) michelsonPrimitive :: Seq Text @@ -105,39 +130,161 @@ "string", "bytes", "mutez", "timestamp", "unit", "operation", "address", "SLICE", "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID", "LEVEL", "SELF_ADDRESS", "never", "NEVER", "UNPAIR", "VOTING_POWER", "TOTAL_VOTING_POWER", "KECCAK", "SHA3", "PAIRING_CHECK", - "bls12_381_g1", "bls12_381_g2", "bls12_381_fr", "sapling_state", "sapling_transaction", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket", + "bls12_381_g1", "bls12_381_g2", "bls12_381_fr", "sapling_state", "sapling_transaction_deprecated", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket", "TICKET", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE", "chest", "chest_key", "OPEN_CHEST", - "VIEW", "view", "constant", "SUB_MUTEZ" + "VIEW", "view", "constant", "SUB_MUTEZ", "tx_rollup_l2_address", "MIN_BLOCK_TIME", "sapling_transaction" ] --- | Type for Micheline Expression -data Expression - = ExpressionInt Integer - -- ^ Micheline represents both nats and ints using the same decimal format. - -- The Haskell Integer type spans all possible values that the final - -- (Michelson) type could end up being, and then some, so we use - -- (StringEncode Integer) to represent all integral values here for easy - -- JSON encoding compatibility. - | ExpressionString Text - | ExpressionBytes ByteString - | ExpressionSeq [Expression] - | ExpressionPrim MichelinePrimAp - deriving stock (Eq, Show, Data, Lift) +-- | Type for Micheline Expression with extension points. +-- +-- Following the Trees-that-Grow approach, this type provides the core set +-- of constructors used by Tezos accompanied with additional data (@XExp*@). +-- Plus additional constructors provided by @XExp@. +-- +-- The type argument @x@ will be called /extension descriptor/ and it must have +-- @ExpExtensionDescriptor@ instance. +data Exp x + = ExpInt (XExpInt x) Integer + | ExpString (XExpString x) Text + | ExpBytes (XExpBytes x) ByteString + | ExpSeq (XExpSeq x) [Exp x] + | ExpPrim (XExpPrim x) (MichelinePrimAp x) + | ExpX (XExp x) -pattern PrimExpr :: Text -> [Expression] -> [Annotation] -> Expression -pattern PrimExpr primName args anns = - ExpressionPrim (MichelinePrimAp (MichelinePrimitive primName) args anns) +pattern ExpPrim' :: XExpPrim x -> MichelinePrimitive -> [Exp x] -> [Annotation] -> Exp x +pattern ExpPrim' x primAp exprs anns = ExpPrim x (MichelinePrimAp primAp exprs anns) -instance Plated Expression +deriving stock instance ExpAllExtrasConstrainted Eq x => Eq (Exp x) +deriving stock instance ExpAllExtrasConstrainted Show x => Show (Exp x) +deriving stock instance (ExpAllExtrasConstrainted Data x, Typeable x) => Data (Exp x) +deriving stock instance ExpAllExtrasConstrainted Lift x => Lift (Exp x) +-- | Kind of extension descriptors. +-- +-- We use a dedicated open type for this, not just @Type@, to notice earlier +-- when type arguments are mis-placed. +type ExpExtensionDescriptorKind = ExpExtensionTag -> Type +data ExpExtensionTag + +-- | Defines details of extension descriptor. +class ExpExtensionDescriptor (x :: ExpExtensionDescriptorKind) where + + -- | Additional data in 'ExpInt' constructor. + type XExpInt x :: Type + type XExpInt _ = () + + -- | Additional data in 'ExpString' constructor. + type XExpString x :: Type + type XExpString _ = () + + -- | Additional data in 'ExpBytes' constructor. + type XExpBytes x :: Type + type XExpBytes _ = () + + -- | Additional data in 'ExpSeq' constructor. + type XExpSeq x :: Type + type XExpSeq _ = () + + -- | Additional data in 'ExpPrim' constructor. + type XExpPrim x :: Type + type XExpPrim _ = () + + -- | Additional constructors. + type XExp x :: Type + type XExp _ = Void + +-- | Constraint all the extra fields provided by this extension. +type ExpExtrasConstrained c x = + Each '[c] + [XExpInt x, XExpString x, XExpBytes x, XExpSeq x, XExpPrim x] + +-- | Constraint all the extra fields and the constructor provided by +-- this extension. +type ExpAllExtrasConstrainted c x = (ExpExtrasConstrained c x, c (XExp x)) + +-- | A helper type that carries something for all extra fields. +-- +-- Fields are carried in the given functor @f@ so that one could provide +-- a generator, parser or something else. +-- +-- Extra constructor is not included here as it may need special treatment, +-- you have to carry it separately. +data ExpExtras f x = ExpExtras + { eeInt :: f (XExpInt x) + , eeString :: f (XExpString x) + , eeBytes :: f (XExpBytes x) + , eeSeq :: f (XExpSeq x) + , eePrim :: f (XExpPrim x) + } + +-- | Fill 'ExpExtras' with the same data, assuming all types of extras are +-- the same. +mkUniformExpExtras + :: ( extra ~ XExpInt x + , extra ~ XExpString x + , extra ~ XExpBytes x + , extra ~ XExpSeq x + , extra ~ XExpPrim x + ) + => f extra -> ExpExtras f x +mkUniformExpExtras x = ExpExtras x x x x x + +-- | Change the functor used in 'ExpExtras'. +hoistExpExtras + :: (forall extra. f1 extra -> f2 extra) + -> ExpExtras f1 x -> ExpExtras f2 x +hoistExpExtras f ExpExtras{..} = ExpExtras + { eeInt = f eeInt + , eeString = f eeString + , eeBytes = f eeBytes + , eeSeq = f eeSeq + , eePrim = f eePrim + } + +-- | Extension descriptor for plain expressions without additional data. +data RegularExp :: ExpExtensionDescriptorKind +instance ExpExtensionDescriptor RegularExp + +-- | Simple expression without any extras. +type Expression = Exp RegularExp + +expressionInt :: Integer -> Expression +expressionInt a = ExpInt () a + +expressionString :: Text -> Expression +expressionString a = ExpString () a + +expressionBytes :: ByteString -> Expression +expressionBytes a = ExpBytes () a + +expressionSeq :: [Expression] -> Expression +expressionSeq a = ExpSeq () a + +expressionPrim :: MichelinePrimAp RegularExp -> Expression +expressionPrim a = ExpPrim () a + +expressionPrim' :: Text -> [Expression] -> [Annotation] -> Expression +expressionPrim' primName args anns = + ExpPrim () (MichelinePrimAp (MichelinePrimitive primName) args anns) + +-- | Default instance that uses @uniplate@ as implementation. +-- +-- If it tries to find expressions for polymorphic types too agressively +-- (requiring 'Data' where you don't what that), feel free to define an +-- overlapping manual instance. +instance ( Typeable x + , ExpAllExtrasConstrainted Data x + , ExpAllExtrasConstrainted Typeable x) + => Plated (Exp x) + instance Buildable Expression where build = \case - ExpressionInt i -> build $ i - ExpressionString s -> build s - ExpressionBytes b -> + ExpInt () i -> build i + ExpString () s -> build s + ExpBytes () b -> build $ encodeBase58Check b - ExpressionSeq s -> "(" +| buildList build s |+ ")" - ExpressionPrim (MichelinePrimAp (MichelinePrimitive text) s annots) -> + ExpSeq () s -> "(" +| buildList build s |+ ")" + ExpPrim () (MichelinePrimAp (MichelinePrimitive text) s annots) -> text <> " " |+ "(" +| buildList build s +| ") " +| buildList (build . annotToText) annots @@ -150,19 +297,24 @@ | AnnotationField FieldAnn deriving stock (Eq, Show, Data, Lift) -data MichelinePrimAp = MichelinePrimAp +data MichelinePrimAp x = MichelinePrimAp { mpaPrim :: MichelinePrimitive - , mpaArgs :: [Expression] + , mpaArgs :: [Exp x] , mpaAnnots :: [Annotation] - } deriving stock (Eq, Show, Data, Lift) + } -instance FromJSON MichelinePrimAp where +deriving stock instance Eq (Exp x) => Eq (MichelinePrimAp x) +deriving stock instance Show (Exp x) => Show (MichelinePrimAp x) +deriving stock instance (Data (Exp x), Typeable x) => Data (MichelinePrimAp x) +deriving stock instance Lift (Exp x) => Lift (MichelinePrimAp x) + +instance FromJSON (Exp x) => FromJSON (MichelinePrimAp x) where parseJSON = withObject "Prim" $ \v -> MichelinePrimAp <$> v .: "prim" <*> v .:? "args" .!= [] <*> v .:? "annots" .!= [] -instance ToJSON MichelinePrimAp where +instance ToJSON (Exp x) => ToJSON (MichelinePrimAp x) where toJSON MichelinePrimAp {..} = object $ catMaybes [ Just ("prim" .= mpaPrim) , if null mpaArgs then Nothing else Just ("args" .= mpaArgs) @@ -198,6 +350,12 @@ (AnnotationField <$> asFields minAnnSet) <> (AnnotationVariable <$> asVars minAnnSet) +mkAnnsFromAny :: [U.AnyAnn] -> [Annotation] +mkAnnsFromAny xs = xs <&> \case + U.AnyAnnType x -> AnnotationType x + U.AnyAnnField x -> AnnotationField x + U.AnyAnnVar x -> AnnotationVariable x + isAnnotationField :: Annotation -> Bool isAnnotationField = \case AnnotationField _ -> True @@ -234,25 +392,71 @@ toEncoding = toEncoding . annotToText instance FromJSON Expression where - parseJSON v = ExpressionSeq <$> parseJSON v - <|> ExpressionPrim <$> parseJSON v - <|> ExpressionString <$> withObject "ExpressionString" (.: "string") v - <|> ExpressionInt . unStringEncode <$> withObject "ExpressionInt" (.: "int") v - <|> ExpressionBytes . unHexJSONByteString <$> withObject "ExpressionBytes" (.: "bytes") v + parseJSON v = ExpSeq () <$> parseJSON v + <|> ExpPrim () <$> parseJSON v + <|> ExpString () <$> withObject "ExpressionString" (.: "string") v + <|> ExpInt () . unStringEncode <$> withObject "ExpressionInt" (.: "int") v + <|> ExpBytes () . unHexJSONByteString <$> withObject "ExpressionBytes" (.: "bytes") v instance ToJSON Expression where - toJSON (ExpressionSeq xs) = toJSON xs - toJSON (ExpressionPrim xs) = toJSON xs - toJSON (ExpressionString x) = Aeson.Object (HashMap.singleton "string" $ toJSON x) - toJSON (ExpressionInt x) = Aeson.Object (HashMap.singleton "int" $ toJSON $ StringEncode x) - toJSON (ExpressionBytes x) = Aeson.Object (HashMap.singleton "bytes" $ toJSON $ HexJSONByteString x) + toJSON (ExpSeq () xs) = toJSON xs + toJSON (ExpPrim () xs) = toJSON xs + toJSON (ExpString () x) = Aeson.Object (KeyMap.singleton "string" $ toJSON x) + toJSON (ExpInt () x) = Aeson.Object (KeyMap.singleton "int" $ toJSON $ StringEncode x) + toJSON (ExpBytes () x) = Aeson.Object (KeyMap.singleton "bytes" $ toJSON $ HexJSONByteString x) - toEncoding (ExpressionSeq xs) = toEncoding xs - toEncoding (ExpressionPrim xs) = toEncoding xs - toEncoding (ExpressionString x) = Aeson.pairs (Aeson.pair "string" (toEncoding x)) - toEncoding (ExpressionInt x) = Aeson.pairs (Aeson.pair "int" (toEncoding $ StringEncode x)) - toEncoding (ExpressionBytes x) = Aeson.pairs (Aeson.pair "bytes" (toEncoding $ HexJSONByteString x)) + toEncoding (ExpSeq () xs) = toEncoding xs + toEncoding (ExpPrim () xs) = toEncoding xs + toEncoding (ExpString () x) = Aeson.pairs (Aeson.pair "string" (toEncoding x)) + toEncoding (ExpInt () x) = Aeson.pairs (Aeson.pair "int" (toEncoding $ StringEncode x)) + toEncoding (ExpBytes () x) = Aeson.pairs (Aeson.pair "bytes" (toEncoding $ HexJSONByteString x)) -makePrisms ''Expression +-------------------------------------------------------------------------------- +-- Optics +-------------------------------------------------------------------------------- + +_ExpInt :: Prism' (Exp d) (XExpInt d, Integer) +_ExpInt = prism' (uncurry ExpInt) \case + ExpInt x a -> Just (x, a) + _ -> Nothing + +_ExpString :: Prism' (Exp d) (XExpString d, Text) +_ExpString = prism' (uncurry ExpString) \case + ExpString x a -> Just (x, a) + _ -> Nothing + +_ExpBytes :: Prism' (Exp d) (XExpBytes d, ByteString) +_ExpBytes = prism' (uncurry ExpBytes) \case + ExpBytes x a -> Just (x, a) + _ -> Nothing + +_ExpSeq :: Prism' (Exp d) (XExpSeq d, [Exp d]) +_ExpSeq = prism' (uncurry ExpSeq) \case + ExpSeq x a -> Just (x, a) + _ -> Nothing + +_ExpPrim :: Prism' (Exp d) (XExpPrim d, MichelinePrimAp d) +_ExpPrim = prism' (uncurry ExpPrim) \case + ExpPrim x a -> Just (x, a) + _ -> Nothing + +neglecting :: Iso' ((), a) a +neglecting = iso snd pure + +_ExpressionInt :: Prism' Expression Integer +_ExpressionInt = _ExpInt . neglecting + +_ExpressionString :: Prism' Expression Text +_ExpressionString = _ExpString . neglecting + +_ExpressionBytes :: Prism' Expression ByteString +_ExpressionBytes = _ExpBytes . neglecting + +_ExpressionSeq :: Prism' Expression [Expression] +_ExpressionSeq = _ExpSeq . neglecting + +_ExpressionPrim :: Prism' Expression (MichelinePrimAp RegularExp) +_ExpressionPrim = _ExpPrim . neglecting + makePrisms ''Annotation makeLensesWith postfixLFields ''MichelinePrimAp diff --git a/src/Morley/Micheline/Expression/WithMeta.hs b/src/Morley/Micheline/Expression/WithMeta.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Micheline/Expression/WithMeta.hs @@ -0,0 +1,107 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Expression that carries the same extra data for all 'Exp' constructors. +module Morley.Micheline.Expression.WithMeta + ( -- * General case + expAllExtraL + + -- * Custom extra field, no extra constructors + , WithMeta + , ExpressionWithMeta + , expMetaL + , expAnnotate + , expAllMetaL + + -- * Utilities + , IsEq + ) where + +import Control.Lens qualified as L + +import Morley.Micheline.Expression +import Morley.Util.Type (IsEq) + +-------------------------------------------------------------------------------- +-- General case +-------------------------------------------------------------------------------- + +-- | Traversal that visits all the extra fields ('XExpInt' and others) +-- in DFS order assuming they are the same for every constructor. +-- +-- It is generic enough to work not only with 'ExpressionWithMeta', but +-- with any 'Exp' that has all the extra fields of the same type; +-- hence, this traversal is applicable to 'Expression' too. +-- +-- This also supports additional constructors. Use 'L.devoid' if you have none. +-- +-- Moreover, when used as setter, it can change the type of meta. +expAllExtraL + :: forall x2 x1 meta2 meta1. + ( ExpExtrasConstrained (IsEq meta1) x1 + , ExpExtrasConstrained (IsEq meta2) x2 + ) + => Traversal (XExp x1) (XExp x2) meta1 meta2 + -> Traversal (Exp x1) (Exp x2) meta1 meta2 +expAllExtraL ctorL = go + where + go f = \case + ExpInt x a -> ExpInt <$> f x <*> pure a + ExpString x a -> ExpString <$> f x <*> pure a + ExpBytes x a -> ExpBytes <$> f x <*> pure a + ExpSeq x a -> ExpSeq <$> f x <*> traverse (go f) a + ExpPrim x a -> + ExpPrim <$> f x <*> L.traverseOf (mpaArgsL . L.traversed) (go f) a + ExpX x -> ExpX <$> ctorL f x + +-------------------------------------------------------------------------------- +-- Custom extra field, no extra constructors +-------------------------------------------------------------------------------- + +-- | Expression that has the same type of metadata attached to each of +-- its constructors. +data WithMeta (meta :: Type) :: ExpExtensionDescriptorKind +instance ExpExtensionDescriptor (WithMeta m) where + type XExpInt (WithMeta m) = m + type XExpString (WithMeta m) = m + type XExpBytes (WithMeta m) = m + type XExpSeq (WithMeta m) = m + type XExpPrim (WithMeta m) = m + +-- | Alias for expression with given meta. +type ExpressionWithMeta meta = Exp (WithMeta meta) + +{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} + +-- | Lens for getting immediate meta of the node. +expMetaL :: Lens' (Exp (WithMeta meta)) meta +expMetaL f = \case + ExpInt x a -> + f x <&> \x' -> ExpInt x' a + ExpString x a -> + f x <&> \x' -> ExpString x' a + ExpBytes x a -> + f x <&> \x' -> ExpBytes x' a + ExpSeq x a -> + f x <&> \x' -> ExpSeq x' a + ExpPrim x a -> + f x <&> \x' -> ExpPrim x' a + +-- | Traversal that visits all the metas in DFS order. +-- This is a specialization of 'expAllExtraL'. +-- +-- This is pretty similar to 'expMetaL', but picks meta of all the +-- transitive children. +-- +-- When used as setter, it can change the type of meta. +expAllMetaL + :: forall x2 x1 meta2 meta1. + ( ExpExtrasConstrained (IsEq meta1) x1 + , ExpExtrasConstrained (IsEq meta2) x2 + ) + => Traversal (ExpressionWithMeta meta1) (ExpressionWithMeta meta2) meta1 meta2 +expAllMetaL = expAllExtraL L.devoid + +-- | Lift plain 'Expression' to 'ExpressionWithMeta'. +expAnnotate :: Expression -> ExpressionWithMeta () +expAnnotate = expAllExtraL L.devoid %~ id diff --git a/src/Morley/Michelson/ErrorPos.hs b/src/Morley/Michelson/ErrorPos.hs --- a/src/Morley/Michelson/ErrorPos.hs +++ b/src/Morley/Michelson/ErrorPos.hs @@ -6,9 +6,7 @@ , Pos (..) , SrcPos (..) , srcPos - , InstrCallStack (..) - , LetCallStack - , LetName (..) + , ErrorSrcPos (..) ) where import Unsafe qualified (fromIntegral) @@ -16,10 +14,9 @@ import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import Data.Default (Default(..)) -import Data.Text qualified as T import Fmt (Buildable(..)) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended, renderAnyBuildable) -import Text.PrettyPrint.Leijen.Text (list, (<+>)) +import Text.PrettyPrint.Leijen.Text ((<+>)) import Morley.Util.Aeson @@ -47,40 +44,26 @@ srcPos :: Word -> Word -> SrcPos srcPos x y = SrcPos (Pos x) (Pos y) -newtype LetName = LetName T.Text - deriving stock (Eq, Ord, Show, Data, Generic) - deriving newtype Buildable - -instance NFData LetName - -type LetCallStack = [LetName] -data InstrCallStack = InstrCallStack - { icsCallStack :: LetCallStack - , icsSrcPos :: SrcPos +newtype ErrorSrcPos = ErrorSrcPos + { unErrorSrcPos :: SrcPos } deriving stock (Eq, Ord, Show, Generic, Data) + deriving newtype (Default) + deriving anyclass (NFData) -instance RenderDoc InstrCallStack where - renderDoc _ InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos row) (Pos col)} = +instance RenderDoc ErrorSrcPos where + renderDoc _ ErrorSrcPos{unErrorSrcPos = SrcPos (Pos row) (Pos col)} = "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1)) - <> case icsCallStack of - [] -> "." - _ -> " inside these let defenitions:" <+> (list $ fmap renderAnyBuildable icsCallStack) <> "." + <> "." -instance Buildable InstrCallStack where +instance Buildable ErrorSrcPos where build = buildRenderDocExtended -instance NFData InstrCallStack - instance Default Pos where def = Pos 0 instance Default SrcPos where def = SrcPos def def -instance Default InstrCallStack where - def = InstrCallStack def def - deriveJSON morleyAesonOptions ''Pos deriveJSON morleyAesonOptions ''SrcPos -deriveJSON morleyAesonOptions ''LetName -deriveJSON morleyAesonOptions ''InstrCallStack +deriveJSON morleyAesonOptions ''ErrorSrcPos diff --git a/src/Morley/Michelson/FailPattern.hs b/src/Morley/Michelson/FailPattern.hs --- a/src/Morley/Michelson/FailPattern.hs +++ b/src/Morley/Michelson/FailPattern.hs @@ -56,8 +56,8 @@ PUSH v -> isTypicalErrorConstant v Seq _ (PUSH v) -> isTypicalErrorConstant v - Seq (PUSH v) PAIR -> FailWithStackValue <$> isStringValue v - Seq (Seq _ (PUSH v)) PAIR -> FailWithStackValue <$> isStringValue v + Seq (PUSH v) PAIR{} -> FailWithStackValue <$> isStringValue v + Seq (Seq _ (PUSH v)) PAIR{} -> FailWithStackValue <$> isStringValue v _ -> Nothing @@ -92,24 +92,24 @@ -- It is quite hard to move the body of these very similar -- cases into a separate function because involved types -- are quite sophisticated. - Seq (PUSH v) PAIR + Seq (AnnPUSH ann@(Anns2' s _) v) (AnnPAIR ann') | _ :: Value a <- v , _ :: Instr (b ': s) ('TPair a b ': s) <- i1 -> case sing @('TPair a b) of STPair l r -> withSingI l $ withSingI r $ case isStringValue v of Just (f -> SomeConstant v') -> - PUSH v' `Seq` PAIR `Seq` FAILWITH + AnnPUSH (Anns2' s starNotes) v' `Seq` AnnPAIR ann' `Seq` FAILWITH Nothing -> - PUSH v `Seq` PAIR `Seq` FAILWITH - Seq (Seq i0 (PUSH v)) PAIR + AnnPUSH ann v `Seq` AnnPAIR ann' `Seq` FAILWITH + Seq (Seq i0 (AnnPUSH ann@(Anns2' s _) v)) (AnnPAIR ann') | _ :: Value a <- v , _ :: Instr s0 ('TPair a b ': s) <- i1 -> case sing @('TPair a b) of STPair l r -> withSingI l $ withSingI r $ Seq i0 $ case isStringValue v of Just (f -> SomeConstant v') -> - PUSH v' `Seq` PAIR `Seq` FAILWITH + AnnPUSH (Anns2' s starNotes) v' `Seq` AnnPAIR ann' `Seq` FAILWITH Nothing -> - PUSH v `Seq` PAIR `Seq` FAILWITH + AnnPUSH ann v `Seq` AnnPAIR ann' `Seq` FAILWITH _ -> Seq i1 FAILWITH diff --git a/src/Morley/Michelson/Interpret.hs b/src/Morley/Michelson/Interpret.hs --- a/src/Morley/Michelson/Interpret.hs +++ b/src/Morley/Michelson/Interpret.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Module, containing function to interpret Michelson -- instructions against given context and input stack. module Morley.Michelson.Interpret @@ -29,7 +26,6 @@ , EvalM , InterpreterStateMonad (..) , StkEl (..) - , starNotesStkEl , InstrRunner , runInstr , runInstrNoGas @@ -60,18 +56,17 @@ import Fmt (Buildable(build), blockListF, pretty, prettyLn, (+|), (|+)) import Unsafe qualified (fromIntegral) -import Morley.Michelson.ErrorPos (InstrCallStack(..)) +import Morley.Michelson.ErrorPos (ErrorSrcPos(..)) import Morley.Michelson.Interpret.Pack (packValue') import Morley.Michelson.Interpret.Unpack (UnpackError, unpackValue') import Morley.Michelson.Runtime.GState -import Morley.Michelson.TypeCheck (matchTypes) +import Morley.Michelson.TypeCheck (eqType) import Morley.Michelson.Typed hiding (Branch(..)) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash) -import Morley.Michelson.Untyped qualified as U -import Morley.Michelson.Untyped.Annotation (annQ) import Morley.Tezos.Address (Address(..), GlobalCounter(..)) +import Morley.Tezos.Address.Alias (Alias) import Morley.Tezos.Core (ChainId, Mutez, Timestamp, zeroMutez) import Morley.Tezos.Crypto (KeyHash, OpeningResult(..), blake2b, checkSignature, hashKey, keccak, mkTLTime, openChest, @@ -126,21 +121,15 @@ makePrisms ''MorleyLogs -data StkEl t = StkEl +newtype StkEl t = StkEl { seValue :: Value t - , seVarAnn :: U.VarAnn - , seNotes :: Notes t } deriving stock (Eq, Show) makeLensesFor [ ("seValue", "seValueL") - , ("seVarAnn", "seVarAnnL") ] ''StkEl -starNotesStkEl :: forall t. Value t -> StkEl t -starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t - -- | Environment for contract execution. data ContractEnv = ContractEnv { ceNow :: Timestamp @@ -168,8 +157,10 @@ -- correct contract address computation in @CREATE_CONTRACT@ instruction. , ceLevel :: Natural -- ^ Number of blocks before the given one in the chain - , ceInstrCallStack :: InstrCallStack + , ceErrorSrcPos :: ErrorSrcPos -- ^ Current source position information + , ceMinBlockTime :: Natural + -- ^ Minimum time between blocks } -- | Represents @[FAILED]@ state of a Michelson program. Contains @@ -209,10 +200,10 @@ MichelsonUnsupported instr -> build instr <> " instruction is not supported." --- | Carries a 'MichelsonFailed' error and the 'InstrCallStack' at which it was raised +-- | Carries a 'MichelsonFailed' error and the 'ErrorSrcPos' at which it was raised data MichelsonFailureWithStack = MichelsonFailureWithStack { mfwsFailed :: MichelsonFailed - , mfwsInstrCallStack :: InstrCallStack + , mfwsErrorSrcPos :: ErrorSrcPos } deriving stock (Show, Generic, Eq) instance Buildable MichelsonFailureWithStack where @@ -262,7 +253,7 @@ -- | Helper function to convert a record of @Value@ to @StkEl@. These will be -- created with @starNotes@. mapToStkEl :: Rec T.Value inp -> Rec StkEl inp -mapToStkEl = rmap starNotesStkEl +mapToStkEl = rmap StkEl -- | Helper function to convert a record of @StkEl@ to @Value@. Any present -- notes will be discarded. @@ -280,24 +271,20 @@ -> ContractReturn st interpret' Contract{..} epc param initSt env ist = first (fmap fromFinalStack) $ runEvalOp - (runInstr cCode $ mkInitStack (liftCallArg epc param) cParamNotes initSt cStoreNotes) + (runInstr (unContractCode cCode) $ mkInitStack (liftCallArg epc param) initSt) env ist mkInitStack :: T.Value param - -> T.ParamNotes param -> T.Value st - -> T.Notes st -> Rec StkEl (ContractInp param st) -mkInitStack param T.UnsafeParamNotes{..} st stNotes = StkEl +mkInitStack param st = StkEl (T.VPair (param, st)) - U.noAnn - (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn [annQ|parameter|] [annQ|storage|] pnNotes stNotes) :& RNil fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st) -fromFinalStack (StkEl (T.VPair (T.VList ops, st)) _ _ :& RNil) = +fromFinalStack (StkEl (T.VPair (T.VList ops, st)) :& RNil) = (map (\(T.VOp op) -> op) ops, st) interpret @@ -316,7 +303,7 @@ initInterpreterState globalCounter bmCounter env = InterpreterState (ceMaxSteps env) globalCounter bmCounter --- | Interpret an instruction in vacuum, putting no extra contraints on +-- | Interpret an instruction in vacuum, putting no extra constraints on -- its execution. -- -- Mostly for testing purposes. @@ -327,7 +314,7 @@ -> Either MichelsonFailureWithStack (Rec T.Value out) interpretInstr = fmap mapToValue ... interpretInstrAnnotated --- | Interpret an instruction in vacuum, putting no extra contraints on +-- | Interpret an instruction in vacuum, putting no extra constraints on -- its execution while preserving its annotations. -- -- Mostly for testing purposes. @@ -410,20 +397,16 @@ -> m (Rec StkEl out) throwMichelson :: EvalM m => MichelsonFailed -> m a -throwMichelson mf = asks ceInstrCallStack >>= throwError . MichelsonFailureWithStack mf +throwMichelson mf = asks ceErrorSrcPos >>= throwError . MichelsonFailureWithStack mf -- | 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@(WithLoc _ _) r = runInstrImpl runInstr i r runInstr i@(Meta _ _i1) r = runInstrImpl runInstr i r -runInstr i@(InstrWithNotes _ _ _i1) r = runInstrImpl runInstr i r -runInstr i@(InstrWithVarNotes _ _i1) r = runInstrImpl runInstr i r -runInstr i@(InstrWithVarAnns _ _i1) r = runInstrImpl runInstr i r runInstr i@Nop r = runInstrImpl runInstr i r runInstr i@(Nested _) r = runInstrImpl runInstr i r runInstr i@(DocGroup _ _i1) r = runInstrImpl runInstr i r -runInstr i@(Fn _ _ _i1) r = runInstrImpl runInstr i r runInstr i r = do rs <- isRemainingSteps <$> getInterpreterState if rs == 0 @@ -438,25 +421,8 @@ -- | Function to interpret Michelson instruction(s) against given stack. runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r' -runInstrImpl runner (WithLoc ics i) r = local (\env -> env{ceInstrCallStack = ics}) $ runner i r +runInstrImpl runner (WithLoc ics i) r = local (\env -> env{ceErrorSrcPos = ics}) $ runner i r runInstrImpl runner (Meta _ i) r = runner i r -runInstrImpl runner (InstrWithNotes (_ :: Proxy rest) notes instr) inp = do - out <- runner instr inp - let zipRec :: Rec Notes topElems -> Rec StkEl (topElems ++ rest) -> Rec StkEl (topElems ++ rest) - zipRec RNil stkElems = stkElems - zipRec (stkElemNotes :& xs) (stkElem :& ys) = - stkElem { seNotes = stkElemNotes } :& zipRec xs ys - pure $ zipRec notes out -runInstrImpl runner (InstrWithVarNotes _vns i) inp = runner i inp -runInstrImpl runner (InstrWithVarAnns vns i) inp = do - runner i inp <&> \case - StkEl v1 _ n1 :& StkEl v2 vn2 n2 :& r -> case vns of - U.OneVarAnn vn -> StkEl v1 vn n1 :& StkEl v2 vn2 n2 :& r - U.TwoVarAnns vn vn' -> StkEl v1 vn n1 :& StkEl v2 vn' n2 :& r - StkEl v _ n :& r -> case vns of - U.OneVarAnn vn -> StkEl v vn n :& r - U.TwoVarAnns _ _ -> error "Input stack is exhausted but there is still a variable annotation." - RNil -> error "Input stack is exhausted but there is still variables annotations." runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do let (inp, end) = rsplit @_ @_ @s r out <- runInstrImpl runner i inp @@ -465,7 +431,6 @@ runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r) runInstrImpl runner (Nested sq) r = runner sq r runInstrImpl runner (DocGroup _ sq) r = runInstrImpl runner sq r -runInstrImpl runner (Fn _ _ i) r = runner i r runInstrImpl _ DROP (_ :& r) = pure $ r runInstrImpl runner (DROPN n) stack = case n of @@ -479,19 +444,18 @@ -- This recursion is implementation detail of `DROPN`. -- The same reasoning applies to other instructions parameterized -- by a natural number like 'DIPN'. -runInstrImpl _ DUP (stkEl :& r) = do +runInstrImpl _ AnnDUP{} (stkEl :& r) = do -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s). duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl pure $ duplicateStkEl :& stkEl :& r -runInstrImpl _ (DUPN s) stack = go s stack +runInstrImpl _ (AnnDUPN _ s) stack = go s stack where go :: forall (n :: Peano) inp out a. ConstraintDUPN n inp out a => PeanoNatural n -> Rec StkEl inp -> m (Rec StkEl out) go (Succ Zero) stk@(stkEl :& _) = do -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s). duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl - -- Discard variable annotations. This is consistent with tezos-client. - pure $ (duplicateStkEl & seVarAnnL .~ U.noAnn) :& stk + pure $ duplicateStkEl :& stk go (Succ n@(Succ _)) (b :& r) = go n r <&> \case (a :& resTail) -> a :& b :& resTail @@ -513,102 +477,91 @@ => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out go Zero stack = stack go (Succ n') (a :& b :& r) = b :& go n' (a :& r) -runInstrImpl _ SOME ((seValue -> a) :& r) = +runInstrImpl _ AnnSOME{} ((seValue -> a) :& r) = withValueTypeSanity a $ - pure $ starNotesStkEl (VOption (Just a)) :& r -runInstrImpl _ (PUSH v) r = pure $ starNotesStkEl v :& r -runInstrImpl _ NONE r = pure $ starNotesStkEl (VOption Nothing) :& r -runInstrImpl _ UNIT r = pure $ starNotesStkEl VUnit :& r -runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) vn (NTOption _ n) :& r) = - runner bJust (StkEl a vn n :& r) -runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) _ _ :& r) = + pure $ StkEl (VOption (Just a)) :& r +runInstrImpl _ (AnnPUSH _ v) r = pure $ StkEl v :& r +runInstrImpl _ AnnNONE{} r = pure $ StkEl (VOption Nothing) :& r +runInstrImpl _ AnnUNIT{} r = pure $ StkEl VUnit :& r +runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) :& r) = + runner bJust (StkEl a :& r) +runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) :& r) = runner bNone r runInstrImpl _ NEVER inp = case inp of {} -runInstrImpl _ (AnnPAIR{}) ((StkEl a _ _) :& (StkEl b _ _) :& r) = - pure $ starNotesStkEl (VPair (a, b)) :& r -runInstrImpl _ (AnnUNPAIR{}) ((StkEl (VPair (a, b)) _ _) :& r) = - pure $ starNotesStkEl a :& starNotesStkEl b :& r -runInstrImpl _ (PAIRN s) stack = pure $ go s stack +runInstrImpl _ (AnnPAIR{}) ((StkEl a) :& (StkEl b) :& r) = + pure $ StkEl (VPair (a, b)) :& r +runInstrImpl _ (AnnUNPAIR{}) ((StkEl (VPair (a, b))) :& r) = + pure $ StkEl a :& StkEl b :& r +runInstrImpl _ (AnnPAIRN _ s) stack = pure $ go s stack where go :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Rec StkEl inp -> Rec StkEl (PairN n inp) - go (Succ (Succ Zero)) (StkEl a _ _ :& StkEl b _ _ :& r) = + go (Succ (Succ Zero)) (StkEl a :& StkEl b :& r) = -- if n=2 - starNotesStkEl (VPair (a, b)) :& r - go (Succ n@(Succ (Succ _))) (StkEl a _ _ :& r@(_ :& _ :& _)) = + StkEl (VPair (a, b)) :& r + go (Succ n@(Succ (Succ _))) (StkEl a :& r@(_ :& _ :& _)) = -- if n>2 case go n r of - StkEl combed _ _ :& r' -> - starNotesStkEl (VPair (a, combed)) :& r' -runInstrImpl _ (UNPAIRN s) (StkEl pair0 _ pairNotes0 :& r) = do - pure $ go s pair0 pairNotes0 <+> r + StkEl combed :& r' -> + StkEl (VPair (a, combed)) :& r' +runInstrImpl _ (UNPAIRN s) (StkEl pair0 :& r) = do + pure $ go s pair0 <+> r where go :: forall n pair. ConstraintUnpairN n pair - => PeanoNatural n -> Value pair -> Notes pair + => PeanoNatural n -> Value pair -> Rec StkEl (UnpairN n pair) - go n pair pairNotes = - case (n, pair, pairNotes) of + go n pair = + case (n, pair) of -- if n=2 - (Succ (Succ Zero), VPair (a, b), NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes) -> - -- @UNPAIR n@ converts field annotations into var annotations. - -- - -- > /* [ @pair pair (int %aa) (int %bb) (int %cc) (int %dd) ] */ ; - -- > UNPAIR 3 - -- > /* [ @aa int : @bb int : pair (int %cc) (int %dd) ] */ ; - -- - -- Nested var annotations will be discarded. - -- - -- > /* [ pair (int @c) (int @a) (int @b) ] */ ; - -- UNPAIR 3 - -- /* [ int : int : int ] */ ; - StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes - :& StkEl b (U.convAnn @U.FieldTag @U.VarTag bFieldAnn) bNotes + (Succ (Succ Zero), VPair (a, b)) -> + StkEl a + :& StkEl b :& RNil -- if n>2 - (Succ n'@(Succ (Succ _)), VPair (a, b@(VPair _)), NTPair _ aFieldAnn _ _ _ aNotes bNotes) -> - StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes - :& go n' b bNotes -runInstrImpl _ (AnnCAR _ _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r -runInstrImpl _ (AnnCDR _ _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r -runInstrImpl _ (AnnLEFT nt nf1 nf2) ((StkEl a _ na) :& r) = + (Succ n'@(Succ (Succ _)), VPair (a, b@(VPair _))) -> + StkEl a + :& go n' b +runInstrImpl _ AnnCAR{} (StkEl (VPair (a, _b)) :& r) = pure $ StkEl a :& r +runInstrImpl _ AnnCDR{} (StkEl (VPair (_a, b)) :& r) = pure $ StkEl b :& r +runInstrImpl _ AnnLEFT{} ((StkEl a) :& r) = withValueTypeSanity a $ - pure $ StkEl (VOr $ Left a) U.noAnn (NTOr nt nf1 nf2 na starNotes) :& r -runInstrImpl _ (AnnRIGHT nt nf1 nf2) ((StkEl b _ nb) :& r) = + pure $ StkEl (VOr $ Left a) :& r +runInstrImpl _ AnnRIGHT{} ((StkEl b) :& r) = withValueTypeSanity b $ - pure $ StkEl (VOr $ Right b) U.noAnn (NTOr nt nf1 nf2 starNotes nb) :& r -runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) = - runner bLeft (StkEl a vn nl :& r) -runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) vn (NTOr _ _ _ _ nr) :& r) = - runner bRight (StkEl a vn nr :& r) -runInstrImpl _ NIL r = pure $ starNotesStkEl (VList []) :& r -runInstrImpl _ CONS (a :& StkEl (VList l) _ _ :& r) = pure $ starNotesStkEl (VList (seValue a : l)) :& r -runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) _ _ :& r) = runner bNil r -runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) vn ntl@(NTList _ nhd) :& r) = - runner bCons (StkEl lh vn nhd :& StkEl (VList lr) vn ntl :& r) -runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ Unsafe.fromIntegral @Int @Natural $ evalSize $ seValue a) :& r -runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r -runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r -runInstrImpl _ EMPTY_BIG_MAP r = do + pure $ StkEl (VOr $ Right b) :& r +runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) :& r) = + runner bLeft (StkEl a :& r) +runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) :& r) = + runner bRight (StkEl a :& r) +runInstrImpl _ AnnNIL{} r = pure $ StkEl (VList []) :& r +runInstrImpl _ AnnCONS{} (a :& StkEl (VList l) :& r) = pure $ StkEl (VList (seValue a : l)) :& r +runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) :& r) = runner bNil r +runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) :& r) = + runner bCons (StkEl lh :& StkEl (VList lr) :& r) +runInstrImpl _ AnnSIZE{} (a :& r) = pure $ StkEl (VNat $ Unsafe.fromIntegral @Int @Natural $ evalSize $ seValue a) :& r +runInstrImpl _ AnnEMPTY_SET{} r = pure $ StkEl (VSet Set.empty) :& r +runInstrImpl _ AnnEMPTY_MAP{} r = pure $ StkEl (VMap Map.empty) :& r +runInstrImpl _ AnnEMPTY_BIG_MAP{} r = do bigMap <- assignBigMapIds' $ VBigMap Nothing Map.empty - pure $ starNotesStkEl bigMap :& r -runInstrImpl runner (MAP (code :: Instr (MapOpInp c ': s) (b ': s))) (StkEl a vn n :& r) = do + pure $ StkEl bigMap :& r +runInstrImpl runner (AnnMAP _ (code :: Instr (MapOpInp c ': s) (b ': s))) (StkEl a :& r) = do -- Evaluation must preserve all stack modifications that @MAP@'s does. (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do res <- runner code (val :& curStack) case res of ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList)) - (r, []) ((\el -> StkEl el vn (mapOpNotes n)) <$> mapOpToList @c a) - pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack -runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a vn n :& r) = + (r, []) ((\el -> StkEl el) <$> mapOpToList @c a) + pure $ StkEl (mapOpFromList a (reverse newList)) :& newStack +runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a :& r) = case iterOpDetachOne @c a of (Just x, xs) -> do - res <- runner code (StkEl x vn (iterOpNotes n) :& r) - runner (ITER code) (StkEl xs vn n :& res) + res <- runner code (StkEl x :& r) + runner (ITER code) (StkEl xs :& res) (Nothing, _) -> pure r -runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r -runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r -runInstrImpl _ (GETN s) (StkEl pair _ _ :& r) = do - pure $ starNotesStkEl (go s pair) :& r +runInstrImpl _ AnnMEM{} (a :& b :& r) = pure $ StkEl (VBool (evalMem (seValue a) (seValue b))) :& r +runInstrImpl _ AnnGET{} (a :& b :& r) = pure $ StkEl (VOption (evalGet (seValue a) (seValue b))) :& r +runInstrImpl _ (AnnGETN _ s) (StkEl pair :& r) = do + pure $ StkEl (go s pair) :& r where go :: forall ix a. ConstraintGetN ix a @@ -617,10 +570,10 @@ go Zero a = a go (Succ Zero) (VPair (left, _)) = left go (Succ (Succ n')) (VPair (_, right)) = go n' right -runInstrImpl _ UPDATE (a :& b :& StkEl c _ _ :& r) = - pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) c) :& r -runInstrImpl _ (UPDATEN s) (StkEl (val :: Value val) _ _ :& StkEl pair _ _ :& r) = do - pure $ starNotesStkEl (go s pair) :& r +runInstrImpl _ AnnUPDATE{} (a :& b :& StkEl c :& r) = + pure $ StkEl (evalUpd (seValue a) (seValue b) c) :& r +runInstrImpl _ (AnnUPDATEN _ s) (StkEl (val :: Value val) :& StkEl pair :& r) = do + pure $ StkEl (go s pair) :& r where go :: forall ix pair. ConstraintUpdateN ix pair @@ -628,27 +581,27 @@ go Zero _ = val go (Succ Zero) (VPair (_, right)) = VPair (val, right) go (Succ (Succ n')) (VPair (left, right)) = VPair (left, go n' right) -runInstrImpl _ GET_AND_UPDATE (StkEl key _ _ :& StkEl valMb _ _ :& StkEl collection _ _ :& r) = +runInstrImpl _ AnnGET_AND_UPDATE{} (StkEl key :& StkEl valMb :& StkEl collection :& r) = pure $ - starNotesStkEl (VOption (evalGet key collection)) - :& starNotesStkEl (evalUpd key valMb collection) + StkEl (VOption (evalGet key collection)) + :& StkEl (evalUpd key valMb collection) :& r -runInstrImpl runner (IF bTrue _) (StkEl (VBool True) _ _ :& r) = runner bTrue r -runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) _ _ :& r) = runner bFalse r -runInstrImpl _ (LOOP _) (StkEl (VBool False) _ _ :& r) = pure $ r -runInstrImpl runner (LOOP ops) (StkEl (VBool True) _ _ :& r) = do +runInstrImpl runner (IF bTrue _) (StkEl (VBool True) :& r) = runner bTrue r +runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) :& r) = runner bFalse r +runInstrImpl _ (LOOP _) (StkEl (VBool False) :& r) = pure $ r +runInstrImpl runner (LOOP ops) (StkEl (VBool True) :& r) = do res <- runner ops r runner (LOOP ops) res -runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) _ _ :& r) = pure $ starNotesStkEl a :& r -runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) = do - res <- runner ops (StkEl a vn nl :& r) +runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) :& r) = pure $ StkEl a :& r +runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) :& r) = do + res <- runner ops (StkEl a :& r) runner (LOOP_LEFT ops) res -runInstrImpl _ (LAMBDA lam) r = pure $ starNotesStkEl lam :& r -runInstrImpl runner EXEC (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) _ _ :& r) = do +runInstrImpl _ (AnnLAMBDA _ lam) r = pure $ StkEl lam :& r +runInstrImpl runner AnnEXEC{} (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) :& r) = do res <- runner lBody (a :& RNil) pure $ res <+> r -runInstrImpl _ APPLY (StkEl (a :: T.Value a) _ _ :& StkEl (VLam lBody) _ _ :& r) = do - pure $ starNotesStkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r +runInstrImpl _ AnnAPPLY{} (StkEl (a :: T.Value a) :& StkEl (VLam lBody) :& r) = do + pure $ StkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r where doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o doApply b = PUSH a `Seq` PAIR `Seq` Nested b @@ -661,53 +614,53 @@ Succ s' -> case stack of (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r runInstrImpl _ FAILWITH (a :& _) = throwMichelson $ MichelsonFailedWith (seValue a) -runInstrImpl _ CAST (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r -runInstrImpl _ RENAME (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r -runInstrImpl _ PACK ((seValue -> a) :& r) = pure $ starNotesStkEl (VBytes $ packValue' a) :& r -runInstrImpl _ UNPACK (StkEl (VBytes a) _ _ :& r) = - pure $ starNotesStkEl (VOption . rightToMaybe $ runUnpack a) :& r -runInstrImpl _ CONCAT (a :& b :& r) = pure $ starNotesStkEl (evalConcat (seValue a) (seValue b)) :& r -runInstrImpl _ CONCAT' (StkEl (VList a) _ _ :& r) = pure $ starNotesStkEl (evalConcat' a) :& r -runInstrImpl _ SLICE (StkEl (VNat o) _ _ :& StkEl (VNat l) _ _ :& StkEl s _ _ :& r) = - pure $ starNotesStkEl (VOption (evalSlice o l s)) :& r -runInstrImpl _ ISNAT (StkEl (VInt i) _ _ :& r) = +runInstrImpl _ AnnCAST{} s = pure s +runInstrImpl _ AnnRENAME{} s = pure s +runInstrImpl _ AnnPACK{} ((seValue -> a) :& r) = pure $ StkEl (VBytes $ packValue' a) :& r +runInstrImpl _ AnnUNPACK{} (StkEl (VBytes a) :& r) = + pure $ StkEl (VOption . rightToMaybe $ runUnpack a) :& r +runInstrImpl _ AnnCONCAT{} (a :& b :& r) = pure $ StkEl (evalConcat (seValue a) (seValue b)) :& r +runInstrImpl _ AnnCONCAT'{} (StkEl (VList a) :& r) = pure $ StkEl (evalConcat' a) :& r +runInstrImpl _ AnnSLICE{} (StkEl (VNat o) :& StkEl (VNat l) :& StkEl s :& r) = + pure $ StkEl (VOption (evalSlice o l s)) :& r +runInstrImpl _ AnnISNAT{} (StkEl (VInt i) :& r) = if i < 0 - then pure $ starNotesStkEl (VOption Nothing) :& r - else pure $ starNotesStkEl (VOption (Just (VNat $ fromInteger i))) :& r -runInstrImpl _ ADD (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r -runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r -runInstrImpl _ SUB_MUTEZ (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @SubMutez) l r -runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r -runInstrImpl _ EDIV (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @EDiv) l r -runInstrImpl _ ABS ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest -runInstrImpl _ NEG ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neg) a) :& rest -runInstrImpl _ LSL (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s -runInstrImpl _ LSR (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s -runInstrImpl _ OR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r -runInstrImpl _ AND (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r -runInstrImpl _ XOR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r -runInstrImpl _ NOT ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Not) a) :& rest -runInstrImpl _ COMPARE ((seValue -> l) :& (seValue -> r) :& rest) = - pure $ starNotesStkEl (T.VInt (compareOp l r)) :& rest -runInstrImpl _ EQ ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest -runInstrImpl _ NEQ ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest -runInstrImpl _ LT ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest -runInstrImpl _ GT ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest -runInstrImpl _ LE ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Le) a) :& rest -runInstrImpl _ GE ((seValue -> a) :& rest) = - pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest -runInstrImpl _ INT (StkEl a _ _ :& r) = - pure $ starNotesStkEl (evalToIntOp a) :& r -runInstrImpl runner (VIEW name (_ :: Notes ret)) - (StkEl (arg :: Value arg) _ _ :& StkEl (VAddress epAddr) addrVa _ :& r) = do + then pure $ StkEl (VOption Nothing) :& r + else pure $ StkEl (VOption (Just (VNat $ fromInteger i))) :& r +runInstrImpl _ AnnADD{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r +runInstrImpl _ AnnSUB{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r +runInstrImpl _ AnnSUB_MUTEZ{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @SubMutez) l r +runInstrImpl _ AnnMUL{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r +runInstrImpl _ AnnEDIV{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @EDiv) l r +runInstrImpl _ AnnABS{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest +runInstrImpl _ AnnNEG{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Neg) a) :& rest +runInstrImpl _ AnnLSL{} (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s +runInstrImpl _ AnnLSR{} (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s +runInstrImpl _ AnnOR{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r +runInstrImpl _ AnnAND{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r +runInstrImpl _ AnnXOR{} (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r +runInstrImpl _ AnnNOT{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Not) a) :& rest +runInstrImpl _ AnnCOMPARE{} ((seValue -> l) :& (seValue -> r) :& rest) = + pure $ StkEl (T.VInt (compareOp l r)) :& rest +runInstrImpl _ AnnEQ{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest +runInstrImpl _ AnnNEQ{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest +runInstrImpl _ AnnLT{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest +runInstrImpl _ AnnGT{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest +runInstrImpl _ AnnLE{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Le) a) :& rest +runInstrImpl _ AnnGE{} ((seValue -> a) :& rest) = + pure $ StkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest +runInstrImpl _ AnnINT{} (StkEl a :& r) = + pure $ StkEl (evalToIntOp a) :& r +runInstrImpl runner (AnnVIEW (Anns2' _ (_ :: Notes ret)) name) + (StkEl (arg :: Value arg) :& StkEl (VAddress epAddr) :& r) = do ContractEnv{..} <- ask res :: Value ('TOption ret) <- VOption <$> runMaybeT do let EpAddress addr _ = epAddr @@ -723,11 +676,10 @@ resSt <- lift $ local (mkViewEnv addr viewedContractState) $ runInstrImpl runner vCode $ - starNotesStkEl (VPair (arg, viewedContractStorage)) :& RNil - let StkEl res _ _ :& RNil = resSt + StkEl (VPair (arg, viewedContractStorage)) :& RNil + let StkEl res :& RNil = resSt return res - let newAnn = addrVa <> [annQ|contract|] -- TODO [#704]: ¯\_(ツ)_/¯ - pure (StkEl res newAnn starNotes :& r) + pure (StkEl res :& r) where mkViewEnv :: Address -> ContractState -> ContractEnv -> ContractEnv mkViewEnv calledAddr viewedContractState ContractEnv{..} = ContractEnv @@ -738,15 +690,15 @@ , ceAmount = zeroMutez , ceContracts , ceNow, ceMaxSteps, ceVotingPowers, ceChainId, ceOperationHash, ceLevel - , ceInstrCallStack + , ceErrorSrcPos, ceMinBlockTime } -runInstrImpl _ (SELF sepc :: Instr inp out) r = do +runInstrImpl _ (AnnSELF _ sepc :: Instr inp out) r = do ContractEnv{..} <- ask case Proxy @out of (_ :: Proxy ('TContract cp ': s)) -> do - pure $ starNotesStkEl (VContract ceSelf sepc) :& r -runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (StkEl (VAddress epAddr) _ _ :& r) = do + pure $ StkEl (VContract ceSelf sepc) :& r +runInstrImpl _ (AnnCONTRACT (Anns2' _ (_ :: T.Notes a)) instrEpName) (StkEl (VAddress epAddr) :& r) = do ContractEnv{..} <- ask let T.EpAddress addr addrEpName = epAddr let mepName = @@ -756,41 +708,44 @@ (en, DefEpName) -> Just en _ -> Nothing - let withNotes v = StkEl v U.noAnn (NTOption U.noAnn $ NTContract U.noAnn nt) :& r - pure $ withNotes $ case mepName of - Nothing -> VOption Nothing + let withNotes v = StkEl v :& r + withNotes <$> case mepName of + Nothing -> pure $ VOption Nothing Just epName -> case addr of - KeyAddress{} -> castContract addr epName T.tyImplicitAccountParam - ContractAddress{} -> + KeyAddress{} -> pure $ castContract addr epName T.tyImplicitAccountParam + ContractAddress{} -> pure $ case Map.lookup addr ceContracts of Just (ASSimple _) -> error "Broken addresses map" Just (ASContract ContractState{..}) -> castContract addr epName (cParamNotes csContract) Nothing -> VOption Nothing + TransactionRollupAddress{} -> + -- TODO [#838]: support transaction rollups on the emulator + throwMichelson $ MichelsonUnsupported "txr1 addresses with CONTRACT" where castContract :: forall p. T.ParameterScope p => 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 - Right (Refl, _) <- pure $ matchTypes nt na + MkEntrypointCallRes (_ :: Notes a') epc <- T.mkEntrypointCall epName param + Right Refl <- pure $ eqType @a @a' return $ VContract addr (T.SomeEpc epc) -runInstrImpl _ TRANSFER_TOKENS - (StkEl p _ _ :& StkEl (VMutez mutez) _ _ :& StkEl contract _ _ :& r) = do +runInstrImpl _ AnnTRANSFER_TOKENS{} + (StkEl p :& StkEl (VMutez mutez) :& StkEl contract :& r) = do incrementCounter globalCounter <- isGlobalCounter <$> getInterpreterState - pure $ starNotesStkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract globalCounter)) :& r -runInstrImpl _ SET_DELEGATE (StkEl (VOption mbKeyHash) _ _ :& r) = do + pure $ StkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract globalCounter)) :& r +runInstrImpl _ AnnSET_DELEGATE{} (StkEl (VOption mbKeyHash) :& r) = do incrementCounter globalCounter <- isGlobalCounter <$> getInterpreterState case mbKeyHash of - Just (VKeyHash k) -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate (Just k) globalCounter)) :& r - Nothing -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate Nothing globalCounter)) :& r -runInstrImpl _ (CREATE_CONTRACT contract) - (StkEl (VOption mbKeyHash) _ _ :& StkEl (VMutez m) _ _ :& StkEl g _ _ :& r) = do + Just (VKeyHash k) -> pure $ StkEl (VOp (OpSetDelegate $ SetDelegate (Just k) globalCounter)) :& r + Nothing -> pure $ StkEl (VOp (OpSetDelegate $ SetDelegate Nothing globalCounter)) :& r +runInstrImpl _ (AnnCREATE_CONTRACT _ contract) + (StkEl (VOption mbKeyHash) :& StkEl (VMutez m) :& StkEl g :& r) = do originator <- ceSelf <$> ask opHash <- ceOperationHash <$> ask incrementCounter @@ -800,101 +755,104 @@ Just hash -> mkContractAddress hash globalCounter Nothing -> mkContractAddress - (mkOriginationOperationHash (createOrigOp originator mbKeyHash m contract g globalCounter)) + (mkOriginationOperationHash (createOrigOp originator Nothing mbKeyHash m contract g globalCounter)) -- If opHash is Nothing it means that interpreter is running in some kind of test -- context, therefore we generate dummy contract address with its own origination -- operation. globalCounter let resEpAddr = EpAddress resAddr DefEpName let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g contract globalCounter - pure $ starNotesStkEl (VOp (OpCreateContract resOp)) - :& starNotesStkEl (VAddress resEpAddr) + pure $ StkEl (VOp (OpCreateContract resOp)) + :& StkEl (VAddress resEpAddr) :& r -runInstrImpl _ IMPLICIT_ACCOUNT (StkEl (VKeyHash k) _ _ :& r) = - pure $ (starNotesStkEl (VContract (KeyAddress k) sepcPrimitive)) :& r -runInstrImpl _ NOW r = do +runInstrImpl _ AnnIMPLICIT_ACCOUNT{} (StkEl (VKeyHash k) :& r) = + pure $ (StkEl (VContract (KeyAddress k) sepcPrimitive)) :& r +runInstrImpl _ AnnNOW{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VTimestamp ceNow) :& r -runInstrImpl _ AMOUNT r = do + pure $ StkEl (VTimestamp ceNow) :& r +runInstrImpl _ AnnAMOUNT{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VMutez ceAmount) :& r -runInstrImpl _ BALANCE r = do + pure $ StkEl (VMutez ceAmount) :& r +runInstrImpl _ AnnBALANCE{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VMutez ceBalance) :& r -runInstrImpl _ VOTING_POWER (StkEl (VKeyHash k) _ _ :& r) = do + pure $ StkEl (VMutez ceBalance) :& r +runInstrImpl _ AnnVOTING_POWER{} (StkEl (VKeyHash k) :& r) = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VNat $ vpPick k ceVotingPowers) :& r -runInstrImpl _ TOTAL_VOTING_POWER r = do + pure $ StkEl (VNat $ vpPick k ceVotingPowers) :& r +runInstrImpl _ AnnTOTAL_VOTING_POWER{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VNat $ vpTotal ceVotingPowers) :& r -runInstrImpl _ CHECK_SIGNATURE - (StkEl (VKey k) _ _ :& StkEl (VSignature v) _ _ :& StkEl (VBytes b) _ _ :& r) = - pure $ starNotesStkEl (VBool $ checkSignature k v b) :& r -runInstrImpl _ SHA256 (StkEl (VBytes b) _ _ :& r) = - pure $ starNotesStkEl (VBytes $ sha256 b) :& r -runInstrImpl _ SHA512 (StkEl (VBytes b) _ _ :& r) = - pure $ starNotesStkEl (VBytes $ sha512 b) :& r -runInstrImpl _ BLAKE2B (StkEl (VBytes b) _ _ :& r) = - pure $ starNotesStkEl (VBytes $ blake2b b) :& r -runInstrImpl _ SHA3 (StkEl (VBytes b) _ _ :& r) = - pure $ starNotesStkEl (VBytes $ sha3 b) :& r -runInstrImpl _ KECCAK (StkEl (VBytes b) _ _ :& r) = - pure $ starNotesStkEl (VBytes $ keccak b) :& r -runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) = - pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r -runInstrImpl _ PAIRING_CHECK (StkEl (VList pairs) _ _ :& r) = do + pure $ StkEl (VNat $ vpTotal ceVotingPowers) :& r +runInstrImpl _ AnnCHECK_SIGNATURE{} + (StkEl (VKey k) :& StkEl (VSignature v) :& StkEl (VBytes b) :& r) = + pure $ StkEl (VBool $ checkSignature k v b) :& r +runInstrImpl _ AnnSHA256{} (StkEl (VBytes b) :& r) = + pure $ StkEl (VBytes $ sha256 b) :& r +runInstrImpl _ AnnSHA512{} (StkEl (VBytes b) :& r) = + pure $ StkEl (VBytes $ sha512 b) :& r +runInstrImpl _ AnnBLAKE2B{} (StkEl (VBytes b) :& r) = + pure $ StkEl (VBytes $ blake2b b) :& r +runInstrImpl _ AnnSHA3{} (StkEl (VBytes b) :& r) = + pure $ StkEl (VBytes $ sha3 b) :& r +runInstrImpl _ AnnKECCAK{} (StkEl (VBytes b) :& r) = + pure $ StkEl (VBytes $ keccak b) :& r +runInstrImpl _ AnnHASH_KEY{} (StkEl (VKey k) :& r) = + pure $ StkEl (VKeyHash $ hashKey k) :& r +runInstrImpl _ AnnPAIRING_CHECK{} (StkEl (VList pairs) :& r) = do let pairs' = [ (g1, g2) | VPair (VBls12381G1 g1, VBls12381G2 g2) <- pairs ] - pure $ starNotesStkEl (VBool $ checkPairing pairs') :& r -runInstrImpl _ SOURCE r = do + pure $ StkEl (VBool $ checkPairing pairs') :& r +runInstrImpl _ AnnSOURCE{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VAddress $ EpAddress ceSource DefEpName) :& r -runInstrImpl _ SENDER r = do + pure $ StkEl (VAddress $ EpAddress ceSource DefEpName) :& r +runInstrImpl _ AnnSENDER{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VAddress $ EpAddress ceSender DefEpName) :& r -runInstrImpl _ ADDRESS (StkEl (VContract a sepc) _ _ :& r) = - pure $ starNotesStkEl (VAddress $ EpAddress a (sepcName sepc)) :& r -runInstrImpl _ CHAIN_ID r = do + pure $ StkEl (VAddress $ EpAddress ceSender DefEpName) :& r +runInstrImpl _ AnnADDRESS{} (StkEl (VContract a sepc) :& r) = + pure $ StkEl (VAddress $ EpAddress a (sepcName sepc)) :& r +runInstrImpl _ AnnCHAIN_ID{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VChainId ceChainId) :& r -runInstrImpl _ LEVEL r = do + pure $ StkEl (VChainId ceChainId) :& r +runInstrImpl _ AnnLEVEL{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VNat ceLevel) :& r -runInstrImpl _ SELF_ADDRESS r = do + pure $ StkEl (VNat ceLevel) :& r +runInstrImpl _ AnnSELF_ADDRESS{} r = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VAddress $ EpAddress ceSelf DefEpName) :& r -runInstrImpl _ TICKET (StkEl dat _ _ :& StkEl (VNat am) _ _ :& r) = do + pure $ StkEl (VAddress $ EpAddress ceSelf DefEpName) :& r +runInstrImpl _ AnnTICKET{} (StkEl dat :& StkEl (VNat am) :& r) = do ContractEnv{..} <- ask - pure $ starNotesStkEl (VTicket ceSelf dat am) :& r -runInstrImpl _ READ_TICKET (te@(StkEl (VTicket addr dat am) _ _) :& r) = do + pure $ StkEl (VTicket ceSelf dat am) :& r +runInstrImpl _ AnnREAD_TICKET{} (te@(StkEl (VTicket addr dat am)) :& r) = do pure $ - starNotesStkEl + StkEl (VPair (VAddress (EpAddress addr DefEpName), (VPair (dat, VNat am)))) :& te :& r -runInstrImpl _ SPLIT_TICKET - (StkEl tv@(VTicket addr dat am) _ _ :& - StkEl (VPair (VNat am1, VNat am2)) _ _ :& r) = do +runInstrImpl _ AnnSPLIT_TICKET{} + (StkEl tv@(VTicket addr dat am) :& + StkEl (VPair (VNat am1, VNat am2)) :& r) = do let result = withValueTypeSanity tv $ VOption do guard (am1 + am2 == am) return $ VPair (VTicket addr dat am1, VTicket addr dat am2) - pure $ starNotesStkEl result :& r -runInstrImpl _ JOIN_TICKETS - (StkEl (VPair (tv1@(VTicket addr1 dat1 am1), VTicket addr2 dat2 am2)) _ _ :& r) = do + pure $ StkEl result :& r +runInstrImpl _ AnnJOIN_TICKETS{} + (StkEl (VPair (tv1@(VTicket addr1 dat1 am1), VTicket addr2 dat2 am2)) :& r) = do let result = withValueTypeSanity tv1 $ VOption do guard (addr1 == addr2) guard (dat1 == dat2) return $ VTicket addr1 dat1 (am1 + am2) - pure $ starNotesStkEl result :& r -runInstrImpl _ OPEN_CHEST - (StkEl (VChestKey ck) _ _ :& StkEl (VChest c) _ _ :& StkEl (VNat nat) _ _ :& r) = do + pure $ StkEl result :& r +runInstrImpl _ AnnOPEN_CHEST{} + (StkEl (VChestKey ck) :& StkEl (VChest c) :& StkEl (VNat nat) :& r) = do let result = case mkTLTime nat of Right time -> case openChest c ck time of Correct bytes -> VOr (Left (VBytes bytes)) BogusOpening -> VOr (Right (VBool True)) BogusCipher -> VOr (Right (VBool False)) Left _ -> VOr (Right (VBool True)) - pure $ starNotesStkEl result :& r -runInstrImpl _ (SAPLING_EMPTY_STATE _) _ = throwMichelson $ MichelsonUnsupported "SAPLING_EMPTY_STATE" -runInstrImpl _ SAPLING_VERIFY_UPDATE _ = throwMichelson $ MichelsonUnsupported "SAPLING_VERIFY_UPDATE" + pure $ StkEl result :& r +runInstrImpl _ AnnSAPLING_EMPTY_STATE{} _ = throwMichelson $ MichelsonUnsupported "SAPLING_EMPTY_STATE" +runInstrImpl _ AnnSAPLING_VERIFY_UPDATE{} _ = throwMichelson $ MichelsonUnsupported "SAPLING_VERIFY_UPDATE" +runInstrImpl _ AnnMIN_BLOCK_TIME{} r = do + ContractEnv{..} <- ask + pure $ StkEl (VNat ceMinBlockTime) :& r -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp @@ -905,7 +863,7 @@ -> monad (StkEl (ArithRes aop n m)) runArithOp op l r = case evalOp op (seValue l) (seValue r) of Left err -> throwMichelson $ MichelsonArithError err - Right res -> pure $ starNotesStkEl res + Right res -> pure $ StkEl res -- | Unpacks given raw data into a typed value. runUnpack @@ -921,13 +879,14 @@ createOrigOp :: (ParameterScope param, StorageScope store) => Address + -> Maybe Alias -> Maybe (T.Value 'T.TKeyHash) -> Mutez -> Contract param store -> Value' Instr store -> GlobalCounter -> OriginationOperation -createOrigOp originator mbDelegate bal contract storage counter = +createOrigOp originator mbAlias mbDelegate bal contract storage counter = OriginationOperation { ooOriginator = originator , ooDelegate = unwrapMbKeyHash mbDelegate @@ -935,6 +894,7 @@ , ooStorage = storage , ooContract = contract , ooCounter = counter + , ooAlias = mbAlias } unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash @@ -991,11 +951,12 @@ -- Otherwise, assign IDs only to bigmaps that don't have one yet. -> Value t -> m (Value t) assignBigMapIds overwriteExistingId = - dfsTraverseValue \case - VBigMap existingId vBigMap | overwriteExistingId || isNothing existingId -> do - bigMapId <- bigMapCounter <<+= 1 - pure $ VBigMap (Just bigMapId) vBigMap - v -> pure v + dfsTraverseValue def{ dsValueStep = \case + VBigMap existingId vBigMap | overwriteExistingId || isNothing existingId -> do + bigMapId <- bigMapCounter <<+= 1 + pure $ VBigMap (Just bigMapId) vBigMap + v -> pure v + } incrementCounter :: (InterpreterStateMonad m) => m () incrementCounter = modifyInterpreterState $ \iState -> diff --git a/src/Morley/Michelson/Interpret/Unpack.hs b/src/Morley/Michelson/Interpret/Unpack.hs --- a/src/Morley/Michelson/Interpret/Unpack.hs +++ b/src/Morley/Michelson/Interpret/Unpack.hs @@ -28,7 +28,7 @@ import Fmt (pretty) import Morley.Micheline.Binary (eitherDecodeExpression) -import Morley.Micheline.Class (FromExpression(..)) +import Morley.Micheline.Class (FromExpression, fromExpression) import Morley.Michelson.Typed (UnpackedValScope) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped diff --git a/src/Morley/Michelson/Let.hs b/src/Morley/Michelson/Let.hs deleted file mode 100644 --- a/src/Morley/Michelson/Let.hs +++ /dev/null @@ -1,32 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Morley.Michelson.Let - ( LetType (..) - , LetValue (..) - ) where - -import Data.Aeson.TH (deriveJSON) -import Data.Text qualified as T - -import Morley.Michelson.Macro (ParsedOp) -import Morley.Michelson.Untyped (Ty, Value') -import Morley.Util.Aeson - --- | A programmer-defined constant -data LetValue = LetValue - { lvName :: T.Text - , lvSig :: Ty - , lvVal :: (Value' ParsedOp) - } deriving stock (Eq, Show) - -{-# DEPRECATED LetValue, LetType "Let macros are deprecated" #-} - --- | A programmer-defined type-synonym -data LetType = LetType - { ltName :: T.Text - , ltSig :: Ty - } deriving stock (Eq, Show) - -deriveJSON morleyAesonOptions ''LetValue -deriveJSON morleyAesonOptions ''LetType diff --git a/src/Morley/Michelson/Macro.hs b/src/Morley/Michelson/Macro.hs --- a/src/Morley/Michelson/Macro.hs +++ b/src/Morley/Michelson/Macro.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - module Morley.Michelson.Macro ( -- * Macros types @@ -11,7 +8,6 @@ , PairStruct (..) , UnpairStruct (..) , Macro (..) - , LetMacro (..) -- * Morley Parsed value types , ParsedValue @@ -41,29 +37,13 @@ import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) -import Data.Text qualified as T import Fmt (Buildable(build), GenericBuildable(..), (+|), (|+)) import Morley.Michelson.ErrorPos import Morley.Michelson.Printer (RenderDoc(..)) import Morley.Michelson.Untyped import Morley.Util.Aeson -import Morley.Util.Generic -import Morley.Util.Positive --- | A programmer-defined macro -data LetMacro = LetMacro - { lmName :: T.Text - , lmSig :: StackFn - , lmExpr :: [ParsedOp] - } - deriving stock (Eq, Show, Data, Generic) - deriving Buildable via GenericBuildable LetMacro - -{-# DEPRECATED LetMacro "Let macros are deprecated" #-} - -instance NFData LetMacro - data PairStruct = F FieldAnn | P PairStruct PairStruct @@ -93,18 +73,16 @@ data ParsedOp = Prim ParsedInstr SrcPos -- ^ Primitive Michelson instruction | Mac Macro SrcPos -- ^ Built-in Michelson macro defined by the specification - | LMac LetMacro SrcPos -- ^ User-defined macro with instructions to be inlined | Seq [ParsedOp] SrcPos -- ^ A sequence of instructions deriving stock (Eq, Show, Data, Generic) instance RenderDoc ParsedOp where - renderDoc pn parsedOp = renderDoc pn $ expand [] parsedOp + renderDoc pn parsedOp = renderDoc pn $ expand parsedOp instance Buildable ParsedOp where build = \case Prim parseInstr _ -> "" Mac macro _ -> "" - LMac letMacro _ -> "" Seq parsedOps _ -> "" instance NFData ParsedOp @@ -119,21 +97,9 @@ type ParsedValue = Value' ParsedOp -{-# DEPRECATED - CASE, TAG, ACCESS, SET, CONSTRUCT, VIEW_, VOID - "Morley-specific macros are deprecated" #-} - -- | Built-in Michelson Macros defined by the specification data Macro - = CASE (NonEmpty [ParsedOp]) - | TAG Natural (NonEmpty Ty) - | ACCESS Natural Positive - | SET Natural Positive - | CONSTRUCT (NonEmpty [ParsedOp]) - -- A1/TZIP4 VIEW, exists for historical reasons - | VIEW_ [ParsedOp] - | VOID [ParsedOp] - | CMP ParsedInstr VarAnn + = CMP ParsedInstr VarAnn | IFX ParsedInstr [ParsedOp] [ParsedOp] | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp] | FAIL @@ -159,13 +125,6 @@ instance Buildable Macro where build = \case - TAG idx ty -> " "" - ACCESS idx size -> " " "" - VIEW_ code -> "" - VOID code -> "" CMP parsedInstr carAnn -> "" IFX parsedInstr parsedOps1 parsedOps2 -> "" IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> "" @@ -192,7 +151,7 @@ instance NFData Macro expandList :: [ParsedOp] -> [ExpandedOp] -expandList = fmap (expand []) +expandList = fmap expand expandView :: View' ParsedOp -> View expandView v = v{ viewCode = expandList (viewCode v) } @@ -218,13 +177,13 @@ ValueLambda opList -> maybe ValueNil ValueLambda $ nonEmpty (expandList $ toList opList) - x -> fmap (expand []) x + x -> fmap expand x expandElt :: Elt ParsedOp -> Elt ExpandedOp expandElt (Elt l r) = Elt (expandValue l) (expandValue r) -expand :: LetCallStack -> ParsedOp -> ExpandedOp -expand cs = let ics pos = InstrCallStack cs pos in \case +expand :: ParsedOp -> ExpandedOp +expand = let ics pos = ErrorSrcPos pos in \case -- We handle this case specially, because it's essentially just PAIR. -- It's needed because we have a hack in parser: we parse PAIR as PAPAIR. -- We need to do something better eventually. @@ -236,55 +195,25 @@ -- As the above comment says, we need to do something better eventually -- (e. g. to avoid `error` usage inside `expandMacro`). (Mac (DIIP n ops) pos) -> - WithSrcEx (ics pos) $ PrimEx (DIPN n (expand cs <$> ops)) + WithSrcEx (ics pos) $ PrimEx (DIPN n (expand <$> ops)) -- Similarly to above, DUUP is now always represented as a single instruction. (Mac (DUUP n v) pos) -> WithSrcEx (ics pos) $ PrimEx $ DUPN v n (Mac m pos) -> WithSrcEx (ics pos) $ SeqEx $ expandMacro (ics pos) m - (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand cs <$> i - (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand cs <$> s - (LMac l pos) -> expandLetMac l - where - expandLetMac :: LetMacro -> ExpandedOp - expandLetMac LetMacro {..} = - let newCS = LetName lmName : cs in - let ics' = InstrCallStack newCS pos in - WithSrcEx ics' $ PrimEx . EXT . FN lmName lmSig $ expand newCS <$> lmExpr + (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand <$> i + (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand <$> s -expandMacro :: InstrCallStack -> Macro -> [ExpandedOp] -expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case - VIEW_ a -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) - , PrimEx (DIP $ oprimEx $ DUPN noAnn 2) - , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++ - (expand cs <$> a) ++ - [ PrimEx (DIP [PrimEx $ AMOUNT noAnn]) - , PrimEx $ TRANSFER_TOKENS noAnn - , PrimEx $ NIL noAnn noAnn (Ty TOperation noAnn) - , PrimEx $ SWAP - , PrimEx $ CONS noAnn - , PrimEx $ PAIR noAnn noAnn noAnn noAnn - ] - VOID a -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) - , PrimEx SWAP - , PrimEx $ DIP $ expand cs <$> a - , PrimEx SWAP - , PrimEx $ EXEC noAnn - , PrimEx FAILWITH - ] - CASE ops -> expandCase (map (expand cs) <$> ops) - TAG idx uty -> expandTag idx uty - ACCESS idx size -> expandAccess idx size - SET idx size -> expandSet idx size - CONSTRUCT ops -> expandConstruct (map (expand cs) <$> ops) +expandMacro :: ErrorSrcPos -> Macro -> [ExpandedOp] +expandMacro p@ErrorSrcPos{unErrorSrcPos=macroPos} = \case CMP i v -> [PrimEx (COMPARE v), xo i] IFX i bt bf -> [xo i, PrimEx $ IF (xp bt) (xp bf)] - IFCMP i v bt bf -> PrimEx <$> [COMPARE v, expand cs <$> i, IF (xp bt) (xp bf)] + IFCMP i v bt bf -> PrimEx <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)] IF_SOME bt bf -> [PrimEx (IF_NONE (xp bf) (xp bt))] IF_RIGHT bt bf -> [PrimEx (IF_LEFT (xp bf) (xp bt))] FAIL -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH] ASSERT -> oprimEx $ IF [] (expandMacro p FAIL) - ASSERTX i -> [expand cs $ mac $ IFX i [] [mac FAIL]] - ASSERT_CMP i -> [expand cs $ mac $ IFCMP i noAnn [] [mac FAIL]] + ASSERTX i -> [expand $ mac $ IFX i [] [mac FAIL]] + ASSERT_CMP i -> [expand $ mac $ IFCMP i noAnn [] [mac FAIL]] ASSERT_NONE -> oprimEx $ IF_NONE [] (expandMacro p FAIL) ASSERT_SOME -> oprimEx $ IF_NONE (expandMacro p FAIL) [] ASSERT_LEFT -> oprimEx $ IF_LEFT [] (expandMacro p FAIL) @@ -303,14 +232,14 @@ where mac = flip Mac macroPos oprimEx = one . PrimEx - xo = PrimEx . fmap (expand cs) - xp = fmap (expand cs) + xo = PrimEx . fmap expand + xp = fmap expand -- | The macro expansion rules below were taken from: https://tezos.gitlab.io/active/michelson.html#syntactic-conveniences -- -- The correctness of type-annotation expansion is currently untested, as these -- expansions are not explicitly documented in the Michelson Specification. -expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp] +expandPapair :: ErrorSrcPos -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp] expandPapair ics ps t v = case ps of P (F a) (F b) -> [PrimEx $ PAIR t v a b] @@ -332,7 +261,7 @@ F _ -> [] -- | The macro expansion rules below were taken from: https://tezos.gitlab.io/active/michelson.html#syntactic-conveniences -expandUnpapair :: InstrCallStack -> UnpairStruct -> [ExpandedOp] +expandUnpapair :: ErrorSrcPos -> UnpairStruct -> [ExpandedOp] expandUnpapair ics = \case UP UF UF -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) ] @@ -359,7 +288,7 @@ -- but if it accidentally happened let's just do nothing. UF -> [] -expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp] +expandCadr :: ErrorSrcPos -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp] expandCadr ics cs v f = case cs of [] -> [] [A] -> [PrimEx $ CAR v f] @@ -376,7 +305,7 @@ pairNoAnn :: VarAnn -> InstrAbstract op pairNoAnn v = PAIR noAnn v [annQ|@|] [annQ|@|] -expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp] +expandSetCadr :: ErrorSrcPos -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp] expandSetCadr ics cs v f = PrimEx <$> case cs of [] -> [] [A] -> [DUP noAnn, CAR noAnn f, DROP, @@ -388,71 +317,14 @@ A:css -> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (SET_CADR css noAnn f)), cdrNoAnn, SWAP, pairNoAnn v] D:css -> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (SET_CADR css noAnn f)), carNoAnn, pairNoAnn v] -expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp] -expandMapCadr ics@InstrCallStack{icsCallStack=cls} cs v f ops = case cs of +expandMapCadr :: ErrorSrcPos -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp] +expandMapCadr ics cs v f ops = case cs of [] -> [] - [A] -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, PAIR noAnn v f [annQ|@|]] - [D] -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, PAIR noAnn v [annQ|@|] f]] + [A] -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand <$> ops)], SWAP, PAIR noAnn v f [annQ|@|]] + [D] -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand <$> ops)], PrimEx <$> [SWAP, carNoAnn, PAIR noAnn v [annQ|@|] f]] A:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), cdrNoAnn, SWAP, pairNoAnn v] D:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), carNoAnn, pairNoAnn v] -expandCase :: NonEmpty [ExpandedOp] -> [ExpandedOp] -expandCase = mkGenericTree (\_ l r -> one . PrimEx $ IF_LEFT l r) - -expandTag :: Natural -> NonEmpty Ty -> [ExpandedOp] -expandTag idx unionTy = - reverse . fst $ mkGenericTree merge (([], ) <$> unionTy) - where - merge i (li, lt) (ri, rt) = - let ty = Ty (TOr noAnn noAnn lt rt) noAnn - in if idx < i - then (PrimEx (LEFT noAnn noAnn noAnn noAnn rt) : li, ty) - else (PrimEx (RIGHT noAnn noAnn noAnn noAnn lt) : ri, ty) - -expandAccess :: Natural -> Positive -> [ExpandedOp] -expandAccess idx size = - mkGenericTree merge (replicateNE size []) - where - merge i li ri = - if idx < i - then PrimEx (CAR noAnn noAnn) : li - else PrimEx (CDR noAnn noAnn) : ri - -expandSet :: Natural -> Positive -> [ExpandedOp] -expandSet idx size = - PrimEx <$> - appEndo (mkGenericTree merge (replicateNE size base)) [] - where - base = pre $ DIP [PrimEx DROP] - merge i li ri = mconcat $ - if idx < i - then [ pre $ DIP - (map PrimEx [DUP n, DIP [PrimEx $ CDR n n], CAR n n]) - , li - , pre $ PAIR n n n n - ] - else [ pre $ DIP - (map PrimEx [DUP n, DIP [PrimEx $ CAR n n], CDR n n]) - , ri - , pre $ SWAP - , pre $ PAIR n n n n - ] - pre e = Endo (e :) - n = noAnn - -expandConstruct :: NonEmpty [ExpandedOp] -> [ExpandedOp] -expandConstruct ctors = - appEndo (mkGenericTree merge $ map toBase ctors) [] - where - toBase ops = Endo (ops ++) - merge _ li ri = - mconcat - [ li - , pre . PrimEx $ DIP (appEndo ri []) - , pre . PrimEx $ PAIR noAnn noAnn noAnn noAnn - ] - pre e = Endo (e :) - mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct mapPairLeaves fs p = evalState (pairLeavesST p) fs @@ -469,9 +341,11 @@ getLeaf (a:as) = (a, as) getLeaf _ = (noAnn, []) -deriveJSON morleyAesonOptions ''ParsedOp -deriveJSON morleyAesonOptions ''LetMacro deriveJSON morleyAesonOptions ''PairStruct deriveJSON morleyAesonOptions ''UnpairStruct deriveJSON morleyAesonOptions ''CadrStruct -deriveJSON morleyAesonOptions ''Macro + +$(mconcat + [ deriveJSON morleyAesonOptions ''Macro + , deriveJSON morleyAesonOptions ''ParsedOp + ]) diff --git a/src/Morley/Michelson/Optimizer.hs b/src/Morley/Michelson/Optimizer.hs --- a/src/Morley/Michelson/Optimizer.hs +++ b/src/Morley/Michelson/Optimizer.hs @@ -7,9 +7,6 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-overlapping-patterns #-} --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Optimizer for typed instructions. -- -- It's quite experimental and incomplete. @@ -122,7 +119,6 @@ flattenSeqLHS `orSimpleRule` removeNesting `orSimpleRule` removeExtStackType - `orSimpleRule` flattenFn `orSimpleRule` dipDrop2swapDrop `orSimpleRule` ifNopNop2Drop `orSimpleRule` nopIsNeutralForSeq @@ -164,11 +160,6 @@ Ext (STACKTYPE{}) -> Just Nop _ -> Nothing -flattenFn :: Rule -flattenFn = Rule $ \case - Fn _ _ i -> Just i - _ -> Nothing - dipDrop2swapDrop :: Rule dipDrop2swapDrop = Rule $ \case DIP DROP -> Just $ SWAP :# DROP @@ -564,7 +555,7 @@ LE :# DROP :# c -> Just $ DROP :# c GE :# DROP :# c -> Just $ DROP :# c INT :# DROP :# c -> Just $ DROP :# c - CONTRACT _ _ :# DROP :# c -> Just $ DROP :# c + CONTRACT _ :# DROP :# c -> Just $ DROP :# c SET_DELEGATE :# DROP :# c -> Just $ DROP :# c IMPLICIT_ACCOUNT :# DROP :# c -> Just $ DROP :# c VOTING_POWER :# DROP :# c -> Just $ DROP :# c @@ -601,7 +592,7 @@ LE :# DROP -> Just DROP GE :# DROP -> Just DROP INT :# DROP -> Just DROP - CONTRACT _ _ :# DROP -> Just DROP + CONTRACT _ :# DROP -> Just DROP SET_DELEGATE :# DROP -> Just DROP IMPLICIT_ACCOUNT :# DROP -> Just DROP VOTING_POWER :# DROP -> Just DROP diff --git a/src/Morley/Michelson/Parser.hs b/src/Morley/Michelson/Parser.hs --- a/src/Morley/Michelson/Parser.hs +++ b/src/Morley/Michelson/Parser.hs @@ -1,16 +1,12 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations -Wno-redundant-constraints #-} - module Morley.Michelson.Parser ( -- * Main parser type Parser -- * Parsers , program - , programExt , value -- * Errors @@ -30,13 +26,11 @@ , codeEntry , ops , type_ - , letInner - , letType , stringLiteral , bytesLiteral , intLiteral , parsedOp - , printComment + , cbParameterBare -- * Quoters , utypeQ @@ -49,24 +43,20 @@ import Prelude hiding (try) -import Data.Default (Default(..)) import Fmt (pretty, (+|), (|+)) import Language.Haskell.TH qualified as TH import Language.Haskell.TH.Quote qualified as TH import Language.Haskell.TH.Syntax qualified as TH import Text.Megaparsec - (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead, - parse, sepEndBy, try) + (Parsec, choice, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead, parse, + sepEndBy, try) import Text.Megaparsec.Pos (SourcePos(..), unPos) import Morley.Michelson.ErrorPos (SrcPos(..), mkPos) import Morley.Michelson.Macro (Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue) -import Morley.Michelson.Parser.Annotations (noteF) import Morley.Michelson.Parser.Common import Morley.Michelson.Parser.Error -import Morley.Michelson.Parser.Ext import Morley.Michelson.Parser.Instr -import Morley.Michelson.Parser.Let import Morley.Michelson.Parser.Lexer import Morley.Michelson.Parser.Macro import Morley.Michelson.Parser.Type @@ -81,13 +71,12 @@ ---------------------------------------------------------------------------- -- | Parse with empty environment -parseNoEnv :: - Default le - => Parser' le a +parseNoEnv + :: Parser a -> MichelsonSource -> Text -> Either (ParseErrorBundle Text CustomParserException) a -parseNoEnv p src = parse (runReaderT p def <* eof) (pretty src) +parseNoEnv p src = parse (p <* eof) (pretty src) ------------------------------------------------------------------------------- -- Parsers @@ -98,42 +87,24 @@ -- | Michelson contract program :: Parsec CustomParserException Text (Contract' ParsedOp) -program = runReaderT (programInner @()) def <* eof - -programInner - :: forall env. (Default env) - => Parser env (Contract' ParsedOp) -programInner = do - mSpace - env <- fromMaybe def <$> (optional (letBlock parsedOp)) - local (const env) contract +program = programInner <* eof --- TODO [#712]: Remove this next major release --- | Michelson contract with let definitions -programExt :: Parsec CustomParserException Text (Contract' ParsedOp) -programExt = runReaderT (programInner @LetEnv) def <* eof +programInner :: Parser (Contract' ParsedOp) +programInner = mSpace *> contract -cbParameter :: Parser le ParameterType +cbParameter :: Parser ParameterType cbParameter = symbol1 "parameter" *> cbParameterBare -cbParameterBare :: Parser le ParameterType -cbParameterBare = do - prefixRootAnn <- optional noteF - (inTypeRootAnn, t) <- field - rootAnn <- case (prefixRootAnn, inTypeRootAnn) of - (Just a, b) | a == noAnn && b == noAnn -> pure noAnn - (Just a, b) | b == noAnn -> pure a - (Nothing, b) -> pure b - (Just _, _) -> customFailure MultiRootAnnotationException - pure $ ParameterType t rootAnn +cbParameterBare :: Parser ParameterType +cbParameterBare = uncurry ParameterType . swap <$> field -cbStorage :: Parser le Ty +cbStorage :: Parser Ty cbStorage = symbol1 "storage" *> type_ -cbCode :: Parser le [ParsedOp] +cbCode :: Parser [ParsedOp] cbCode = symbol "code" *> codeEntry -cbView :: Parser le (View' ParsedOp) +cbView :: Parser (View' ParsedOp) cbView = do symbol "view" viewName <- viewName_ @@ -142,7 +113,7 @@ viewCode <- ops return View{..} -contractBlock :: Parser le (ContractBlock ParsedOp) +contractBlock :: Parser (ContractBlock ParsedOp) contractBlock = choice [ (CBParam <$> cbParameter) , (CBStorage <$> cbStorage) @@ -151,7 +122,7 @@ ] -- | This ensures that the error message will point to the correct line. -ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le () +ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser () ensureNotDuplicate blocks result = let failDuplicateField a = fail $ "Duplicate contract field: " +| a |+ "" @@ -165,7 +136,7 @@ (_, []) -> pure () -- | Michelson contract -contract :: Parser le (Contract' ParsedOp) +contract :: Parser (Contract' ParsedOp) contract = do mSpace result <- braces contractTuple <|> contractTuple @@ -186,7 +157,7 @@ -- Value ------------------ -value :: Parser le ParsedValue +value :: Parser ParsedValue value = value' parsedOp -- | Parse untyped value from text which comes from something that is @@ -202,7 +173,7 @@ -- expecting value -- parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue -parseValue = first ParserException ... (parseNoEnv @()) value +parseValue = first ParserException ... parseNoEnv value -- | Like 'parseValue', but also expands macros. parseExpandValue :: MichelsonSource -> Text -> Either ParserException U.Value @@ -211,7 +182,7 @@ -- Primitive instruction ------------------ -prim :: Parser le ParsedInstr +prim :: Parser ParsedInstr prim = primInstr contract parsedOp -- Parsed operations (primitive instructions, macros, extras, etc.) @@ -220,14 +191,14 @@ -- | Parses code block after "code" keyword of a contract. -- -- This function is part of the module API, its semantics should not change. -codeEntry :: Parser le [ParsedOp] +codeEntry :: Parser [ParsedOp] codeEntry = bracewrappedOps -bracewrappedOps :: Parser le [ParsedOp] +bracewrappedOps :: Parser [ParsedOp] bracewrappedOps = lookAhead (symbol "{") *> ops -- | --- >>> parseNoEnv @() parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ()) +-- >>> parseNoEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ()) -- 1:2: -- | -- 1 | {a} @@ -235,35 +206,17 @@ -- unexpected 'a' -- expecting '{', '}', macro, or primitive instruction -- --- >>> :m + Morley.Michelson.Parser.Types --- >>> parseNoEnv @LetEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ()) --- ... --- 1:2: --- | --- 1 | {a} --- | ^ --- unexpected 'a' --- expecting '{', '}', macro, morley instruction, or primitive instruction --- -parsedOp :: Parser le ParsedOp +parsedOp :: Parser ParsedOp parsedOp = do pos <- getSrcPos choice - [ withLetEnv $ flip Prim pos <$> (EXT <$> extInstr ops) - , withLetEnv $ lmacWithPos - , flip Prim pos <$> prim + [ flip Prim pos <$> prim , flip Mac pos <$> macro parsedOp , primOrMac , flip Seq pos <$> bracewrappedOps ] - where - lmacWithPos :: Parser' LetEnv ParsedOp - lmacWithPos = do - act <- mkLetMac <$> asks letMacros - srcPos <- getSrcPos - flip LMac srcPos <$> act -getSrcPos :: Parser le SrcPos +getSrcPos :: Parser SrcPos getSrcPos = do sp <- getSourcePos let l = unPos $ sourceLine sp @@ -271,17 +224,17 @@ -- reindexing starting from 0 pure . unsafe $ SrcPos <$> (mkPos $ l - 1) <*> (mkPos $ c - 1) -primWithPos :: Parser le ParsedInstr -> Parser le ParsedOp +primWithPos :: Parser ParsedInstr -> Parser ParsedOp primWithPos act = do srcPos <- getSrcPos flip Prim srcPos <$> act -macWithPos :: Parser le Macro -> Parser le ParsedOp +macWithPos :: Parser Macro -> Parser ParsedOp macWithPos act = do srcPos <- getSrcPos flip Mac srcPos <$> act -ops :: Parser le [ParsedOp] +ops :: Parser [ParsedOp] ops = ops' parsedOp ------------------------------------------------------------------------------- @@ -289,10 +242,10 @@ -- These are needed for better error messages ------------------------------------------------------------------------------- -ifOrIfX :: Parser le ParsedOp +ifOrIfX :: Parser ParsedOp ifOrIfX = do pos <- getSrcPos - symbol' "IF" + symbol "IF" a <- eitherP cmpOp ops case a of Left cmp -> flip Mac pos <$> (IFX cmp <$> ops <*> ops) @@ -300,7 +253,7 @@ -- Some of the operations and macros have the same prefixes in their names -- So this case should be handled separately -primOrMac :: Parser le ParsedOp +primOrMac :: Parser ParsedOp primOrMac = hidden $ (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX) <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp)) @@ -312,7 +265,7 @@ -- Safe construction of Haskell values ------------------------------------------------------------------------------- -parserToQuasiQuoter :: Parser () (TH.Q TH.Exp) -> TH.QuasiQuoter +parserToQuasiQuoter :: Parser (TH.Q TH.Exp) -> TH.QuasiQuoter parserToQuasiQuoter parser = TH.QuasiQuoter { TH.quoteExp = \s -> case parseNoEnv (mSpace *> parser) "quasi-quoter" (toText s) of diff --git a/src/Morley/Michelson/Parser/Annotations.hs b/src/Morley/Michelson/Parser/Annotations.hs --- a/src/Morley/Michelson/Parser/Annotations.hs +++ b/src/Morley/Michelson/Parser/Annotations.hs @@ -3,6 +3,7 @@ module Morley.Michelson.Parser.Annotations ( note + , anyNote , noteF , noteV , noteDef @@ -32,7 +33,7 @@ import Morley.Util.Default -- | General T/V/F Annotation parser, including Special Annotations -note :: forall tag le. KnownAnnTag tag => Parser le (Annotation tag) +note :: forall tag. KnownAnnTag tag => Parser (Annotation tag) note = lexeme $ string (annPrefix @tag) >> (specialNote <|> note' <|> emptyNote) where -- TODO [#48]: these are special annotations and should not always be accepted @@ -45,22 +46,29 @@ b <- takeWhileP Nothing isValidAnnBodyChar return . unsafe . mkAnnotation $ T.cons a b -noteV :: Parser le VarAnn +-- | Parse arbitrary annotation. +anyNote :: Parser AnyAnn +anyNote = + AnyAnnType <$> note @TypeTag + <|> AnyAnnField <$> note @FieldTag + <|> AnyAnnVar <$> note @VarTag + +noteV :: Parser VarAnn noteV = note -noteDef :: KnownAnnTag tag => Parser le (Annotation tag) +noteDef :: KnownAnnTag tag => Parser (Annotation tag) noteDef = parseDef note -noteF :: Parser le FieldAnn +noteF :: Parser FieldAnn noteF = note -noteV2Def :: Parser le (VarAnn, VarAnn) +noteV2Def :: Parser (VarAnn, VarAnn) noteV2Def = permute2Def note note -notesTVF :: Parser le (TypeAnn, VarAnn, FieldAnn) +notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn) notesTVF = permute3Def note note note -notesTVF2Def :: Parser le (TypeAnn, VarAnn, (FieldAnn, FieldAnn)) +notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn)) notesTVF2Def = permute3Def note note (permute2Def note note) -- | Parse 0/1/2 var anns and 0/1/2 field anns. @@ -75,21 +83,21 @@ -- * "@c @d %a %b" is valid -- * "@c %a %b @d" is not valid, because the two var anns are not "grouped" together. -- * "%a @c @d %b" is not valid, because the two fields anns are not "grouped" together. -notesVVFF :: Parser le ((VarAnn, VarAnn), (FieldAnn, FieldAnn)) +notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn)) notesVVFF = permute2Def (liftA2 (,) note noteDef) (liftA2 (,) note noteDef) -notesVF :: Parser le (VarAnn, FieldAnn) +notesVF :: Parser (VarAnn, FieldAnn) notesVF = permute2Def note note -notesTV :: Parser le (TypeAnn, VarAnn) +notesTV :: Parser (TypeAnn, VarAnn) notesTV = permute2Def note note -notesTF :: Parser le (TypeAnn, FieldAnn) +notesTF :: Parser (TypeAnn, FieldAnn) notesTF = permute2Def note note fieldType :: Default a - => Parser le a - -> Parser le (a, TypeAnn) + => Parser a + -> Parser (a, TypeAnn) fieldType fp = runPermutation $ (,) <$> toPermutationWithDefault def fp <*> toPermutationWithDefault noAnn note diff --git a/src/Morley/Michelson/Parser/Common.hs b/src/Morley/Michelson/Parser/Common.hs --- a/src/Morley/Michelson/Parser/Common.hs +++ b/src/Morley/Michelson/Parser/Common.hs @@ -13,7 +13,7 @@ import Morley.Michelson.Parser.Types import Morley.Michelson.Untyped -viewName_ :: Parser le ViewName +viewName_ :: Parser ViewName viewName_ = lexeme do string "\"" str <- manyTill anySingle (string "\"") diff --git a/src/Morley/Michelson/Parser/Error.hs b/src/Morley/Michelson/Parser/Error.hs --- a/src/Morley/Michelson/Parser/Error.hs +++ b/src/Morley/Michelson/Parser/Error.hs @@ -11,33 +11,19 @@ ) where import Data.Data (Data(..)) -import Fmt (Buildable(build), pretty, (+|), (|+)) +import Fmt (Buildable(build), pretty) import Text.Megaparsec (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty) import Morley.Michelson.Untyped.View import Morley.Util.Instances () -import Morley.Util.Positive data CustomParserException = StringLiteralException StringLiteralParserException | ViewNameException BadViewNameError | OddNumberBytesException - | WrongTagArgs Natural Positive - | WrongAccessArgs Natural Positive - | WrongSetArgs Natural Positive | ExcessFieldAnnotation - | MultiRootAnnotationException - | DeprecatedException deriving stock (Eq, Data, Ord, Show, Generic) -{-# DEPRECATED - WrongTagArgs - , WrongAccessArgs - , WrongSetArgs - - "Exceptions specific to deprecated Morley language extensions" - #-} - instance NFData CustomParserException instance ShowErrorComponent CustomParserException where @@ -45,18 +31,6 @@ showErrorComponent (ViewNameException e) = pretty e showErrorComponent OddNumberBytesException = "odd number bytes" showErrorComponent ExcessFieldAnnotation = "excess field annotation" - showErrorComponent MultiRootAnnotationException = "unexpected multiple root annotations" - showErrorComponent DeprecatedException = "deprecated syntax, use --deprecated-morley-extensions \ - \command-line argument to silence this error" - showErrorComponent (WrongTagArgs idx size) = - "TAG: too large index: " +| idx |+ " \ - \exceedes union size " +| size |+ "" - showErrorComponent (WrongAccessArgs idx size) = - "ACCESS: too large index: " +| idx |+ " \ - \exceedes tuple size " +| size |+ "" - showErrorComponent (WrongSetArgs idx size) = - "SET: too large index: " +| idx |+ " \ - \exceedes tuple size " +| size |+ "" data StringLiteralParserException = InvalidEscapeSequence Char diff --git a/src/Morley/Michelson/Parser/Ext.hs b/src/Morley/Michelson/Parser/Ext.hs deleted file mode 100644 --- a/src/Morley/Michelson/Parser/Ext.hs +++ /dev/null @@ -1,76 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | Parsing logic for extra instructions (Morley extensions) - -module Morley.Michelson.Parser.Ext - ( extInstr - , stackType - - -- * For tests - , printComment - ) where - -import Prelude hiding (try) - -import Text.Megaparsec (choice, label, satisfy, try) -import Text.Megaparsec.Char (alphaNumChar, string) -import Text.Megaparsec.Char.Lexer qualified as L - -import Morley.Michelson.Macro (ParsedOp(..), ParsedUExtInstr) -import Morley.Michelson.Parser.Lexer -import Morley.Michelson.Parser.Type -import Morley.Michelson.Parser.Types (LetEnv, Parser') -import Morley.Michelson.Untyped qualified as U - -extInstr :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr -extInstr opsParser = do - label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp] - -stackOp :: Parser' LetEnv ParsedUExtInstr -stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType - -testAssertOp :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr -testAssertOp opsParser = - word' "TEST_ASSERT" U.UTEST_ASSERT <*> testAssert opsParser - -printOp :: Parser' LetEnv ParsedUExtInstr -printOp = word' "PRINT" U.UPRINT <*> printComment - -testAssert :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv (U.TestAssert ParsedOp) -testAssert opsParser = do - n <- lexeme (toText <$> some alphaNumChar) - c <- printComment - o <- opsParser - return $ U.TestAssert n c o - -printComment :: Parser' LetEnv U.PrintComment -printComment = do - string "\"" - let validChar = toText <$> some (satisfy (\x -> x /= '%' && x /= '"')) - c <- many (Right <$> stackRef <|> Left <$> validChar) - symbol "\"" - return $ U.PrintComment c - -stackRef :: Parser' LetEnv U.StackRef -stackRef = do - string "%" - n <- brackets' L.decimal - return $ U.StackRef n - -stackType :: Parser' LetEnv U.StackTypePattern -stackType = do - symbol "'[" >> (emptyStk <|> stkCons <|> stkRest) - where - emptyStk = try $ symbol "]" $> U.StkEmpty - stkRest = try $ symbol "..." >> symbol "]" $> U.StkRest - stkCons = try $ do - t <- tyVar - s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk - return $ U.StkCons t s - -tyVar :: Parser' LetEnv U.TyVar -tyVar = (U.TyCon <$> type_) <|> (U.VarID <$> varID) diff --git a/src/Morley/Michelson/Parser/Helpers.hs b/src/Morley/Michelson/Parser/Helpers.hs --- a/src/Morley/Michelson/Parser/Helpers.hs +++ b/src/Morley/Michelson/Parser/Helpers.hs @@ -1,28 +1,20 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - module Morley.Michelson.Parser.Helpers - ( mkParser - , sepEndBy1 + ( sepEndBy1 , some' , sepBy1 , sepBy2 , parseDef - , positive , count ) where import Data.Default (Default(..)) import Data.List.NonEmpty qualified as NE import Text.Megaparsec qualified as P -import Text.Megaparsec.Char.Lexer (decimal) -import Morley.Michelson.Parser.Lexer (word') import Morley.Michelson.Parser.Types (Parser) -import Morley.Util.Positive import Morley.Util.SizedList.Types -- | Version of 'P.sepEndBy1' returning a 'NonEmpty' list @@ -45,20 +37,9 @@ es <- P.sepBy1 parser sep return $ e :| es --- | Make a parser from a string -mkParser :: (a -> Text) -> a -> Parser le a -mkParser f a = word' (f a) a - -- | Apply given parser and return default value if it fails. -parseDef :: Default a => Parser le a -> Parser le a +parseDef :: Default a => Parser a -> Parser a parseDef a = P.try a <|> pure def - --- | Parse a positive number. -positive :: Parser le Positive -positive = do - n :: Integer <- decimal - mkPositive n - & either (fail . toString) pure -- | Parse expression @n@ times, where @n@ is a type-level natural. -- Essentially, a type-safe version of 'P.count', but requires diff --git a/src/Morley/Michelson/Parser/Instr.hs b/src/Morley/Michelson/Parser/Instr.hs --- a/src/Morley/Michelson/Parser/Instr.hs +++ b/src/Morley/Michelson/Parser/Instr.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations -Wno-redundant-constraints #-} - -- | Parsing of Michelson instructions. module Morley.Michelson.Parser.Instr @@ -23,21 +20,20 @@ import Prelude hiding (EQ, GT, LT, many, note, some, try) -import Text.Megaparsec (choice, label, notFollowedBy, try) +import Text.Megaparsec (choice, label, many, notFollowedBy, try) import Text.Megaparsec.Char.Lexer qualified as L -import Morley.Michelson.Let (LetValue(..)) import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..)) import Morley.Michelson.Parser.Annotations import Morley.Michelson.Parser.Common import Morley.Michelson.Parser.Lexer import Morley.Michelson.Parser.Type -import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', letValues, withLetEnv) +import Morley.Michelson.Parser.Types (Parser) import Morley.Michelson.Parser.Value import Morley.Michelson.Untyped -- | Parser for primitive Michelson instruction (no macros and extensions). -primInstr :: Parser' le (Contract' ParsedOp) -> Parser' le ParsedOp -> Parser le ParsedInstr +primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr primInstr contractParser opParser = label "primitive instruction" $ choice [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp , ifNoneOp opParser, leftOp, rightOp, ifLeftOp opParser, nilOp @@ -55,11 +51,11 @@ , unpairOp , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp , openChestOp - , saplingEmptyStateOp, saplingVerifyUpdateOp + , saplingEmptyStateOp, saplingVerifyUpdateOp, minBlockTimeOp ] -- | Parse a sequence of instructions. -ops' :: Parser' le ParsedOp -> Parser le [ParsedOp] +ops' :: Parser ParsedOp -> Parser [ParsedOp] ops' opParser = (braces $ parseSeq) <|> (pure <$> opParser) where parseSeq = @@ -78,401 +74,399 @@ -- Control Structures -failWithOp :: Parser le ParsedInstr -failWithOp = word' "FAILWITH" FAILWITH +failWithOp :: Parser ParsedInstr +failWithOp = word "FAILWITH" FAILWITH -loopOp :: Parser' le ParsedOp -> Parser le ParsedInstr -loopOp opParser = word' "LOOP" LOOP <*> ops' opParser +loopOp :: Parser ParsedOp -> Parser ParsedInstr +loopOp opParser = word "LOOP" LOOP <*> ops' opParser -loopLOp :: Parser' le ParsedOp -> Parser le ParsedInstr -loopLOp opParser = word' "LOOP_LEFT" LOOP_LEFT <*> ops' opParser +loopLOp :: Parser ParsedOp -> Parser ParsedInstr +loopLOp opParser = word "LOOP_LEFT" LOOP_LEFT <*> ops' opParser -execOp :: Parser le ParsedInstr -execOp = word' "EXEC" EXEC <*> noteDef +execOp :: Parser ParsedInstr +execOp = word "EXEC" EXEC <*> noteDef -applyOp :: Parser le ParsedInstr -applyOp = word' "APPLY" APPLY <*> noteDef +applyOp :: Parser ParsedInstr +applyOp = word "APPLY" APPLY <*> noteDef -- Parses both `DIP` and `DIP n`. -dipOp :: Parser' le ParsedOp -> Parser le ParsedInstr +dipOp :: Parser ParsedOp -> Parser ParsedInstr dipOp opParser = parseWithOptionalParameter "DIP" DIPN DIP <*> ops' opParser -- Helper for instructions which have optional numeric non-negative parameter. -parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser le instr +parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser instr parseWithOptionalParameter instrName constructorWithParam constructorNoParam = - symbol1' instrName *> + symbol1 instrName *> (try (constructorWithParam <$> lexeme L.decimal) <|> pure constructorNoParam) -- Stack Operations -- Parses both `DROP` and `DROP n`. -dropOp :: Parser le ParsedInstr +dropOp :: Parser ParsedInstr dropOp = parseWithOptionalParameter "DROP" DROPN DROP -dupOp :: Parser le ParsedInstr +dupOp :: Parser ParsedInstr dupOp = do - symbol1' "DUP" + symbol1 "DUP" varAnn <- noteDef optional (lexeme L.decimal) <&> maybe (DUP varAnn) (DUPN varAnn) -swapOp :: Parser le ParsedInstr -swapOp = word' "SWAP" SWAP +swapOp :: Parser ParsedInstr +swapOp = word "SWAP" SWAP -digOp :: Parser le ParsedInstr -digOp = word' "DIG" DIG <*> lexeme L.decimal +digOp :: Parser ParsedInstr +digOp = word "DIG" DIG <*> lexeme L.decimal -dugOp :: Parser le ParsedInstr -dugOp = word' "DUG" DUG <*> lexeme L.decimal +dugOp :: Parser ParsedInstr +dugOp = word "DUG" DUG <*> lexeme L.decimal -pushOp :: forall le. Parser' le ParsedOp -> Parser le ParsedInstr +pushOp :: Parser ParsedOp -> Parser ParsedInstr pushOp opParser = do - symbol1' "PUSH" + symbol1 "PUSH" v <- noteDef - (try $ withLetEnv $ pushLet v) <|> (push' v) + push' v where - pushLet :: VarAnn -> Parser' LetEnv ParsedInstr - pushLet v = do - lvs <- asks letValues - lv <- mkLetVal lvs - return $ PUSH v (lvSig lv) (lvVal lv) - push' :: VarAnn -> Parser le ParsedInstr + push' :: VarAnn -> Parser ParsedInstr push' v = PUSH v <$> type_ <*> value' opParser -unitOp :: Parser le ParsedInstr -unitOp = do symbol1' "UNIT"; (t, v) <- notesTV; return $ UNIT t v +unitOp :: Parser ParsedInstr +unitOp = do symbol1 "UNIT"; (t, v) <- notesTV; return $ UNIT t v -lambdaOp :: Parser' le ParsedOp -> Parser le ParsedInstr +lambdaOp :: Parser ParsedOp -> Parser ParsedInstr lambdaOp opParser = - word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser + word "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser -neverOp :: Parser le ParsedInstr -neverOp = word' "NEVER" NEVER +neverOp :: Parser ParsedInstr +neverOp = word "NEVER" NEVER -- Generic comparison -cmpOp :: Parser le ParsedInstr +cmpOp :: Parser ParsedInstr cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp -eqOp :: Parser le ParsedInstr -eqOp = word' "EQ" EQ <*> noteDef +eqOp :: Parser ParsedInstr +eqOp = word "EQ" EQ <*> noteDef -neqOp :: Parser le ParsedInstr -neqOp = word' "NEQ" NEQ <*> noteDef +neqOp :: Parser ParsedInstr +neqOp = word "NEQ" NEQ <*> noteDef -ltOp :: Parser le ParsedInstr -ltOp = word' "LT" LT <*> noteDef +ltOp :: Parser ParsedInstr +ltOp = word "LT" LT <*> noteDef -gtOp :: Parser le ParsedInstr -gtOp = word' "GT" GT <*> noteDef +gtOp :: Parser ParsedInstr +gtOp = word "GT" GT <*> noteDef -leOp :: Parser le ParsedInstr -leOp = word' "LE" LE <*> noteDef +leOp :: Parser ParsedInstr +leOp = word "LE" LE <*> noteDef -geOp :: Parser le ParsedInstr -geOp = word' "GE" GE <*> noteDef +geOp :: Parser ParsedInstr +geOp = word "GE" GE <*> noteDef -- ad-hoc comparison -compareOp :: Parser le ParsedInstr -compareOp = word' "COMPARE" COMPARE <*> noteDef +compareOp :: Parser ParsedInstr +compareOp = word "COMPARE" COMPARE <*> noteDef -- Operations on booleans -orOp :: Parser le ParsedInstr -orOp = word' "OR" OR <*> noteDef +orOp :: Parser ParsedInstr +orOp = word "OR" OR <*> noteDef -andOp :: Parser le ParsedInstr -andOp = word' "AND" AND <*> noteDef +andOp :: Parser ParsedInstr +andOp = word "AND" AND <*> noteDef -xorOp :: Parser le ParsedInstr -xorOp = word' "XOR" XOR <*> noteDef +xorOp :: Parser ParsedInstr +xorOp = word "XOR" XOR <*> noteDef -notOp :: Parser le ParsedInstr -notOp = word' "NOT" NOT <*> noteDef +notOp :: Parser ParsedInstr +notOp = word "NOT" NOT <*> noteDef -- Operations on integers and natural numbers -addOp :: Parser le ParsedInstr -addOp = word' "ADD" ADD <*> noteDef +addOp :: Parser ParsedInstr +addOp = word "ADD" ADD <*> noteDef -saplingEmptyStateOp :: Parser le ParsedInstr -saplingEmptyStateOp = word' "SAPLING_EMPTY_STATE" SAPLING_EMPTY_STATE <*> noteDef <*> lexeme L.decimal +saplingEmptyStateOp :: Parser ParsedInstr +saplingEmptyStateOp = word "SAPLING_EMPTY_STATE" SAPLING_EMPTY_STATE <*> noteDef <*> lexeme L.decimal -saplingVerifyUpdateOp :: Parser le ParsedInstr -saplingVerifyUpdateOp = word' "SAPLING_VERIFY_UPDATE" SAPLING_VERIFY_UPDATE <*> noteDef +saplingVerifyUpdateOp :: Parser ParsedInstr +saplingVerifyUpdateOp = word "SAPLING_VERIFY_UPDATE" SAPLING_VERIFY_UPDATE <*> noteDef -subOp :: Parser le ParsedInstr -subOp = word' "SUB" SUB <*> noteDef +minBlockTimeOp :: Parser ParsedInstr +minBlockTimeOp = word "MIN_BLOCK_TIME" MIN_BLOCK_TIME <*> many anyNote -subMutezOp :: Parser le ParsedInstr -subMutezOp = word' "SUB_MUTEZ" SUB_MUTEZ <*> noteDef +subOp :: Parser ParsedInstr +subOp = word "SUB" SUB <*> noteDef -mulOp :: Parser le ParsedInstr -mulOp = word' "MUL" MUL <*> noteDef +subMutezOp :: Parser ParsedInstr +subMutezOp = word "SUB_MUTEZ" SUB_MUTEZ <*> noteDef -edivOp :: Parser le ParsedInstr -edivOp = word' "EDIV" EDIV <*> noteDef +mulOp :: Parser ParsedInstr +mulOp = word "MUL" MUL <*> noteDef -absOp :: Parser le ParsedInstr -absOp = word' "ABS" ABS <*> noteDef +edivOp :: Parser ParsedInstr +edivOp = word "EDIV" EDIV <*> noteDef -negOp :: Parser le ParsedInstr -negOp = word' "NEG" NEG <*> noteDef +absOp :: Parser ParsedInstr +absOp = word "ABS" ABS <*> noteDef +negOp :: Parser ParsedInstr +negOp = word "NEG" NEG <*> noteDef + -- Bitwise logical operators -lslOp :: Parser le ParsedInstr -lslOp = word' "LSL" LSL <*> noteDef +lslOp :: Parser ParsedInstr +lslOp = word "LSL" LSL <*> noteDef -lsrOp :: Parser le ParsedInstr -lsrOp = word' "LSR" LSR <*> noteDef +lsrOp :: Parser ParsedInstr +lsrOp = word "LSR" LSR <*> noteDef -- Operations on string's -concatOp :: Parser le ParsedInstr -concatOp = word' "CONCAT" CONCAT <*> noteDef +concatOp :: Parser ParsedInstr +concatOp = word "CONCAT" CONCAT <*> noteDef -sliceOp :: Parser le ParsedInstr -sliceOp = word' "SLICE" SLICE <*> noteDef +sliceOp :: Parser ParsedInstr +sliceOp = word "SLICE" SLICE <*> noteDef -- Operations on pairs -pairOp :: Parser le ParsedInstr +pairOp :: Parser ParsedInstr pairOp = do - symbol1' "PAIR" + symbol1 "PAIR" (t, v, (p, q)) <- notesTVF2Def -- Make sure this is a `PAIR` instruction, -- and not a `PAIR n` instruction. - notFollowedBy (lexeme L.decimal :: Parser le Word) + notFollowedBy (lexeme L.decimal :: Parser Word) return $ PAIR t v p q -unpairOp :: Parser le ParsedInstr +unpairOp :: Parser ParsedInstr unpairOp = do - symbol1' "UNPAIR" + symbol1 "UNPAIR" ((vn1, vn2), (fn1, fn2)) <- notesVVFF -- Make sure this is an `UNPAIR` instruction, -- and not an `UNPAIR n` instruction. - notFollowedBy (lexeme L.decimal :: Parser le Word) + notFollowedBy (lexeme L.decimal :: Parser Word) return $ UNPAIR vn1 vn2 fn1 fn2 -pairNOp :: Parser le ParsedInstr +pairNOp :: Parser ParsedInstr pairNOp = do - symbol1' "PAIR" + symbol1 "PAIR" PAIRN <$> noteDef <*> lexeme L.decimal -unpairNOp :: Parser le ParsedInstr +unpairNOp :: Parser ParsedInstr unpairNOp = - word' "UNPAIR" UNPAIRN <*> lexeme L.decimal + word "UNPAIR" UNPAIRN <*> lexeme L.decimal -carOp :: Parser le ParsedInstr -carOp = do symbol1' "CAR"; (v, f) <- notesVF; return $ CAR v f +carOp :: Parser ParsedInstr +carOp = do symbol1 "CAR"; (v, f) <- notesVF; return $ CAR v f -cdrOp :: Parser le ParsedInstr -cdrOp = do symbol1' "CDR"; (v, f) <- notesVF; return $ CDR v f +cdrOp :: Parser ParsedInstr +cdrOp = do symbol1 "CDR"; (v, f) <- notesVF; return $ CDR v f -- Operations on collections (sets, maps, lists) -emptySetOp :: Parser le ParsedInstr -emptySetOp = do symbol1' "EMPTY_SET"; (t, v) <- notesTV; +emptySetOp :: Parser ParsedInstr +emptySetOp = do symbol1 "EMPTY_SET"; (t, v) <- notesTV; EMPTY_SET t v <$> type_ -emptyMapOp :: Parser le ParsedInstr -emptyMapOp = do symbol1' "EMPTY_MAP"; (t, v) <- notesTV; a <- type_; +emptyMapOp :: Parser ParsedInstr +emptyMapOp = do symbol1 "EMPTY_MAP"; (t, v) <- notesTV; a <- type_; EMPTY_MAP t v a <$> type_ -emptyBigMapOp :: Parser le ParsedInstr -emptyBigMapOp = do symbol1' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- type_; +emptyBigMapOp :: Parser ParsedInstr +emptyBigMapOp = do symbol1 "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- type_; EMPTY_BIG_MAP t v a <$> type_ -memOp :: Parser le ParsedInstr -memOp = word' "MEM" MEM <*> noteDef +memOp :: Parser ParsedInstr +memOp = word "MEM" MEM <*> noteDef -updateOp :: Parser le ParsedInstr +updateOp :: Parser ParsedInstr updateOp = do - symbol1' "UPDATE" + symbol1 "UPDATE" varAnn <- noteDef ix <- optional (lexeme L.decimal) pure $ maybe (UPDATE varAnn) (UPDATEN varAnn) ix -getAndUpdateOp :: Parser le ParsedInstr -getAndUpdateOp = word' "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef +getAndUpdateOp :: Parser ParsedInstr +getAndUpdateOp = word "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef -iterOp :: Parser' le ParsedOp -> Parser le ParsedInstr -iterOp opParser = word' "ITER" ITER <*> ops' opParser +iterOp :: Parser ParsedOp -> Parser ParsedInstr +iterOp opParser = word "ITER" ITER <*> ops' opParser -sizeOp :: Parser le ParsedInstr -sizeOp = word' "SIZE" SIZE <*> noteDef +sizeOp :: Parser ParsedInstr +sizeOp = word "SIZE" SIZE <*> noteDef -mapOp :: Parser' le ParsedOp -> Parser le ParsedInstr -mapOp opParser = word' "MAP" MAP <*> noteDef <*> ops' opParser +mapOp :: Parser ParsedOp -> Parser ParsedInstr +mapOp opParser = word "MAP" MAP <*> noteDef <*> ops' opParser -getOp :: Parser le ParsedInstr +getOp :: Parser ParsedInstr getOp = do - symbol1' "GET" + symbol1 "GET" varAnn <- noteDef ix <- optional (lexeme L.decimal) pure $ maybe (GET varAnn) (GETN varAnn) ix -nilOp :: Parser le ParsedInstr -nilOp = do symbol1' "NIL"; (t, v) <- notesTV; NIL t v <$> type_ +nilOp :: Parser ParsedInstr +nilOp = do symbol1 "NIL"; (t, v) <- notesTV; NIL t v <$> type_ -consOp :: Parser le ParsedInstr -consOp = word' "CONS" CONS <*> noteDef +consOp :: Parser ParsedInstr +consOp = word "CONS" CONS <*> noteDef -ifConsOp :: Parser' le ParsedOp -> Parser le ParsedInstr -ifConsOp opParser = word' "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser +ifConsOp :: Parser ParsedOp -> Parser ParsedInstr +ifConsOp opParser = word "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser -- Operations on options -someOp :: Parser le ParsedInstr -someOp = do symbol1' "SOME"; (t, v) <- notesTV; return $ SOME t v +someOp :: Parser ParsedInstr +someOp = do symbol1 "SOME"; (t, v) <- notesTV; return $ SOME t v -noneOp :: Parser le ParsedInstr -noneOp = do symbol1' "NONE"; (t, v) <- notesTV; NONE t v <$> type_ +noneOp :: Parser ParsedInstr +noneOp = do symbol1 "NONE"; (t, v) <- notesTV; NONE t v <$> type_ -ifNoneOp :: Parser' le ParsedOp -> Parser le ParsedInstr -ifNoneOp opParser = word' "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser +ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr +ifNoneOp opParser = word "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser -- Operations on unions -leftOp :: Parser le ParsedInstr -leftOp = do symbol1' "LEFT"; (t, v, (f, f')) <- notesTVF2Def; +leftOp :: Parser ParsedInstr +leftOp = do symbol1 "LEFT"; (t, v, (f, f')) <- notesTVF2Def; LEFT t v f f' <$> type_ -rightOp :: Parser le ParsedInstr -rightOp = do symbol1' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def; +rightOp :: Parser ParsedInstr +rightOp = do symbol1 "RIGHT"; (t, v, (f, f')) <- notesTVF2Def; RIGHT t v f f' <$> type_ -ifLeftOp :: Parser' le ParsedOp -> Parser le ParsedInstr -ifLeftOp opParser = word' "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser +ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr +ifLeftOp opParser = word "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser -- Operations on contracts -createContractOp :: Parser le (Contract' ParsedOp) -> Parser le ParsedInstr +createContractOp :: Parser (Contract' ParsedOp) -> Parser ParsedInstr createContractOp contractParser = - word' "CREATE_CONTRACT" CREATE_CONTRACT + word "CREATE_CONTRACT" CREATE_CONTRACT <*> noteDef <*> noteDef <*> braces contractParser -transferTokensOp :: Parser le ParsedInstr -transferTokensOp = word' "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef +transferTokensOp :: Parser ParsedInstr +transferTokensOp = word "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef -setDelegateOp :: Parser le ParsedInstr -setDelegateOp = word' "SET_DELEGATE" SET_DELEGATE <*> noteDef +setDelegateOp :: Parser ParsedInstr +setDelegateOp = word "SET_DELEGATE" SET_DELEGATE <*> noteDef -balanceOp :: Parser le ParsedInstr -balanceOp = word' "BALANCE" BALANCE <*> noteDef +balanceOp :: Parser ParsedInstr +balanceOp = word "BALANCE" BALANCE <*> noteDef -contractOp :: Parser le ParsedInstr -contractOp = word' "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_ +contractOp :: Parser ParsedInstr +contractOp = word "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_ -sourceOp :: Parser le ParsedInstr -sourceOp = word' "SOURCE" SOURCE <*> noteDef +sourceOp :: Parser ParsedInstr +sourceOp = word "SOURCE" SOURCE <*> noteDef -senderOp :: Parser le ParsedInstr -senderOp = word' "SENDER" SENDER <*> noteDef +senderOp :: Parser ParsedInstr +senderOp = word "SENDER" SENDER <*> noteDef -amountOp :: Parser le ParsedInstr -amountOp = word' "AMOUNT" AMOUNT <*> noteDef +amountOp :: Parser ParsedInstr +amountOp = word "AMOUNT" AMOUNT <*> noteDef -votingPowerOp :: Parser le ParsedInstr -votingPowerOp = word' "VOTING_POWER" VOTING_POWER <*> noteDef +votingPowerOp :: Parser ParsedInstr +votingPowerOp = word "VOTING_POWER" VOTING_POWER <*> noteDef -totalVotingPowerOp :: Parser le ParsedInstr -totalVotingPowerOp = word' "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef +totalVotingPowerOp :: Parser ParsedInstr +totalVotingPowerOp = word "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef -implicitAccountOp :: Parser le ParsedInstr -implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef +implicitAccountOp :: Parser ParsedInstr +implicitAccountOp = word "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef -viewOp :: Parser le ParsedInstr +viewOp :: Parser ParsedInstr viewOp = -- @VIEW_@ A1 macro should not be parsed by this - word' "VIEW" VIEW <*> noteDef <*> viewName_ <*> type_ + word "VIEW" VIEW <*> noteDef <*> viewName_ <*> type_ -selfOp :: Parser le ParsedInstr -selfOp = word' "SELF" SELF <*> noteDef <*> noteDef +selfOp :: Parser ParsedInstr +selfOp = word "SELF" SELF <*> noteDef <*> noteDef -addressOp :: Parser le ParsedInstr -addressOp = word' "ADDRESS" ADDRESS <*> noteDef +addressOp :: Parser ParsedInstr +addressOp = word "ADDRESS" ADDRESS <*> noteDef -selfAddressOp :: Parser le ParsedInstr -selfAddressOp = word' "SELF_ADDRESS" SELF_ADDRESS <*> noteDef +selfAddressOp :: Parser ParsedInstr +selfAddressOp = word "SELF_ADDRESS" SELF_ADDRESS <*> noteDef -- Special Operations -nowOp :: Parser le ParsedInstr -nowOp = word' "NOW" NOW <*> noteDef +nowOp :: Parser ParsedInstr +nowOp = word "NOW" NOW <*> noteDef -levelOp :: Parser le ParsedInstr -levelOp = word' "LEVEL" LEVEL <*> noteDef +levelOp :: Parser ParsedInstr +levelOp = word "LEVEL" LEVEL <*> noteDef -chainIdOp :: Parser le ParsedInstr -chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef +chainIdOp :: Parser ParsedInstr +chainIdOp = word "CHAIN_ID" CHAIN_ID <*> noteDef -- Operations on bytes -packOp :: Parser le ParsedInstr -packOp = word' "PACK" PACK <*> noteDef +packOp :: Parser ParsedInstr +packOp = word "PACK" PACK <*> noteDef -unpackOp :: Parser le ParsedInstr -unpackOp = do symbol1' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_ +unpackOp :: Parser ParsedInstr +unpackOp = do symbol1 "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_ -- Cryptographic Primitives -checkSigOp :: Parser le ParsedInstr -checkSigOp = word' "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef +checkSigOp :: Parser ParsedInstr +checkSigOp = word "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef -blake2BOp :: Parser le ParsedInstr -blake2BOp = word' "BLAKE2B" BLAKE2B <*> noteDef +blake2BOp :: Parser ParsedInstr +blake2BOp = word "BLAKE2B" BLAKE2B <*> noteDef -sha256Op :: Parser le ParsedInstr -sha256Op = word' "SHA256" SHA256 <*> noteDef +sha256Op :: Parser ParsedInstr +sha256Op = word "SHA256" SHA256 <*> noteDef -sha512Op :: Parser le ParsedInstr -sha512Op = word' "SHA512" SHA512 <*> noteDef +sha512Op :: Parser ParsedInstr +sha512Op = word "SHA512" SHA512 <*> noteDef -sha3Op :: Parser le ParsedInstr -sha3Op = word' "SHA3" SHA3 <*> noteDef +sha3Op :: Parser ParsedInstr +sha3Op = word "SHA3" SHA3 <*> noteDef -keccakOp :: Parser le ParsedInstr -keccakOp = word' "KECCAK" KECCAK <*> noteDef +keccakOp :: Parser ParsedInstr +keccakOp = word "KECCAK" KECCAK <*> noteDef -hashKeyOp :: Parser le ParsedInstr -hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef +hashKeyOp :: Parser ParsedInstr +hashKeyOp = word "HASH_KEY" HASH_KEY <*> noteDef -pairingCheckOp :: Parser le ParsedInstr -pairingCheckOp = word' "PAIRING_CHECK" PAIRING_CHECK <*> noteDef +pairingCheckOp :: Parser ParsedInstr +pairingCheckOp = word "PAIRING_CHECK" PAIRING_CHECK <*> noteDef -- Type operations -castOp :: Parser le ParsedInstr -castOp = word' "CAST" CAST <*> noteDef <*> type_ +castOp :: Parser ParsedInstr +castOp = word "CAST" CAST <*> noteDef <*> type_ -renameOp :: Parser le ParsedInstr -renameOp = word' "RENAME" RENAME <*> noteDef +renameOp :: Parser ParsedInstr +renameOp = word "RENAME" RENAME <*> noteDef -isNatOp :: Parser le ParsedInstr -isNatOp = word' "ISNAT" ISNAT <*> noteDef +isNatOp :: Parser ParsedInstr +isNatOp = word "ISNAT" ISNAT <*> noteDef -intOp :: Parser le ParsedInstr -intOp = word' "INT" INT <*> noteDef +intOp :: Parser ParsedInstr +intOp = word "INT" INT <*> noteDef -- Ticket Operations -ticketOp :: Parser le ParsedInstr -ticketOp = word' "TICKET" TICKET <*> noteDef +ticketOp :: Parser ParsedInstr +ticketOp = word "TICKET" TICKET <*> noteDef -readTicketOp :: Parser le ParsedInstr -readTicketOp = word' "READ_TICKET" READ_TICKET <*> noteDef +readTicketOp :: Parser ParsedInstr +readTicketOp = word "READ_TICKET" READ_TICKET <*> noteDef -splitTicketOp :: Parser le ParsedInstr -splitTicketOp = word' "SPLIT_TICKET" SPLIT_TICKET <*> noteDef +splitTicketOp :: Parser ParsedInstr +splitTicketOp = word "SPLIT_TICKET" SPLIT_TICKET <*> noteDef -joinTicketsOp :: Parser le ParsedInstr -joinTicketsOp = word' "JOIN_TICKETS" JOIN_TICKETS <*> noteDef +joinTicketsOp :: Parser ParsedInstr +joinTicketsOp = word "JOIN_TICKETS" JOIN_TICKETS <*> noteDef -openChestOp :: Parser le ParsedInstr -openChestOp = word' "OPEN_CHEST" OPEN_CHEST <*> noteDef +openChestOp :: Parser ParsedInstr +openChestOp = word "OPEN_CHEST" OPEN_CHEST <*> noteDef diff --git a/src/Morley/Michelson/Parser/Let.hs b/src/Morley/Michelson/Parser/Let.hs deleted file mode 100644 --- a/src/Morley/Michelson/Parser/Let.hs +++ /dev/null @@ -1,127 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | Parsing of let blocks - -module Morley.Michelson.Parser.Let - ( letBlock - , mkLetMac - -- * For tests - , letInner - , letType - ) where - -import Prelude hiding (try) - -import Data.Char qualified as Char -import Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Type.Equality ((:~:)(Refl)) - -import Text.Megaparsec (choice, satisfy, try) -import Text.Megaparsec.Char (lowerChar, upperChar) - -import Morley.Michelson.Let (LetType(..), LetValue(..)) -import Morley.Michelson.Macro (LetMacro(..), ParsedOp(..)) -import Morley.Michelson.Parser.Ext -import Morley.Michelson.Parser.Helpers -import Morley.Michelson.Parser.Instr -import Morley.Michelson.Parser.Lexer -import Morley.Michelson.Parser.Type -import Morley.Michelson.Parser.Types (LetEnv(..), Parser, Parser', assertLetEnv, noLetEnv) -import Morley.Michelson.Parser.Value -import Morley.Michelson.Untyped (StackFn(..), Ty(..), mkAnnotation, noAnn) - --- | Element of a let block -data Let = LetM LetMacro | LetV LetValue | LetT LetType - --- | let block parser -letBlock :: forall le. Parser' le ParsedOp -> Parser le le -letBlock opParser = do - symbol "let" - symbol "{" - Refl <- assertLetEnv - ls <- local (const noLetEnv) (letInner opParser) - symbol "}" - semicolon - return ls - --- | Incrementally build the let environment -letInner :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetEnv -letInner opParser = do - env <- ask - l <- lets opParser - semicolon - local (addLet l) (letInner opParser) <|> return (addLet l env) - --- | Add a Let to the environment in the correct place -addLet :: Let -> LetEnv -> LetEnv -addLet l (LetEnv lms lvs lts) = case l of - LetM lm -> LetEnv (Map.insert (lmName lm) lm lms) lvs lts - LetV lv -> LetEnv lms (Map.insert (lvName lv) lv lvs) lts - LetT lt -> LetEnv lms lvs (Map.insert (ltName lt) lt lts) - -lets :: Parser' LetEnv ParsedOp -> Parser' LetEnv Let -lets opParser = choice - [ (LetM <$> letMacro opParser) - , (LetV <$> letValue opParser) - , (LetT <$> letType) - ] - --- | Build a let name parser from a leading character parser -letName :: Parser' LetEnv Char -> Parser' LetEnv Text -letName p = lexeme $ do - v <- p - let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_') - vs <- many (satisfy validChar) - return $ toText (v:vs) - -letMacro :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetMacro -letMacro opParser = lexeme $ do - n <- try $ do - n <- letName lowerChar - symbol "::" - return n - s <- stackFn - symbol "=" - o <- ops' opParser - return $ LetMacro n s o - -letType :: Parser' LetEnv LetType -letType = lexeme $ do - n <- try $ do - symbol "type" - n <- letName upperChar <|> letName lowerChar - symbol "=" - return n - t@(Ty t' a) <- type_ - if a == noAnn - then case mkAnnotation n of - Right an -> return $ LetType n (Ty t' an) - Left err -> fail $ toString err - else return $ LetType n t - -letValue :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetValue -letValue opParser = lexeme $ do - n <- try $ do - n <- letName upperChar - symbol "::" - return n - t <- type_ - symbol "=" - v <- value' opParser - return $ LetValue n t v - -mkLetMac :: Map Text LetMacro -> Parser' LetEnv LetMacro -mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms) - -stackFn :: Parser' LetEnv StackFn -stackFn = do - vs <- (optional (symbol "forall" >> some varID <* symbol ".")) - a <- stackType - symbol "->" - b <- stackType - return $ StackFn (Set.fromList <$> vs) a b diff --git a/src/Morley/Michelson/Parser/Lexer.hs b/src/Morley/Michelson/Parser/Lexer.hs --- a/src/Morley/Michelson/Parser/Lexer.hs +++ b/src/Morley/Michelson/Parser/Lexer.hs @@ -1,52 +1,41 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - module Morley.Michelson.Parser.Lexer ( lexeme , mSpace , spaces , symbol - , symbol' , symbol1 - , symbol1' , word - , word' - , string' , parens , braces , brackets , brackets' , semicolon , comma - , varID ) where import Prelude hiding (try) -import Data.Char (isDigit, isLower, toLower) -import Data.Text qualified as T -import Text.Megaparsec (Tokens, between, choice, eof, hidden, lookAhead, satisfy, try) -import Text.Megaparsec.Char (lowerChar, space, space1, string) +import Text.Megaparsec (Tokens, between, choice, eof, hidden, lookAhead, try) +import Text.Megaparsec.Char (space, space1, string) import Text.Megaparsec.Char.Lexer qualified as L -import Morley.Michelson.Parser.Types (Parser, Parser') -import Morley.Michelson.Untyped qualified as U +import Morley.Michelson.Parser.Types (Parser) -- Lexing -lexeme :: Parser le a -> Parser le a +lexeme :: Parser a -> Parser a lexeme = L.lexeme spaces -mSpace :: Parser le () +mSpace :: Parser () mSpace = L.space space1 (L.skipLineComment "#" >> optionalSemicolon) (L.skipBlockComment "/*" "*/" >> optionalSemicolon) where optionalSemicolon = space >> void (optional semicolon) -spaces :: Parser le () +spaces :: Parser () spaces = (mandatorySpaceOrComment >> mSpace) <|> hasFollowingDelimiter ["}", "{", "]", ")", "|", ",", ";", ":", "."] @@ -55,50 +44,29 @@ mandatorySpaceOrComment = hidden (space1 <|> L.skipBlockComment "/*" "*/") hasFollowingDelimiter = hidden . choice . map (void . lookAhead . string) -symbol :: Tokens Text -> Parser le () +symbol :: Tokens Text -> Parser () symbol = void . L.symbol mSpace -symbol' :: Text -> Parser le () -symbol' str = symbol str <|> symbol (T.map toLower str) - -symbol1 :: Tokens Text -> Parser le () +symbol1 :: Tokens Text -> Parser () symbol1 = try . void . L.symbol spaces -symbol1' :: Text -> Parser le () -symbol1' str = symbol1 str <|> symbol1 (T.map toLower str) - -word :: Tokens Text -> a -> Parser le a +word :: Tokens Text -> a -> Parser a word str val = symbol1 str $> val -word' :: Tokens Text -> a -> Parser le a -word' str val = symbol1' str $> val - -string' :: Text -> Parser le Text -string' str = string str <|> string (T.map toLower str) - -parens :: Parser le a -> Parser le a +parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") -braces :: Parser le a -> Parser le a +braces :: Parser a -> Parser a braces = between (symbol "{") (symbol "}") -brackets :: Parser le a -> Parser le a +brackets :: Parser a -> Parser a brackets = between (symbol "[") (symbol "]") -brackets' :: Parser le a -> Parser le a +brackets' :: Parser a -> Parser a brackets' = between (string "[") (string "]") -semicolon :: Parser le () +semicolon :: Parser () semicolon = symbol ";" -comma :: Parser le () +comma :: Parser () comma = symbol "," - -varID :: Parser le U.Var -varID = lexeme $ do - v <- lowerChar - vs <- many lowerAlphaNumChar - return $ U.Var (toText (v:vs)) - where - lowerAlphaNumChar :: Parser' le Char - lowerAlphaNumChar = satisfy (\x -> isLower x || isDigit x) diff --git a/src/Morley/Michelson/Parser/Macro.hs b/src/Morley/Michelson/Parser/Macro.hs --- a/src/Morley/Michelson/Parser/Macro.hs +++ b/src/Morley/Michelson/Parser/Macro.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Parsing of built-in Michelson macros. module Morley.Michelson.Parser.Macro @@ -20,7 +17,8 @@ import Prelude hiding (note, try) -import Text.Megaparsec (customFailure, label, notFollowedBy, skipMany, try) +import Text.Megaparsec (label, notFollowedBy, skipMany, try) +import Text.Megaparsec.Char (string) import Text.Megaparsec.Char.Lexer (decimal) import Unsafe qualified (fromIntegral) @@ -28,145 +26,101 @@ (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..)) import Morley.Michelson.Macro qualified as Macro import Morley.Michelson.Parser.Annotations -import Morley.Michelson.Parser.Error -import Morley.Michelson.Parser.Helpers import Morley.Michelson.Parser.Instr import Morley.Michelson.Parser.Lexer -import Morley.Michelson.Parser.Type -import Morley.Michelson.Parser.Types (Parser, Parser', assertLetEnv) -import Morley.Michelson.Untyped (T(..), Ty(..), noAnn) -import Morley.Util.Positive +import Morley.Michelson.Parser.Types (Parser) +import Morley.Michelson.Untyped (noAnn) -macro :: Parser' le ParsedOp -> Parser le Macro +macro :: Parser ParsedOp -> Parser Macro macro opParser = label "macro" $ setCadrMac - <|> (word' "CASE" CASE <* assertLetEnv) <*> someNE ops - <|> (symbol1' "TAG" <* assertLetEnv) *> tagMac - <|> (symbol1' "ACCESS" <* assertLetEnv) *> accessMac - <|> (symbol1' "SET" <* assertLetEnv) *> setMac - <|> (word' "CONSTRUCT" CONSTRUCT <* assertLetEnv) <*> someNE ops - <|> (word' "VIEW_" VIEW_ <* assertLetEnv) <*> ops - <|> (word' "VOID" VOID <* assertLetEnv) <*> ops - <|> (string' "CMP" >> return CMP <*> cmpOp <*> noteDef) - <|> word' "IF_SOME" IF_SOME <*> ops <*> ops - <|> word' "IF_RIGHT" IF_RIGHT <*> ops <*> ops - <|> word' "FAIL" FAIL - <|> (string' "ASSERT_CMP" >> return ASSERT_CMP <*> cmpOp) - <|> word' "ASSERT_NONE" ASSERT_NONE - <|> word' "ASSERT_SOME" ASSERT_SOME - <|> word' "ASSERT_LEFT" ASSERT_LEFT - <|> word' "ASSERT_RIGHT" ASSERT_RIGHT - <|> (string' "ASSERT_" >> return ASSERTX <*> cmpOp) - <|> word' "ASSERT" ASSERT - <|> do string' "DI"; n <- num "I"; symbol1' "P"; DIIP (n + 1) <$> ops + <|> (string "CMP" >> return CMP <*> cmpOp <*> noteDef) + <|> word "IF_SOME" IF_SOME <*> ops <*> ops + <|> word "IF_RIGHT" IF_RIGHT <*> ops <*> ops + <|> word "FAIL" FAIL + <|> (string "ASSERT_CMP" >> return ASSERT_CMP <*> cmpOp) + <|> word "ASSERT_NONE" ASSERT_NONE + <|> word "ASSERT_SOME" ASSERT_SOME + <|> word "ASSERT_LEFT" ASSERT_LEFT + <|> word "ASSERT_RIGHT" ASSERT_RIGHT + <|> (string "ASSERT_" >> return ASSERTX <*> cmpOp) + <|> word "ASSERT" ASSERT + <|> do string "DI"; n <- num "I"; symbol1 "P"; DIIP (n + 1) <$> ops <|> unpairMac where ops = ops' opParser - num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str) + num str = Unsafe.fromIntegral @Int @Word . length <$> some (string str) -duupMac :: Parser le Macro -duupMac = do string' "DU"; n <- num "U"; symbol1' "P"; DUUP (n + 1) <$> noteDef +duupMac :: Parser Macro +duupMac = do string "DU"; n <- num "U"; symbol1 "P"; DUUP (n + 1) <$> noteDef where - num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str) + num str = Unsafe.fromIntegral @Int @Word . length <$> some (string str) -pairMacInner :: Parser le PairStruct +pairMacInner :: Parser PairStruct pairMacInner = do - string' "P" - l <- (string' "A" $> F noAnn) <|> pairMacInner - r <- (string' "I" $> F noAnn) <|> pairMacInner + string "P" + l <- (string "A" $> F noAnn) <|> pairMacInner + r <- (string "I" $> F noAnn) <|> pairMacInner return $ P l r -pairMac :: Parser le Macro +pairMac :: Parser Macro pairMac = do a <- pairMacInner - symbol1' "R" + symbol1 "R" (tn, vn, fns) <- permute3Def noteDef note (some note) let ps = Macro.mapPairLeaves fns a return $ PAPAIR ps tn vn -unpairMacInner :: Parser le UnpairStruct +unpairMacInner :: Parser UnpairStruct unpairMacInner = do - string' "P" - l <- (string' "A" $> UF) <|> unpairMacInner - r <- (string' "I" $> UF) <|> unpairMacInner + string "P" + l <- (string "A" $> UF) <|> unpairMacInner + r <- (string "I" $> UF) <|> unpairMacInner return $ UP l r -unpairMac :: Parser le Macro +unpairMac :: Parser Macro unpairMac = do - string' "UN" + string "UN" a <- unpairMacInner - symbol1' "R" + symbol1 "R" skipMany $ (void noteF) <|> (void noteV) return $ UNPAPAIR a -cadrMac :: Parser le Macro +cadrMac :: Parser Macro cadrMac = lexeme $ do - string' "C" - a <- some $ try $ cadrInner <* notFollowedBy (string' "R") + string "C" + a <- some $ try $ cadrInner <* notFollowedBy (string "R") b <- cadrInner - symbol1' "R" + symbol1 "R" (vn, fn) <- notesVF return $ CADR (a ++ pure b) vn fn -cadrInner :: Parser le CadrStruct -cadrInner = (string' "A" $> A) <|> (string' "D" $> D) +cadrInner :: Parser CadrStruct +cadrInner = (string "A" $> A) <|> (string "D" $> D) -carnMac :: Parser le Macro -carnMac = symbol1' "CAR" *> (CARN <$> noteDef <*> lexeme decimal) +carnMac :: Parser Macro +carnMac = symbol1 "CAR" *> (CARN <$> noteDef <*> lexeme decimal) -cdrnMac :: Parser le Macro -cdrnMac = symbol1' "CDR" *> (CDRN <$> noteDef <*> lexeme decimal) +cdrnMac :: Parser Macro +cdrnMac = symbol1 "CDR" *> (CDRN <$> noteDef <*> lexeme decimal) {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} -setCadrMac :: Parser le Macro +setCadrMac :: Parser Macro setCadrMac = do - string' "SET_C" + string "SET_C" a <- some cadrInner - symbol1' "R" + symbol1 "R" (v, f) <- notesVF return $ SET_CADR a v f -mapCadrMac :: Parser le ParsedOp -> Parser le Macro +mapCadrMac :: Parser ParsedOp -> Parser Macro mapCadrMac opParser = do - string' "MAP_C" + string "MAP_C" a <- some cadrInner - symbol1' "R" + symbol1 "R" (v, f) <- notesVF MAP_CADR a v f <$> ops' opParser -ifCmpMac :: Parser le ParsedOp -> Parser le Macro -ifCmpMac opParser = string' "IFCMP" >> return +ifCmpMac :: Parser ParsedOp -> Parser Macro +ifCmpMac opParser = string "IFCMP" >> return IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser - -tagMac :: Parser le Macro -tagMac = do - idx <- decimal - spaces - ty <- type_ - let utys = unrollUnion ty [] - when (Unsafe.fromIntegral @Natural @Int idx >= length utys) $ - customFailure $ WrongTagArgs idx (lengthNE utys) - return $ TAG idx utys - where - unrollUnion ty = - case ty of - Ty (TOr _ _ l r) _ -> unrollUnion l . toList . unrollUnion r - _ -> (ty :|) - -accessMac :: Parser le Macro -accessMac = do - idx <- decimal - spaces - size <- positive - when (idx >= unPositive size) $ - customFailure $ WrongAccessArgs idx size - return $ ACCESS idx size - -setMac :: Parser le Macro -setMac = do - idx <- decimal - spaces - size <- positive - when (idx >= unPositive size) $ - customFailure $ WrongSetArgs idx size - return $ SET idx size diff --git a/src/Morley/Michelson/Parser/Type.hs b/src/Morley/Michelson/Parser/Type.hs --- a/src/Morley/Michelson/Parser/Type.hs +++ b/src/Morley/Michelson/Parser/Type.hs @@ -1,12 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - -- | Parsing of Michelson types. module Morley.Michelson.Parser.Type @@ -16,89 +10,40 @@ import Prelude hiding (note, some, try) -import Data.Default (Default, def) -import Data.Map qualified as Map -import Data.Type.Equality ((:~:)(Refl)) +import Data.Default (Default) import Fmt (pretty) -import Text.Megaparsec (choice, customFailure, label, sepBy) +import Text.Megaparsec (choice, label) import Text.Megaparsec.Char.Lexer qualified as L -import Morley.Michelson.Let (LetType(..)) import Morley.Michelson.Parser.Annotations -import Morley.Michelson.Parser.Error -import Morley.Michelson.Parser.Helpers import Morley.Michelson.Parser.Lexer -import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', assertLetEnv, isLetEnv, letTypes) +import Morley.Michelson.Parser.Types (Parser) import Morley.Michelson.Untyped -import Morley.Util.Generic -- | This parses arbitrary type expressions. -- --- Note that this includes parenthesized ones for efficiency, see 't_operator'. +-- Note that this includes parenthesized ones. -- That is to say, @int@, @(int)@, @((int))@, etc will match with this parser and produce @TInt@. -type_ :: Parser le Ty +type_ :: Parser Ty type_ = snd <$> typeInner (pure noAnn) -field :: Parser le (FieldAnn, Ty) +field :: Parser (FieldAnn, Ty) field = typeInner note --- | 't_operator' parses tuples @(a, b, c)@, variants @(a | b | c)@, and also type expressions in --- parentheses @(a)@ and unit @()@. This is done this way for performance considerations. --- --- Consequently, 't_unit' doesn't bother with parsing @()@. -t_operator :: Parser' le FieldAnn -> Parser le (FieldAnn, Ty) -t_operator fp = do - whole <- parens do - optional do - ty <- field - rest <- optional do - isOr <- (symbol' "|" >> return True) - <|> (symbol' "," >> return False) - others <- field `sepBy` symbol' if isOr then "|" else "," - return (isOr, others) - return (ty, rest) - - (f, t) <- fieldType fp - case whole of - Just (ty, Just (isOr, tys)) -> do - assertLetEnv - let (f', Ty ty' _) = mkGenericTree (mergeTwo isOr) (ty :| tys) - f'' <- mergeAnnots f f' - return (f'', Ty ty' t) - Just (res, _) -> do - return res - Nothing -> do - assertLetEnv - return (f, Ty TUnit t) - where - mergeTwo isOr _ (l, a) (r, b) = - (noAnn, Ty ((if isOr then TOr l r else TPair l r noAnn noAnn) a b) noAnn) - - mergeAnnots l r - | l == def = return r - | r == def = return l - | otherwise = customFailure ExcessFieldAnnotation - typeInner - :: Parser le FieldAnn -> Parser le (FieldAnn, Ty) -typeInner fp = label "type" $ choice $ (\x -> x fp) <$> - [ t_operator - , t_int, t_nat, t_string, t_bytes, t_mutez, t_bool + :: Parser FieldAnn -> Parser (FieldAnn, Ty) +typeInner fp = label "type" $ choice $ (parens field :) $ (\x -> x fp) <$> + [ t_int, t_nat, t_string, t_bytes, t_mutez, t_bool , t_keyhash, t_timestamp, t_address , t_key, t_unit, t_never, t_signature, t_chain_id , t_bls12381fr, t_bls12381g1, t_bls12381g2 , t_option, t_list, t_set , t_operation, t_contract, t_ticket, t_pair, t_or - , t_lambda, t_map, t_big_map, t_view - , t_void, t_letType' + , t_lambda, t_map, t_big_map , t_chestKey, t_chest - , t_saplingState, t_saplingTransaction + , t_saplingState, t_saplingTransaction, t_saplingTransactionDeprecated + , t_txRollupL2Address ] - where - t_letType' :: forall le fp. Default fp => Parser' le fp -> Parser le (fp, Ty) - t_letType' = case isLetEnv @le of - Just Refl -> t_letType - Nothing -> const mzero ---------------------------------------------------------------------------- -- Non-comparable types @@ -108,107 +53,106 @@ mkType t (a, ta) = (a, Ty t ta) -t_int :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_int fp = word' "Int" (mkType TInt) <*> fieldType fp +t_int :: (Default a) => Parser a -> Parser (a, Ty) +t_int fp = word "int" (mkType TInt) <*> fieldType fp -t_nat :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_nat fp = word' "Nat" (mkType TNat) <*> fieldType fp +t_nat :: (Default a) => Parser a -> Parser (a, Ty) +t_nat fp = word "nat" (mkType TNat) <*> fieldType fp -t_string :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_string fp = word' "String" (mkType TString) <*> fieldType fp +t_string :: (Default a) => Parser a -> Parser (a, Ty) +t_string fp = word "string" (mkType TString) <*> fieldType fp -t_bytes :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_bytes fp = word' "Bytes" (mkType TBytes) <*> fieldType fp +t_bytes :: (Default a) => Parser a -> Parser (a, Ty) +t_bytes fp = word "bytes" (mkType TBytes) <*> fieldType fp -t_mutez :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_mutez fp = word' "Mutez" (mkType TMutez) <*> fieldType fp +t_mutez :: (Default a) => Parser a -> Parser (a, Ty) +t_mutez fp = word "mutez" (mkType TMutez) <*> fieldType fp -t_bool :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_bool fp = word' "Bool" (mkType TBool) <*> fieldType fp +t_bool :: (Default a) => Parser a -> Parser (a, Ty) +t_bool fp = word "bool" (mkType TBool) <*> fieldType fp -t_keyhash :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_keyhash fp = ((word' "KeyHash" (mkType TKeyHash)) <|> (word "key_hash" (mkType TKeyHash))) <*> fieldType fp +t_keyhash :: (Default a) => Parser a -> Parser (a, Ty) +t_keyhash fp = word "key_hash" (mkType TKeyHash) <*> fieldType fp -t_timestamp :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_timestamp fp = word' "Timestamp" (mkType TTimestamp) <*> fieldType fp +t_timestamp :: (Default a) => Parser a -> Parser (a, Ty) +t_timestamp fp = word "timestamp" (mkType TTimestamp) <*> fieldType fp -t_address :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_address fp = word' "Address" (mkType TAddress) <*> fieldType fp +t_address :: (Default a) => Parser a -> Parser (a, Ty) +t_address fp = word "address" (mkType TAddress) <*> fieldType fp -t_key :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_key fp = word' "Key" (mkType TKey) <*> fieldType fp +t_key :: (Default a) => Parser a -> Parser (a, Ty) +t_key fp = word "key" (mkType TKey) <*> fieldType fp -t_signature :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp +t_signature :: (Default a) => Parser a -> Parser (a, Ty) +t_signature fp = word "signature" (mkType TSignature) <*> fieldType fp -t_bls12381fr :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_bls12381fr :: (Default a) => Parser a -> Parser (a, Ty) t_bls12381fr fp = do - symbol1' "bls12_381_fr" <|> symbol1' "Bls12381Fr" + symbol1 "bls12_381_fr" mkType TBls12381Fr <$> fieldType fp -t_bls12381g1 :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_bls12381g1 :: (Default a) => Parser a -> Parser (a, Ty) t_bls12381g1 fp = do - symbol1' "bls12_381_g1" <|> symbol1' "Bls12381G1" + symbol1 "bls12_381_g1" mkType TBls12381G1 <$> fieldType fp -t_bls12381g2 :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_bls12381g2 :: (Default a) => Parser a -> Parser (a, Ty) t_bls12381g2 fp = do - symbol1' "bls12_381_g2" <|> symbol1' "Bls12381G2" + symbol1 "bls12_381_g2" mkType TBls12381G2 <$> fieldType fp -t_chestKey :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_chestKey :: (Default a) => Parser a -> Parser (a, Ty) t_chestKey fp = do - symbol' "ChestKey" <|> symbol' "chest_key" + symbol1 "chest_key" mkType TChestKey <$> fieldType fp -t_chest :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_chest fp = word' "Chest" (mkType TChest) <*> fieldType fp +t_chest :: (Default a) => Parser a -> Parser (a, Ty) +t_chest fp = word "chest" (mkType TChest) <*> fieldType fp -t_chain_id :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_chain_id :: (Default a) => Parser a -> Parser (a, Ty) t_chain_id fp = do - symbol1' "ChainId" <|> symbol1' "chain_id" + symbol1 "chain_id" mkType TChainId <$> fieldType fp -t_operation :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_operation fp = word' "Operation" (mkType TOperation) <*> fieldType fp +t_operation :: (Default a) => Parser a -> Parser (a, Ty) +t_operation fp = word "operation" (mkType TOperation) <*> fieldType fp -t_contract :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_contract :: (Default a) => Parser a -> Parser (a, Ty) t_contract fp = do - symbol1' "Contract" + symbol1 "contract" (f, t) <- fieldType fp a <- type_ return (f, Ty (TContract a) t) -t_ticket :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_ticket :: (Default a) => Parser a -> Parser (a, Ty) t_ticket fp = do - symbol1' "Ticket" + symbol1 "ticket" (f, t) <- fieldType fp a <- type_ return (f, Ty (TTicket a) t) --- | Parses a @unit@ type. Unit type admits two variants of syntax, @unit@ and @()@. This parser --- handles only the former, the latter is handled in 't_operator' -t_unit :: (Default a) => Parser' le a -> Parser le (a, Ty) +-- | Parses a @unit@ type. +t_unit :: (Default a) => Parser a -> Parser (a, Ty) t_unit fp = do - symbol1' "Unit" + symbol1 "unit" (f,t) <- fieldType fp return (f, Ty TUnit t) -t_never :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_never :: (Default a) => Parser a -> Parser (a, Ty) t_never fp = do - symbol1' "Never" <|> symbol1' "⊥" + symbol1 "never" <|> symbol1 "⊥" (f,t) <- fieldType fp return (f, Ty TNever t) -t_pair :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_pair :: (Default a) => Parser a -> Parser (a, Ty) t_pair fp = do - symbol1' "Pair" + symbol1 "pair" (fieldAnn, typeAnn) <- fieldType fp fields <- many field tPair <- go fields pure $ (fieldAnn, Ty tPair typeAnn) where - go :: [(FieldAnn, Ty)] -> Parser le T + go :: [(FieldAnn, Ty)] -> Parser T go = \case [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given." [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'." @@ -218,133 +162,86 @@ rightCombedT <- go fields pure $ TPair fieldAnnL noAnn noAnn noAnn typeL (Ty rightCombedT noAnn) -t_or :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_or :: (Default a) => Parser a -> Parser (a, Ty) t_or fp = do - symbol1' "Or" + symbol1 "or" (f, t) <- fieldType fp (l, a) <- field (r, b) <- field return (f, Ty (TOr l r a b) t) -t_option :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_option :: (Default a) => Parser a -> Parser (a, Ty) t_option fp = do - symbol1' "Option" + symbol1 "option" (f, t) <- fieldType fp a <- snd <$> typeInner (pure noAnn) return (f, Ty (TOption a) t) -t_saplingState :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_saplingState :: (Default a) => Parser a -> Parser (a, Ty) t_saplingState fp = do - symbol1' "Sapling_state" + symbol1 "sapling_state" (f,t) <- fieldType fp n <- lexeme L.decimal return (f, Ty (TSaplingState n) t) -t_saplingTransaction :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_saplingTransaction :: (Default a) => Parser a -> Parser (a, Ty) t_saplingTransaction fp = do - symbol1' "Sapling_transaction" + symbol1 "sapling_transaction" (f,t) <- fieldType fp n <- lexeme L.decimal return (f, Ty (TSaplingTransaction n) t) -t_lambda :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_lambda fp = core <|> slashLambda - where - core = do - symbol1' "Lambda" - (f, t) <- fieldType fp - a <- type_ - b <- type_ - return (f, Ty (TLambda a b) t) - slashLambda = do - symbol "\\" - (f, t) <- fieldType fp - a <- type_ - symbol "->" - assertLetEnv - b <- type_ - return (f, Ty (TLambda a b) t) +t_saplingTransactionDeprecated :: Parser a -> Parser (a, Ty) +t_saplingTransactionDeprecated _ = do + symbol1 "sapling_transaction_deprecated" + fail "Use of deprecated type: sapling_transaction_deprecated" +t_lambda :: (Default a) => Parser a -> Parser (a, Ty) +t_lambda fp = do + symbol1 "lambda" + (f, t) <- fieldType fp + a <- type_ + b <- type_ + return (f, Ty (TLambda a b) t) + -- Container types -t_list :: forall a le. (Default a) => Parser' le a -> Parser le (a, Ty) -t_list fp = core <|> bracketList - where - core = do - symbol1' "List" - (f, t) <- fieldType fp - a <- type_ - return (f, Ty (TList a) t) - bracketList :: Parser le (a, Ty) - bracketList = do - a <- brackets type_ - assertLetEnv - (f, t) <- fieldType fp - return (f, Ty (TList a) t) +t_list :: forall a. (Default a) => Parser a -> Parser (a, Ty) +t_list fp = do + symbol1 "list" + (f, t) <- fieldType fp + a <- type_ + return (f, Ty (TList a) t) -t_set :: forall a le. (Default a) => Parser' le a -> Parser le (a, Ty) -t_set fp = core <|> braceSet - where - core = do - symbol1' "Set" - (f, t) <- fieldType fp - a <- type_ - return (f, Ty (TSet a) t) - braceSet :: Parser le (a, Ty) - braceSet = do - a <- braces type_ - assertLetEnv - (f, t) <- fieldType fp - return (f, Ty (TSet a) t) +t_set :: forall a. (Default a) => Parser a -> Parser (a, Ty) +t_set fp = do + symbol1 "set" + (f, t) <- fieldType fp + a <- type_ + return (f, Ty (TSet a) t) t_map_like :: (Default a) - => Parser' le a -> Parser le (Ty, Ty, a, TypeAnn) + => Parser a -> Parser (Ty, Ty, a, TypeAnn) t_map_like fp = do (f, t) <- fieldType fp a <- type_ b <- type_ return (a, b, f, t) -t_map :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_map :: (Default a) => Parser a -> Parser (a, Ty) t_map fp = do - symbol1' "Map" + symbol1 "map" (a, b, f, t) <- t_map_like fp return (f, Ty (TMap a b) t) -t_big_map :: (Default a) => Parser' le a -> Parser le (a, Ty) +t_big_map :: (Default a) => Parser a -> Parser (a, Ty) t_big_map fp = do - symbol1' "BigMap" <|> symbol1 "big_map" + symbol1 "big_map" (a, b, f, t) <- t_map_like fp return (f, Ty (TBigMap a b) t) ----------------------------------------------------------------------------- --- Non-standard types (Morley extensions) ----------------------------------------------------------------------------- - -t_view :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_view fp = do - symbol' "View" - a <- type_ - r <- type_ - (f, t) <- fieldType fp - let c' = Ty (TContract r) noAnn - return (f, Ty (TPair noAnn noAnn noAnn noAnn a c') t) - -t_void :: (Default a) => Parser' le a -> Parser le (a, Ty) -t_void fp = do - symbol' "Void" - a <- type_ - b <- type_ - (f, t) <- fieldType fp - let c = Ty (TLambda b b) noAnn - return (f, Ty (TPair noAnn noAnn noAnn noAnn a c) t) - -t_letType :: (Default fp) => Parser' LetEnv fp -> Parser' LetEnv (fp, Ty) -t_letType fp = do - lts <- asks letTypes - lt <- ltSig <$> (mkLetType lts) - f <- parseDef fp - return (f, lt) - -mkLetType :: Map Text LetType -> Parser le LetType -mkLetType lts = choice $ mkParser ltName <$> (Map.elems lts) +t_txRollupL2Address :: Default a => Parser a -> Parser (a, Ty) +t_txRollupL2Address fp = do + symbol1 "tx_rollup_l2_address" + (f,t) <- fieldType fp + return (f, Ty TTxRollupL2Address t) diff --git a/src/Morley/Michelson/Parser/Types.hs b/src/Morley/Michelson/Parser/Types.hs --- a/src/Morley/Michelson/Parser/Types.hs +++ b/src/Morley/Michelson/Parser/Types.hs @@ -2,76 +2,25 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations -Wno-orphans #-} - -- | Core parser types module Morley.Michelson.Parser.Types ( Parser - , Parser' - , LetEnv (..) - , noLetEnv - , HasLetEnv(..) - , assertLetEnv - , withLetEnv - , MichelsonSource (.., MSStdin, MSCli) , codeSrc ) where -import Data.Default (Default(..)) -import Data.Map qualified as Map -import Data.Type.Equality ((:~:)(Refl)) import Fmt (Buildable(..)) import GHC.Stack (SrcLoc(..)) -import Text.Megaparsec (Parsec, customFailure) +import Text.Megaparsec (Parsec) -import Morley.Michelson.Let (LetType, LetValue) -import Morley.Michelson.Macro (LetMacro) import Morley.Michelson.Parser.Error -type Parser a r = HasLetEnv a => Parser' a r -type Parser' a = ReaderT a (Parsec CustomParserException Text) - -class HasLetEnv a where - isLetEnv :: Maybe (a :~: LetEnv) - -instance HasLetEnv LetEnv where - isLetEnv = Just Refl - -instance HasLetEnv () where - isLetEnv = Nothing - -assertLetEnv :: forall le. Parser le (le :~: LetEnv) -assertLetEnv = maybe (customFailure DeprecatedException) pure $ isLetEnv @le - -withLetEnv :: forall le a. Parser' LetEnv a -> Parser le a -withLetEnv p = case isLetEnv @le of - Just Refl -> p - Nothing -> mzero - -instance Default a => Default (Parser' le a) where - def = pure def +type Parser = Parsec CustomParserException Text data ParserOptions = ParserOptions { poMorleyExts :: Bool } deriving stock (Show, Eq) - --- | The environment containing lets from the let-block -data LetEnv = LetEnv - { letMacros :: Map Text LetMacro - , letValues :: Map Text LetValue - , letTypes :: Map Text LetType - } deriving stock (Show, Eq) - -{-# DEPRECATED LetEnv "Let macros are deprecated" #-} - -noLetEnv :: LetEnv -noLetEnv = LetEnv Map.empty Map.empty Map.empty - -instance Default LetEnv where - def = noLetEnv -- | Where a contract or value in Michelson comes from. data MichelsonSource diff --git a/src/Morley/Michelson/Parser/Value.hs b/src/Morley/Michelson/Parser/Value.hs --- a/src/Morley/Michelson/Parser/Value.hs +++ b/src/Morley/Michelson/Parser/Value.hs @@ -1,17 +1,10 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - -- | Parsing of untyped Michelson values. module Morley.Michelson.Parser.Value ( value' - , mkLetVal -- * For tests , stringLiteral @@ -22,83 +15,52 @@ import Prelude hiding (many, note, try) import Data.Char qualified as Char -import Data.Map qualified as Map import Text.Hex qualified as Hex import Text.Megaparsec (anySingle, choice, customFailure, label, manyTill, satisfy, takeWhileP, try) import Text.Megaparsec.Char (char, string) import Text.Megaparsec.Char.Lexer qualified as L -import Morley.Michelson.Let (LetValue(..)) import Morley.Michelson.Macro (ParsedOp, ParsedValue) import Morley.Michelson.Parser.Error import Morley.Michelson.Parser.Helpers import Morley.Michelson.Parser.Lexer -import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', isLetEnv, letValues, withLetEnv) +import Morley.Michelson.Parser.Types (Parser) import Morley.Michelson.Text (isMChar, mkMText) import Morley.Michelson.Untyped qualified as U -{- -Note [Exponential backtracking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider the following input string: - -@ -(Pair 1 (Pair 2 (Pair 3 (Pair 4 5)))) -@ - -until we've parsed it completely, we can't decide whether the first -opening parenthesis is starting a tuple, or a simple expression. -The same applies to all subsequent parentheses. At one point, our parser -first tried to parse the whole expression as a tuple, then backtracked, -then tried to parse the same expression as a value (which includes -a tuple). Hence it incurred the exponential backtracking. - -To avoid that, we first try to parse anything that starts with @(@, i.e. -a comma-separated tuple, or a plain value in parentheses. The choice -between the two is trivial: if there's one value it's just value, if -there are multiple, it's a tuple. - -If we don't find @(@ we then try to parse anything that /doesn't/ start -with a parenthesis, i.e. everything else. --} - -- | Parse untyped 'ParsedValue'. Take instruction parser as argument -- to avoid cyclic dependencies between modules, hence ' in its name. -value' :: Parser le ParsedOp -> Parser le ParsedValue +value' :: Parser ParsedOp -> Parser ParsedValue value' opParser = parensOrTuple opParser <|> valueInnerWithoutParens opParser -parensOrTuple :: forall le. Parser le ParsedOp -> Parser le ParsedValue -parensOrTuple opParser = parens $ - case isLetEnv @le of - Just{} -> foldr1 U.ValuePair <$> value' opParser `sepBy1` comma - Nothing -> value' opParser +parensOrTuple :: Parser ParsedOp -> Parser ParsedValue +parensOrTuple opParser = parens $ value' opParser -valueInnerWithoutParens :: Parser le ParsedOp -> Parser le ParsedValue +valueInnerWithoutParens :: Parser ParsedOp -> Parser ParsedValue valueInnerWithoutParens opParser = label "value" $ choice $ [ stringLiteral, bytesLiteral, intLiteral, unitValue , trueValue, falseValue, pairValueCore opParser, leftValue opParser , rightValue opParser, someValue opParser, noneValue, nilValue - , seqOrLambda opParser, mapValue opParser, withLetEnv dataLetValue + , seqOrLambda opParser, mapValue opParser ] -seqOrLambda :: Parser le ParsedOp -> Parser le ParsedValue +seqOrLambda :: Parser ParsedOp -> Parser ParsedValue seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser -stringLiteral :: forall le. Parser le ParsedValue +stringLiteral :: Parser ParsedValue stringLiteral = lexeme $ U.ValueString . unsafe . mkMText . toText <$> do _ <- try $ string "\"" manyTill validChar (string "\"") where - validChar :: Parser le Char + validChar :: Parser Char validChar = choice [ strEscape , satisfy (\x -> x /= '"' && isMChar x) , anySingle >>= stringLiteralFailure . InvalidChar ] - strEscape :: Parser le Char + strEscape :: Parser Char strEscape = try (char '\\') >> esc where esc = choice @@ -111,7 +73,7 @@ -- It is safe not to use `try` here because bytesLiteral is the only -- thing that starts from 0x (at least for now) -bytesLiteral :: Parser le (U.Value' op) +bytesLiteral :: Parser (U.Value' op) bytesLiteral = lexeme $ do string "0x" hexdigits <- takeWhileP Nothing Char.isHexDigit @@ -121,61 +83,53 @@ (return . U.ValueBytes . U.InternalByteString) mBytes -intLiteral :: Parser le (U.Value' op) +intLiteral :: Parser (U.Value' op) intLiteral = lexeme $ try $ U.ValueInt <$> L.signed pass L.decimal -unitValue :: Parser le ParsedValue +unitValue :: Parser ParsedValue unitValue = word "Unit" U.ValueUnit -trueValue :: Parser le ParsedValue +trueValue :: Parser ParsedValue trueValue = word "True" U.ValueTrue -falseValue :: Parser le ParsedValue +falseValue :: Parser ParsedValue falseValue = word "False" U.ValueFalse -pairValueCore :: Parser le ParsedOp -> Parser le ParsedValue +pairValueCore :: Parser ParsedOp -> Parser ParsedValue pairValueCore opParser = symbol1 "Pair" *> pairInner where pairInner = U.ValuePair <$> value' opParser <*> (foldr1 U.ValuePair <$> some' (value' opParser)) -leftValue :: Parser le ParsedOp -> Parser le ParsedValue +leftValue :: Parser ParsedOp -> Parser ParsedValue leftValue opParser = word "Left" U.ValueLeft <*> value' opParser -rightValue :: Parser le ParsedOp -> Parser le ParsedValue +rightValue :: Parser ParsedOp -> Parser ParsedValue rightValue opParser = word "Right" U.ValueRight <*> value' opParser -someValue :: Parser le ParsedOp -> Parser le ParsedValue +someValue :: Parser ParsedOp -> Parser ParsedValue someValue opParser = word "Some" U.ValueSome <*> value' opParser -noneValue :: Parser le ParsedValue +noneValue :: Parser ParsedValue noneValue = word "None" U.ValueNone -nilValue :: Parser le ParsedValue +nilValue :: Parser ParsedValue nilValue = U.ValueNil <$ (try $ braces pass) -lambdaValue :: forall le. Parser le ParsedOp -> Parser le ParsedValue +lambdaValue :: Parser ParsedOp -> Parser ParsedValue lambdaValue opParser = U.ValueLambda <$> ops1 where - ops1 :: Parser le (NonEmpty ParsedOp) + ops1 :: Parser (NonEmpty ParsedOp) ops1 = braces $ sepEndBy1 opParser semicolon -seqValue :: Parser le ParsedOp -> Parser le ParsedValue +seqValue :: Parser ParsedOp -> Parser ParsedValue seqValue opParser = U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon) -eltValue :: Parser le ParsedOp -> Parser le (U.Elt ParsedOp) +eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp) eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser -mapValue :: Parser le ParsedOp -> Parser le ParsedValue +mapValue :: Parser ParsedOp -> Parser ParsedValue mapValue opParser = U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon) - -dataLetValue :: Parser' LetEnv ParsedValue -dataLetValue = do - lvs <- asks letValues - lvVal <$> (mkLetVal lvs) - -mkLetVal :: Map Text LetValue -> Parser le LetValue -mkLetVal lvs = choice $ mkParser lvName <$> Map.elems lvs diff --git a/src/Morley/Michelson/Preprocess.hs b/src/Morley/Michelson/Preprocess.hs --- a/src/Morley/Michelson/Preprocess.hs +++ b/src/Morley/Michelson/Preprocess.hs @@ -29,7 +29,9 @@ v -> v -- | Similar to 'transformStrings' but for bytes. -transformBytes :: Bool -> (ByteString -> ByteString) -> Instr inp out -> Instr inp out +transformBytes + :: Bool -> (ByteString -> ByteString) -> Instr inp out + -> Instr inp out transformBytes goToValues f = transformConstants goToValues mapBytes where mapBytes :: Value t -> Value t @@ -44,9 +46,12 @@ -- ^ Should transform only atomic values, 'dfsMapValue' will be applied to it. -> Instr inp out -> Instr inp out -transformConstants dsGoToValues f = dfsModifyInstr def{ dsGoToValues } step +transformConstants dsGoToValues f = dfsModifyInstr settings step where + settings :: DfsSettings Identity + settings = def{ dsGoToValues } + step :: forall i o. Instr i o -> Instr i o step = \case - PUSH v -> PUSH (dfsMapValue f v) + AnnPUSH ann v -> AnnPUSH ann (dfsMapValue (settings{dsValueStep = pure . f}) v) i -> i diff --git a/src/Morley/Michelson/Runtime.hs b/src/Morley/Michelson/Runtime.hs --- a/src/Morley/Michelson/Runtime.hs +++ b/src/Morley/Michelson/Runtime.hs @@ -16,12 +16,6 @@ , readAndParseContract , prepareContract - -- * Deprecated - , parseContractExt - , parseExpandContractExt - , readAndParseContractExt - , prepareContractExt - -- * Re-exports , ContractState (..) , AddressState (..) @@ -74,6 +68,7 @@ RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret) import Morley.Michelson.Macro (ParsedOp, expandContract) import Morley.Michelson.Parser qualified as P +import Morley.Michelson.Runtime.Dummy import Morley.Michelson.Runtime.GState import Morley.Michelson.Runtime.TxData import Morley.Michelson.TypeCheck @@ -85,9 +80,10 @@ import Morley.Michelson.Untyped (Contract) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address(..), GlobalCounter(..), isKeyAddress) +import Morley.Tezos.Address.Alias (AddressOrAlias(..), Alias) import Morley.Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez, zeroMutez) -import Morley.Tezos.Crypto (KeyHash, parseKeyHash) +import Morley.Tezos.Crypto (KeyHash, parseHash) import Morley.Util.MismatchError import Morley.Util.Named @@ -140,6 +136,7 @@ data ExecutorEnv = ExecutorEnv { _eeNow :: Timestamp , _eeLevel :: Natural + , _eeMinBlockTime :: Natural } deriving stock (Show, Generic) @@ -174,15 +171,17 @@ | EEInterpreterFailed a InterpretError -- ^ Interpretation of Michelson contract failed. - | EEAlreadyOriginated a - ContractState - -- ^ A contract is already originated. + | EEUnknownAddressAlias Alias + -- ^ Given alias doesn't refer to any address. | EEUnknownSender a -- ^ Sender address is unknown. | EEUnknownManager a -- ^ Manager address is unknown. | EENotEnoughFunds a Mutez -- ^ Sender doesn't have enough funds. + | EEEmptyImplicitContract a + -- ^ Sender is an implicit address with the balance of 0. We mimic tezos-client in calling it + -- "Empty implicit contract". | EEZeroTransaction a -- ^ Sending 0tz towards an address. | EEFailedToApplyUpdates GStateUpdateError @@ -205,17 +204,18 @@ instance (Buildable a) => Buildable (ExecutorError' a) where build = \case + EEUnknownAddressAlias alias -> + "The alias " +| alias |+ " doesn't have any associated addresses" EEUnknownContract addr -> "The contract is not originated " +| addr |+ "" EEInterpreterFailed addr err -> "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ "" - EEAlreadyOriginated addr cs -> - "The following contract is already originated: " +| addr |+ - ", " +| cs |+ "" EEUnknownSender addr -> "The sender address is unknown " +| addr |+ "" EEUnknownManager addr -> "The manager address is unknown " +| addr |+ "" EENotEnoughFunds addr amount -> "The sender (" +| addr |+ ") doesn't have enough funds (has only " +| amount |+ ")" + EEEmptyImplicitContract addr -> + "Empty implicit contract (" +| addr |+ ")" EEZeroTransaction addr -> "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited" EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ "" @@ -251,47 +251,7 @@ :: P.MichelsonSource -> Text -> Either P.ParserException Contract parseExpandContract = fmap expandContract ... parseContract --- TODO [#712]: Remove this next major release --- | Parse a contract from 'Text' with Morley extensions. -parseContractExt - :: P.MichelsonSource -> Text -> Either P.ParserException (U.Contract' ParsedOp) -parseContractExt source = - first P.ParserException . parse P.programExt (pretty source) - --- TODO [#712]: Remove this next major release --- | Parse a contract from 'Text' and expand macros with Morley extensions. -parseExpandContractExt - :: P.MichelsonSource -> Text -> Either P.ParserException Contract -parseExpandContractExt = fmap expandContract ... parseContractExt - --- TODO [#712]: Remove this next major release -- | Read and parse a contract from give path or `stdin` (if the --- argument is 'Nothing') with Morley extensions. The contract is not expanded. -readAndParseContractExt :: Maybe FilePath -> IO (U.Contract' ParsedOp) -readAndParseContractExt mFilename = do - code <- readCode mFilename - either throwM pure $ parseContractExt (toSrc mFilename) code - where - readCode :: Maybe FilePath -> IO Text - readCode = maybe getContents Utf8.readFile - - toSrc :: Maybe FilePath -> P.MichelsonSource - toSrc = maybe P.MSUnspecified P.MSFile --- TODO [#712]: Remove this next major release --- | Read a contract using 'readAndParseContract', expand and --- flatten with Morley extensions. The contract is not type checked. -prepareContractExt :: Maybe FilePath -> IO Contract -prepareContractExt mFile = expandContract <$> readAndParseContractExt mFile - - -{-# DEPRECATED - parseContractExt, - parseExpandContractExt, - readAndParseContractExt, - prepareContractExt - "Morley extensions are deprecated" #-} - --- | Read and parse a contract from give path or `stdin` (if the -- argument is 'Nothing'). The contract is not expanded. readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp) readAndParseContract mFilename = do @@ -315,18 +275,19 @@ :: FilePath -> TypeCheckOptions -> Address + -> Maybe Alias -> Maybe KeyHash -> Mutez -> U.Value -> U.Contract -> "verbose" :! Bool -> IO Address -originateContract dbPath tcOpts originator delegate balance uStorage uContract verbose = do +originateContract dbPath tcOpts originator mbAlias delegate balance uStorage uContract verbose = do origination <- either throwM pure . typeCheckingWith tcOpts $ mkOrigination <$> typeCheckContractAndStorage uContract uStorage -- pass 100500 as maxSteps, because it doesn't matter for origination, -- as well as 'now' - fmap snd $ runExecutorMWithDB Nothing Nothing dbPath 100500 verbose (#dryRun :? Nothing) $ do + fmap snd $ runExecutorMWithDB Nothing Nothing Nothing dbPath 100500 verbose (#dryRun :? Nothing) $ do executeGlobalOrigination origination where mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation @@ -336,6 +297,7 @@ , ooStorage = storage , ooContract = contract , ooCounter = 0 + , ooAlias = mbAlias } -- | Run a contract. The contract is originated first (if it's not @@ -343,6 +305,7 @@ runContract :: Maybe Timestamp -> Maybe Natural + -> Maybe Natural -> Word64 -> Mutez -> FilePath @@ -353,11 +316,11 @@ -> "verbose" :! Bool -> "dryRun" :! Bool -> IO SomeStorage -runContract maybeNow maybeLevel maxSteps initBalance dbPath tcOpts uStorage uContract txData +runContract maybeNow maybeLevel maybeMinBlockTime maxSteps initBalance dbPath tcOpts uStorage uContract txData verbose (arg #dryRun -> dryRun) = do origination <- either throwM pure . typeCheckingWith tcOpts $ mkOrigination <$> typeCheckContractAndStorage uContract uStorage - (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath + (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do -- Here we are safe to bypass executeGlobalOperations for origination, -- since origination can't generate more operations. @@ -372,9 +335,10 @@ -- it may have different storage value which may be confusing). -- 2. If one uses this functionality twice with the same contract and -- other data, the contract will have the same address. + delegate :: KeyHash delegate = either (error . mappend "runContract can't parse delegate: " . pretty) id $ - parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47" + parseHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47" mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation { ooOriginator = genesisAddress , ooDelegate = Just delegate @@ -382,6 +346,7 @@ , ooStorage = storage , ooContract = contract , ooCounter = 0 + , ooAlias = Nothing } getContractStorage :: Address -> ExecutorM SomeStorage @@ -396,17 +361,19 @@ transfer :: Maybe Timestamp -> Maybe Natural + -> Maybe Natural -> Word64 -> FilePath -> TypeCheckOptions - -> Address + -> AddressOrAlias -> TxData -> "verbose" :! Bool -> "dryRun" :? Bool -> IO () -transfer maybeNow maybeLevel maxSteps dbPath tcOpts destination txData verbose dryRun = do - void $ runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose dryRun $ - executeGlobalOperations tcOpts [TransferOp $ TransferOperation destination txData 0] +transfer maybeNow maybeLevel maybeMinBlockTime maxSteps dbPath tcOpts destination txData verbose dryRun = do + void $ runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath (RemainingSteps maxSteps) verbose dryRun $ do + destAddr <- resolveAddress destination + executeGlobalOperations tcOpts [TransferOp $ TransferOperation destAddr txData 0] ---------------------------------------------------------------------------- -- Executor @@ -427,14 +394,15 @@ runExecutorM :: Timestamp -> Natural + -> Natural -> RemainingSteps -> GState -> ExecutorM a -> Either ExecutorError (ExecutorRes, a) -runExecutorM now level remainingSteps gState action = +runExecutorM now level minBlockTime remainingSteps gState action = fmap preResToRes $ runExcept - $ runStateT (runReaderT action $ ExecutorEnv now level) + $ runStateT (runReaderT action $ ExecutorEnv now level minBlockTime) initialState where initialOpHash = error "Initial OperationHash touched" @@ -467,20 +435,23 @@ runExecutorMWithDB :: Maybe Timestamp -> Maybe Natural + -> Maybe Natural -> FilePath -> RemainingSteps -> "verbose" :! Bool -> "dryRun" :? Bool -> ExecutorM a -> IO (ExecutorRes, a) -runExecutorMWithDB maybeNow maybeLevel dbPath remainingSteps +runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath remainingSteps (arg #verbose -> verbose) (argDef #dryRun False -> dryRun) action = do gState <- readGState dbPath now <- maybe getCurrentTime pure maybeNow let level = fromMaybe 0 maybeLevel - (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now level remainingSteps gState action + mbt = fromMaybe dummyMinBlockTime maybeMinBlockTime + (res@ExecutorRes{..}, a) <- either throwM pure $ + runExecutorM now level mbt remainingSteps gState action unless dryRun $ writeGState dbPath _erGState @@ -507,6 +478,15 @@ mapM_ putTextLn logs putTextLn "" -- extra break line to separate logs from two sequence contracts +-- | Resolves 'AddressOrAlias' type to 'Address' +resolveAddress :: AddressOrAlias -> ExecutorM Address +resolveAddress (AddressResolved addr) = pure addr +resolveAddress (AddressAlias alias) = do + addrAliases <- use $ esGState . gsAddressAliasesL + case lookupAddress alias addrAliases of + Just addr -> pure addr + Nothing -> throwError $ EEUnknownAddressAlias alias + -- | Execute a list of global operations, discarding their results. executeGlobalOperations :: TypeCheckOptions @@ -571,7 +551,8 @@ address = mkContractAddress opHash ooCounter updates = catMaybes - [ Just $ GSAddAddress address (ASContract contractState) + [ liftA2 GSAddAddressAlias ooAlias (Just address) + , Just $ GSAddAddress address (ASContract contractState) , Just $ GSSetBalance originatorAddress originatorBalance , Just GSIncrementCounter , if bigMapCounter0 == bigMapCounter1 @@ -580,8 +561,7 @@ ] case applyUpdates updates gs of - Left _ -> - throwError $ EEAlreadyOriginated address contractState + Left err -> throwError $ EEFailedToApplyUpdates err Right newGS -> do esGState .= newGS esLog <>= ExecutorLog updates [] @@ -630,6 +610,7 @@ now <- view eeNow level <- view eeLevel + mbt <- view eeMinBlockTime gs <- use esGState remainingSteps <- use esRemainingSteps mSourceAddr <- use esSourceAddress @@ -642,6 +623,15 @@ checkOperationReplay $ TransferOp transferOperation + -- Implicit addresses can't be senders with a balance of 0tz even when the transfer amount + -- is zero. + when (isKeyAddress senderAddr && isNothing overrideBalanceMb) $ + case addresses ^. at senderAddr of + Nothing -> throwError $ EEEmptyImplicitContract senderAddr + Just (asBalance -> balance) | balance == zeroMutez -> + throwError $ EEEmptyImplicitContract senderAddr + _ -> pass + when (badParamToImplicitAccount addr $ tdParameter txData) $ throwError $ EEWrongParameterType addr @@ -665,6 +655,9 @@ let onlyUpdates updates = return (updates, [], Nothing, remainingSteps) (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps) <- case (addresses ^. at addr, addr) of + (Nothing, TransactionRollupAddress _) -> + -- TODO [#838]: support transaction rollups on the emulator + throwError $ EEUnknownContract addr (Nothing, ContractAddress _) -> throwError $ EEUnknownContract addr (Nothing, KeyAddress _) -> do @@ -708,7 +701,7 @@ typedParameter <- case tdParameter txData of TxTypedParam (typedVal :: T.Value t) -> do - T.castM @t @epArg typedVal (throwError ... EEUnexpectedParameterType addr) + T.castM @t @epArg typedVal (throwError . EEUnexpectedParameterType addr) TxUntypedParam untypedVal -> liftEither $ first (EEIllTypedParameter addr) $ typeCheckingWith tcOpts $ typeVerifyParameter @epArg existingContracts untypedVal @@ -745,7 +738,8 @@ , ceChainId = gsChainId gs , ceOperationHash = Just opHash , ceLevel = level - , ceInstrCallStack = def + , ceErrorSrcPos = def + , ceMinBlockTime = mbt } iur@InterpretResult @@ -849,6 +843,7 @@ , ooStorage = ccStorageVal cc , ooContract = ccContract cc , ooCounter = ccCounter cc + , ooAlias = Nothing } in OriginateOp origination diff --git a/src/Morley/Michelson/Runtime/Dummy.hs b/src/Morley/Michelson/Runtime/Dummy.hs --- a/src/Morley/Michelson/Runtime/Dummy.hs +++ b/src/Morley/Michelson/Runtime/Dummy.hs @@ -12,6 +12,7 @@ , dummyContractEnv , dummyGlobalCounter , dummyOrigination + , dummyMinBlockTime ) where import Data.Default (def) @@ -32,6 +33,9 @@ dummyLevel :: Natural dummyLevel = 4000 +dummyMinBlockTime :: Natural +dummyMinBlockTime = 1 + -- | Dummy value for maximal number of steps a contract can -- make. Intentionally quite large, because most likely if you use -- dummy value you don't want the interpreter to stop due to gas @@ -63,7 +67,8 @@ , ceChainId = dummyChainId , ceOperationHash = Nothing , ceLevel = dummyLevel - , ceInstrCallStack = def + , ceErrorSrcPos = def + , ceMinBlockTime = dummyMinBlockTime } -- | 'OriginationOperation' with most data hardcoded to some @@ -82,4 +87,5 @@ , ooStorage = storage , ooContract = contract , ooCounter = counter + , ooAlias = Nothing } diff --git a/src/Morley/Michelson/Runtime/GState.hs b/src/Morley/Michelson/Runtime/GState.hs --- a/src/Morley/Michelson/Runtime/GState.hs +++ b/src/Morley/Michelson/Runtime/GState.hs @@ -8,6 +8,8 @@ -- * Auxiliary types ContractState (..) , AddressState (..) + , AddressAliases (..) + , lookupAddress , asBalance , VotingPowers (..) , vpPick @@ -22,6 +24,7 @@ , GState (..) , gsChainIdL , gsAddressesL + , gsAddressAliasesL , gsVotingPowersL , gsCounterL , gsBigMapCounterL @@ -32,9 +35,6 @@ , genesisAddress1 , genesisAddress2 , genesisAddress3 - , genesisAddress4 - , genesisAddress5 - , genesisAddress6 , genesisAddressN , genesisKeyHash -- * Genesis secret keys @@ -53,11 +53,13 @@ , extractAllContracts ) where -import Control.Lens (at, makeLenses) +import Control.Lens (at, makeLenses, (?~)) import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as Aeson import Data.Aeson.TH (deriveJSON) +import Data.Bimap (Bimap) +import Data.Bimap qualified as Bimap (empty, fromList, insert, lookup, toList) import Data.ByteString.Lazy qualified as LBS import Data.Default (def) import Data.Map.Strict qualified as Map @@ -71,7 +73,8 @@ import Morley.Michelson.Typed.Existential (SomeContractAndStorage(..)) import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped (Contract, Value) -import Morley.Tezos.Address (Address(..), ContractHash, GlobalCounter(..)) +import Morley.Tezos.Address (Address(..), GlobalCounter(..)) +import Morley.Tezos.Address.Alias (Alias) import Morley.Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId) import Morley.Tezos.Crypto import Morley.Util.Aeson @@ -212,8 +215,22 @@ , gsCounter :: GlobalCounter -- ^ Ever increasing operation counter. , gsBigMapCounter :: BigMapCounter + , gsAddressAliases :: AddressAliases + -- ^ Addresses with the associated aliases/names. } deriving stock (Show, Eq) +newtype AddressAliases = AddressAliases (Bimap Alias Address) + deriving stock (Eq, Show) + +instance FromJSON AddressAliases where + parseJSON = fmap (AddressAliases . Bimap.fromList) . parseJSON + +instance ToJSON AddressAliases where + toJSON (AddressAliases aa) = toJSON $ Bimap.toList aa + +lookupAddress :: Alias -> AddressAliases -> Maybe Address +lookupAddress alias (AddressAliases aa) = Bimap.lookup alias aa + makeLensesWith postfixLFields ''GState deriveJSON morleyAesonOptions ''GState @@ -256,14 +273,9 @@ -- | More genesis addresses genesisAddress1, genesisAddress2, genesisAddress3 :: Address -genesisAddress4, genesisAddress5, genesisAddress6 :: Address _ :< genesisAddress1 :< genesisAddress2 :< genesisAddress3 - :< genesisAddress4 :< genesisAddress5 :< genesisAddress6 :< _ = genesisAddresses -{-# DEPRECATED genesisAddress4, genesisAddress5, genesisAddress6 - "Consider using 'genesisAddressN' instead" #-} - -- | More genesis addresses, via a type-level natural -- -- > genesisAddressN @7 @@ -295,6 +307,7 @@ , gsVotingPowers = dummyVotingPowers , gsCounter = GlobalCounter 0 , gsBigMapCounter = BigMapCounter 0 + , gsAddressAliases = AddressAliases $ Bimap.empty } data GStateParseError = @@ -330,6 +343,7 @@ -- | Updates that can be applied to 'GState'. data GStateUpdate where GSAddAddress :: Address -> AddressState -> GStateUpdate + GSAddAddressAlias :: Alias -> Address -> GStateUpdate GSSetStorageValue :: StorageScope st => Address -> T.Value st -> GStateUpdate GSSetBalance :: Address -> Mutez -> GStateUpdate GSIncrementCounter :: GStateUpdate @@ -344,6 +358,8 @@ \case GSAddAddress addr st -> "Add address " +| addr |+ " with state " +| st |+ "" + GSAddAddressAlias alias addr -> + "Add an alias " +| alias |+ " for address " +| addr |+ "" GSSetStorageValue addr tVal -> "Set storage value of address " +| addr |+ " to " +| T.untypeValue tVal |+ "" GSSetBalance addr balance -> @@ -379,8 +395,8 @@ applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState applyUpdate = \case - GSAddAddress addr st -> - maybeToRight (GStateAddressExists addr) . addAddress addr st + GSAddAddress addr st -> addAddress addr st + GSAddAddressAlias alias addr -> Right . addAddressAlias alias addr GSSetStorageValue addr newValue -> setStorageValue addr newValue GSSetBalance addr newBalance -> setBalance addr newBalance @@ -394,12 +410,17 @@ applyUpdates = flip (foldM (flip applyUpdate)) -- | Add an address if it hasn't been added before. -addAddress :: Address -> AddressState -> GState -> Maybe GState +addAddress :: Address -> AddressState -> GState -> Either GStateUpdateError GState addAddress addr st gs - | addr `Map.member` accounts = Nothing - | otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st}) + | addr `Map.member` (gsAddresses gs) = Left $ GStateAddressExists addr + | otherwise = Right $ gs & gsAddressesL . at addr ?~ st + +-- | Add an alias for given address, overwriting any existing address for the same alias. +addAddressAlias :: Alias -> Address -> GState -> GState +addAddressAlias alias addr = gsAddressAliasesL %~ insertAddressAlias where - accounts = gsAddresses gs + insertAddressAlias (AddressAliases aa) = + AddressAliases $ Bimap.insert alias addr aa -- | Update storage value associated with given address. setStorageValue :: forall st. (StorageScope st) => @@ -451,3 +472,5 @@ (ContractAddress ca, ASContract (ContractState{..})) -> Just (ca, SomeParamType $ T.cParamNotes $ csContract) (ContractAddress _, _) -> error "broken GState" + -- TODO [#838]: support transaction rollups on the emulator + (TransactionRollupAddress _, _) -> error "broken GState" diff --git a/src/Morley/Michelson/Runtime/Import.hs b/src/Morley/Michelson/Runtime/Import.hs --- a/src/Morley/Michelson/Runtime/Import.hs +++ b/src/Morley/Michelson/Runtime/Import.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - module Morley.Michelson.Runtime.Import ( -- * Read, parse, typecheck contract @@ -14,9 +11,6 @@ , importSomeContract , importUntypedContract , ContractReadError(..) - , readUntypedContractExt - , readContractExt - , readSomeContractExt -- * Read, parse, typecheck value , readValue @@ -37,7 +31,7 @@ import Morley.Michelson.Parser (parseExpandValue) import Morley.Michelson.Parser.Error (ParserException(..)) import Morley.Michelson.Parser.Types (MichelsonSource(..)) -import Morley.Michelson.Runtime (parseExpandContract, parseExpandContractExt) +import Morley.Michelson.Runtime (parseExpandContract) import Morley.Michelson.TypeCheck (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith, typeVerifyContract, typeVerifyTopLevelType) @@ -58,20 +52,6 @@ readUntypedContract source txt = do first (CREParse source) $ parseExpandContract source txt --- TODO [#712]: Remove this next major release --- | Purely read an untyped contract from Michelson textual representation --- with Morley extensions. --- --- 'MichelsonSource' is accepted solely as a hint for error messages. -readUntypedContractExt - :: MichelsonSource - -> Text - -> Either ContractReadError U.Contract -readUntypedContractExt source txt = do - first (CREParse source) $ parseExpandContractExt source txt - -{-# DEPRECATED readUntypedContractExt "Morley extensions are deprecated" #-} - -- | Purely read a typed contract from Michelson textual representation. readSomeContract :: MichelsonSource @@ -82,20 +62,6 @@ first (CRETypeCheck source) $ typeCheckingWith def $ typeCheckContract contract --- TODO [#712]: Remove this next major release --- | Purely read a typed contract from Michelson textual representation --- with Morley extensions. -readSomeContractExt - :: MichelsonSource - -> Text - -> Either ContractReadError SomeContract -readSomeContractExt source txt = do - contract <- readUntypedContractExt source txt - first (CRETypeCheck source) $ - typeCheckingWith def $ typeCheckContract contract - -{-# DEPRECATED readSomeContractExt "Morley extensions are deprecated" #-} - -- | Purely read a typed contract from Michelson textual representation, -- failing if parameter or storage types mismatch with the expected ones. readContract @@ -108,23 +74,6 @@ contract <- readUntypedContract source txt first (CRETypeCheck source) $ typeCheckingWith def $ typeVerifyContract contract - --- TODO [#712]: Remove this next major release --- | Purely read a typed contract from Michelson textual representation --- with Morley extensions, --- failing if parameter or storage types mismatch with the expected ones. -readContractExt - :: forall cp st . - Each '[SingI] [cp, st] - => MichelsonSource - -> Text - -> Either ContractReadError (Contract cp st) -readContractExt source txt = do - contract <- readUntypedContractExt source txt - first (CRETypeCheck source) $ - typeCheckingWith def $ typeVerifyContract contract - -{-# DEPRECATED readContractExt "Morley extensions are deprecated" #-} -- | Read a thing from a file, using the provided parsing function. importUsing diff --git a/src/Morley/Michelson/TypeCheck.hs b/src/Morley/Michelson/TypeCheck.hs --- a/src/Morley/Michelson/TypeCheck.hs +++ b/src/Morley/Michelson/TypeCheck.hs @@ -21,7 +21,6 @@ , module M , module T , eqType - , matchTypes ) where import Morley.Michelson.TypeCheck.Error as E @@ -30,4 +29,4 @@ import Morley.Michelson.TypeCheck.TypeCheck as T import Morley.Michelson.TypeCheck.Types as M -import Morley.Michelson.TypeCheck.Helpers (eqType, matchTypes) +import Morley.Michelson.TypeCheck.Helpers (eqType) diff --git a/src/Morley/Michelson/TypeCheck/Error.hs b/src/Morley/Michelson/TypeCheck/Error.hs --- a/src/Morley/Michelson/TypeCheck/Error.hs +++ b/src/Morley/Michelson/TypeCheck/Error.hs @@ -19,15 +19,13 @@ import Text.PrettyPrint.Leijen.Text (Doc, cat, enclose, indent, line, list, punctuate, textStrict, (<$$>), (<$>), (<+>)) -import Morley.Michelson.ErrorPos (InstrCallStack(..)) +import Morley.Michelson.ErrorPos (ErrorSrcPos(..)) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, buildRenderDocExtended, doesntNeedParens, renderAnyBuildable, renderDoc, renderDocList) import Morley.Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp) import Morley.Michelson.TypeCheck.Types (SomeHST(..)) import Morley.Michelson.Typed qualified as T -import Morley.Michelson.Typed.Annotation (AnnConvergeError(..)) -import Morley.Michelson.Untyped (StackFn, Ty, Var) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) import Morley.Tezos.Crypto (CryptoParseError) @@ -104,9 +102,7 @@ -- These errors are used to specify info about type check errors -- in @TCError@ data type. data TCTypeError - = AnnError AnnConvergeError - -- ^ Annotation unify error - | TypeEqError (MismatchError T.T) + = TypeEqError (MismatchError T.T) -- ^ Type equality error | StackEqError (MismatchError [T.T]) -- ^ Stacks equality error @@ -170,7 +166,6 @@ instance RenderDoc TCTypeError where renderDoc context = \case - AnnError e -> renderAnyBuildable e TypeEqError merr -> "Types not equal:" <$> renderDoc context merr StackEqError merr -> @@ -216,12 +211,12 @@ -- | Type check error data TCError - = TCFailedOnInstr U.ExpandedInstr SomeHST InstrCallStack (Maybe TypeContext) (Maybe TCTypeError) - | TCFailedOnValue U.Value T.T Text InstrCallStack (Maybe TCTypeError) + = TCFailedOnInstr U.ExpandedInstr SomeHST ErrorSrcPos (Maybe TypeContext) (Maybe TCTypeError) + | TCFailedOnValue U.Value T.T Text ErrorSrcPos (Maybe TCTypeError) | TCContractError Text (Maybe TCTypeError) | TCViewError Text U.ViewName (Maybe TCTypeError) - | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp) - | TCExtError SomeHST InstrCallStack ExtError + | TCUnreachableCode ErrorSrcPos (NonEmpty U.ExpandedOp) + | TCExtError SomeHST ErrorSrcPos ExtError | TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp) | TCIncompletelyTypedView TCError (U.View' TypeCheckedOp) deriving stock (Show, Eq, Generic) @@ -294,9 +289,7 @@ -- | Various type errors possible when checking Morley extension commands data ExtError = LengthMismatch U.StackTypePattern - | VarError Text StackFn | TypeMismatch U.StackTypePattern Int TCTypeError - | TyVarMismatch Var Ty U.StackTypePattern Int TCTypeError | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError | TestAssertError Text | InvalidStackReference U.StackRef StackSize @@ -310,15 +303,8 @@ "Unexpected length of stack: pattern " +| stk |+ " has length " +| (length . fst . U.stackTypePatternToList) stk |+ "" - VarError t sf -> - "In defenition of " +| t |+ ": VarError " - +| sf |+ "" TypeMismatch stk i e -> "TypeMismatch: Pattern " +| stk |+ " at index " - +| i |+ " with error: " +| e |+ "" - TyVarMismatch v t stk i e -> - "TyVarMismach: Variable " +| v |+ " is bound to type " - +| t |+ " but pattern " +| stk |+ " failed at index " +| i |+ " with error: " +| e |+ "" StkRestMismatch stk (SomeHST r) (SomeHST r') e -> "StkRestMismatch in pattern " +| stk |+ diff --git a/src/Morley/Michelson/TypeCheck/Ext.hs b/src/Morley/Michelson/TypeCheck/Ext.hs --- a/src/Morley/Michelson/TypeCheck/Ext.hs +++ b/src/Morley/Michelson/TypeCheck/Ext.hs @@ -1,32 +1,25 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Type-checking of Morley extension. module Morley.Michelson.TypeCheck.Ext ( typeCheckExt ) where -import Control.Lens ((%=)) import Control.Monad.Except (MonadError, liftEither, throwError) import Data.Constraint (Dict(..)) import Data.Map.Lazy (insert, lookup) -import Data.Singletons (SingI) +import Data.Singletons (SingI, fromSing) import Data.Typeable ((:~:)(..)) -import Morley.Michelson.ErrorPos import Morley.Michelson.TypeCheck.Error import Morley.Michelson.TypeCheck.Helpers import Morley.Michelson.TypeCheck.TypeCheck import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..)) import Morley.Michelson.TypeCheck.Types -import Morley.Michelson.Typed (Notes(..), converge, mkUType, notesT, withUType) +import Morley.Michelson.Typed (Notes(..), notesT, withUType) import Morley.Michelson.Typed qualified as T -import Morley.Michelson.Untyped - (ExpandedOp, StackFn, Ty, TyVar(..), Var, VarAnn, sfnInPattern, sfnOutPattern, sfnQuantifiedVars, - varSet) +import Morley.Michelson.Untyped (Ty, TyVar(..), Var) import Morley.Michelson.Untyped qualified as U import Morley.Util.MismatchError import Morley.Util.PeanoNatural (PeanoNatural(..)) @@ -50,11 +43,10 @@ -> HST s -> TypeCheckInstrNoExcept (TypeCheckedSeq s) typeCheckExt tcInstr ext hst = do - instrPos <- ask + instrPos <- view tcieErrorPos case ext of U.STACKTYPE s -> workOnInstr ext $ liftExtError hst $ stackTypeSomeInstr s <$ checkStackType noBoundVars s hst - U.FN t sf op -> checkFn tcInstr t sf op hst instrPos U.UPRINT pc -> workOnInstr ext $ verifyPrint pc <&> \tpc -> toSomeInstr (T.PRINT tpc) U.UTEST_ASSERT U.TestAssert{..} -> do @@ -62,7 +54,7 @@ preserving (typeCheckImpl tcInstr tassInstrs hst) cons $ \(_ :/ si) -> case si of AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError "TEST_ASSERT has to return Bool, but it always fails" - instr ::: (((_ :: (T.Notes b, Dict (T.WellTyped b), VarAnn)) ::& _)) -> do + instr ::: (((_ :: (T.SingT b, Dict (T.WellTyped b))) ::& _)) -> do Refl <- liftEither $ first (const $ TCExtError (SomeHST hst) instrPos $ TestAssertError "TEST_ASSERT has to return Bool, but returned something else") @@ -87,47 +79,9 @@ liftExtError :: SingI s => HST s -> Either ExtError a -> TypeCheckInstr a liftExtError hst ei = do - instrPos <- ask + instrPos <- view tcieErrorPos liftEither $ first (TCExtError (SomeHST hst) instrPos) ei --- | Check that the optional "forall" variables are consistent if present -checkVars :: Text -> StackFn -> Either ExtError () -checkVars t sf = case sfnQuantifiedVars sf of - Just qs - | varSet (sfnInPattern sf) /= qs -> Left $ VarError t sf - _ -> pass - --- | Executes function body, pushing @ExtFrame@ onto the state and checks --- the pattern in @FN@. -checkFn - :: SingI inp - => TcInstrHandler - -> Text - -> StackFn - -> [ExpandedOp] - -> HST inp - -> InstrCallStack - -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) -checkFn tcInstr t sf body inp loc = do - guarding (con body) (checkStart inp) $ \vars -> - preserving (typeCheckImplStripped tcInstr body inp) con $ \someI@(_ :/ instrAndOut) -> - case instrAndOut of - _ ::: out -> checkEnd vars out $> mapSomeInstr (T.WithLoc loc . T.Fn t sf) someI - AnyOutInstr{} -> pure someI - where - checkStart hst = do - liftExtError hst $ checkVars t sf - vars <- liftExtError hst $ checkStackType noBoundVars (sfnInPattern sf) hst - tcExtFramesL %= (vars :) - return vars - - checkEnd :: SingI out => BoundVars -> HST out -> TypeCheckInstr () - checkEnd vars out = liftExtError out $ - void $ checkStackType vars (sfnOutPattern sf) out - - con :: [op] -> U.InstrAbstract op - con = U.EXT . U.FN t sf - -- | Check that a @StackTypePattern@ matches the type of the current stack checkStackType :: SingI xs @@ -148,34 +102,33 @@ 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) ((xann :: Notes xt, _, _) ::& xs) = + go m n (U.StkCons tyVar ts) ((xsing :: T.SingT xt, _) ::& xs) = let handleType :: U.Ty -> Either ExtError BoundVars handleType t = withUType t $ \(tann :: Notes t) -> do Refl <- first (\_ -> TypeMismatch s n $ TypeEqError MkMismatchError - { meExpected = notesT xann, meActual = notesT tann }) + { meExpected = fromSing xsing, meActual = 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 xann in go (insert v t m) (n + 1) ts xs + Nothing -> let t = T.toUType $ fromSing xsing in go (insert v t m) (n + 1) ts xs Just t -> handleType t -- | Create stack reference accessing element with a given index. -- -- Fails when index is too large for the given stack. createStackRef - :: (MonadError TCError m, MonadReader InstrCallStack m, SingI s) + :: (MonadError TCError m, MonadReader TypeCheckInstrEnv m, SingI s) => Natural -> HST s -> m (T.StackRef s) createStackRef idx hst = case doCreate (hst, idx) of Just sr -> pure sr Nothing -> do - instrPos <- ask + instrPos <- view tcieErrorPos throwError $ TCExtError (SomeHST hst) instrPos $ InvalidStackReference (U.StackRef idx) (StackSize $ lengthHST hst) diff --git a/src/Morley/Michelson/TypeCheck/Helpers.hs b/src/Morley/Michelson/TypeCheck/Helpers.hs --- a/src/Morley/Michelson/TypeCheck/Helpers.hs +++ b/src/Morley/Michelson/TypeCheck/Helpers.hs @@ -1,34 +1,21 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - module Morley.Michelson.TypeCheck.Helpers - ( deriveSpecialVN - , deriveSpecialFNs - , deriveVN - , deriveNsOr - , deriveNsOption - , convergeHSTEl - , convergeHST - , hstToTs + ( hstToTs , eqHST , eqHST1 - , matchHST1 , lengthHST , ensureDistinctAsc , handleError , eqType - , onTypeCheckInstrAnnErr , onTypeCheckInstrErr , onScopeCheckInstrErr , typeCheckInstrErr , typeCheckInstrErr' , typeCheckImpl , typeCheckImplStripped - , matchTypes , memImpl , getImpl @@ -50,125 +37,35 @@ import Prelude hiding (EQ, GT, LT) -import Control.Lens (unsnoc) import Control.Monad.Except (MonadError, catchError, throwError) import Data.Constraint (Dict(..), withDict) import Data.Default (def) -import Data.Singletons (Sing, SingI(sing), demote) +import Data.Singletons (Sing, SingI(sing), demote, fromSing) import Data.Singletons.Decide ((:~:)(Refl)) -import Data.Text qualified as T -import Data.Vinyl (Rec(..)) import Fmt (Buildable, (+|), (|+)) -import Morley.Michelson.ErrorPos (InstrCallStack) +import Morley.Michelson.ErrorPos (ErrorSrcPos) import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..), TypeContext(..)) import Morley.Michelson.TypeCheck.TypeCheck import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..)) import Morley.Michelson.TypeCheck.Types import Morley.Michelson.Typed (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, ExtInstr(COMMENT_ITEM), - Instr(..), Notes(..), SingT(..), T(..), WellTyped, converge, getComparableProofS, notesT, - requireEq, starNotes) -import Morley.Michelson.Typed.Annotation (AnnConvergeError, isStar) + Instr(..), SingT(..), T(..), WellTyped, getComparableProofS, requireEq) +import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Arith (Add, ArithOp(..), EDiv, Mul, Sub, UnaryArithOp(..)) import Morley.Michelson.Typed.Polymorphic (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..)) import Morley.Michelson.Untyped qualified as Un -import Morley.Michelson.Untyped.Annotation - (Annotation(..), FieldAnn, VarAnn, annQ, mkAnnotation, noAnn, orAnn) +import Morley.Michelson.Untyped.Annotation (VarAnn) import Morley.Util.MismatchError import Morley.Util.Sing (eqI) -import Morley.Util.Type (onFirst) --- | Function which derives special annotations --- for PAIR instruction. --- --- Namely, it does following transformation: --- --- > PAIR %@ %@ [ @p.a int : @p.b int : .. ] --- > ~ --- > [ @p pair (int %a) (int %b) : .. ] --- --- All relevant cases (e.g. @PAIR %myf %@@ @) --- are handled as they should be according to spec. -deriveSpecialFNs - :: FieldAnn -> FieldAnn - -> VarAnn -> VarAnn - -> VarAnn - -> (VarAnn, FieldAnn, FieldAnn) -deriveSpecialFNs pfn qfn pvn qvn vn = (vn', pfn', qfn') - where - (vn1, pfn') = bool (vn, pfn) (splitLastDot pvn) (unAnnotation pfn == "@") - (vn2, qfn') = bool (vn, qfn) (splitLastDot qvn) (unAnnotation qfn == "@") - vn' = bool vn (commonPrefix vn1 vn2) (vn == def) - - splitLastDot :: VarAnn -> (VarAnn, FieldAnn) - splitLastDot v = case unsnoc $ T.splitOn "." $ unAnnotation v of - Nothing -> def - Just (_, "") -> (def, Un.convAnn v) - Just (vs, l) -> (foldMap (unsafe . mkAnnotation) vs, bool (unsafe . mkAnnotation $ l) def (l == "car" || l == "cdr")) - - commonPrefix :: VarAnn -> VarAnn -> VarAnn - commonPrefix = curry \case - (v1, v2) | v1 == v2 -> v1 - (v1, v2) | v2 == noAnn -> v1 - (v1, v2) | v1 == noAnn -> v2 - _ -> def - --- | Function which derives special annotations --- for CDR / CAR instructions. -deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn -deriveSpecialVN vn elFn pairVN elVn - | (unAnnotation vn) == "%" = Un.convAnn elFn - -- TODO [#534]: - -- In the `%%` branch, if the pair's field annotation (`elFn`) is empty, we should default it to "cdr"/"car". - -- See: - | (unAnnotation vn) == "%%" = pairVN <> Un.convAnn elFn - | otherwise = vn `orAnn` elVn - --- | Append suffix to variable annotation (if it's not empty) -deriveVN :: VarAnn -> VarAnn -> VarAnn -deriveVN suffix vn = bool (suffix <> vn) def (vn == def) - --- | Function which extracts annotations for @or@ type --- (for left and right parts). --- --- It extracts field/type annotations and also auto-generates variable --- annotations if variable annotation is not provided as second argument. -deriveNsOr :: Notes ('TOr a b) -> VarAnn -> (Notes a, Notes b, VarAnn, VarAnn) -deriveNsOr (NTOr _ afn bfn an bn) ovn = - let avn = deriveVN (Un.convAnn afn `orAnn` [annQ|left|]) ovn - bvn = deriveVN (Un.convAnn bfn `orAnn` [annQ|right|]) ovn - in (an, bn, avn, bvn) - --- | Function which extracts annotations for @option t@ type. --- --- It extracts field/type annotations and also auto-generates variable --- annotation for @Some@ case if it is not provided as second argument. -deriveNsOption :: Notes ('TOption a) -> VarAnn -> (Notes a, VarAnn) -deriveNsOption (NTOption _ an) ovn = - let avn = deriveVN [annQ|some|] ovn - in (an, avn) - -convergeHSTEl - :: (Notes t, Dict (WellTyped t), VarAnn) - -> (Notes t, Dict (WellTyped t), VarAnn) - -> Either AnnConvergeError (Notes t, Dict (WellTyped t), VarAnn) -convergeHSTEl (an, d@Dict, avn) (bn, _, bvn) = - (,,) <$> converge an bn <*> pure d - <*> pure (bool def avn $ avn == bvn) - --- | Combine annotations from two given stack types -convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts) -convergeHST SNil SNil = pure SNil -convergeHST (a ::& as) (b ::& bs) = - liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs) - -- | Extract singleton for each single type of the given stack. hstToTs :: HST st -> [T] hstToTs = \case SNil -> [] - (notes, _, _) ::& hst -> notesT notes : hstToTs hst + (ts, _) ::& hst -> fromSing ts : hstToTs hst -- | Check whether the given stack types are equal. eqHST @@ -177,9 +74,7 @@ eqHST (hst :: HST xs) (hst' :: HST ys) = do case eqI @as @bs of Nothing -> Left $ StackEqError MkMismatchError {meActual = hstToTs hst, meExpected = hstToTs hst'} - Just Refl -> do - void $ convergeHST hst hst' `onFirst` AnnError - return Refl + Just Refl -> Right Refl -- | Check whether the given stack has size 1 and its only element matches the -- given type. This function is a specialized version of `eqHST`. @@ -192,16 +87,6 @@ Nothing -> Left $ StackEqError MkMismatchError {meActual = hstToTs hst, meExpected = hstToTs hst'} Just Refl -> Right Refl --- | Version of 'eqHST1' that also checks whether annotations converge --- like 'matchTypes'. -matchHST1 - :: forall t st. (SingI st, WellTyped t) - => HST st -> Notes t -> Either TCTypeError (st :~: '[t], HST st) -matchHST1 hst nt = do - refl@Refl <- eqHST1 @t hst - hstRes <- convergeHST ((nt, Dict, noAnn) ::& SNil) hst `onFirst` AnnError - return (refl, hstRes) - lengthHST :: HST xs -> Natural lengthHST (_ ::& xs) = 1 + lengthHST xs lengthHST SNil = 0 @@ -233,7 +118,7 @@ requireEq @a @b $ Left ... TypeEqError onTypeCheckInstrErr - :: (MonadReader InstrCallStack m, MonadError TCError m) + :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext -> Either TCTypeError a -> m a onTypeCheckInstrErr instr hst mContext ei = do @@ -241,41 +126,34 @@ onScopeCheckInstrErr :: forall (t :: T) m a. - (MonadReader InstrCallStack m, MonadError TCError m, SingI t) + (MonadReader TypeCheckInstrEnv m, MonadError TCError m, SingI t) => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext -> Either BadTypeForScope a -> m a onScopeCheckInstrErr instr hst mContext = \case Right a -> return a Left e -> do - pos <- ask + pos <- view tcieErrorPos throwError $ TCFailedOnInstr instr hst pos mContext $ Just $ UnsupportedTypeForScope (demote @t) e typeCheckInstrErr - :: (MonadReader InstrCallStack m, MonadError TCError m) + :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext -> m a typeCheckInstrErr instr hst mContext = do - pos <- ask + pos <- view tcieErrorPos throwError $ TCFailedOnInstr instr hst pos mContext Nothing typeCheckInstrErr' - :: (MonadReader InstrCallStack m, MonadError TCError m) + :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext -> TCTypeError -> m a typeCheckInstrErr' instr hst mContext err = do - pos <- ask + pos <- view tcieErrorPos throwError $ TCFailedOnInstr instr hst pos mContext (Just err) -onTypeCheckInstrAnnErr - :: (MonadReader InstrCallStack m, MonadError TCError m, SingI ts) - => Un.ExpandedInstr -> HST ts -> Maybe TypeContext - -> Either AnnConvergeError a -> m a -onTypeCheckInstrAnnErr instr i mContext ei = - onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onFirst` AnnError) - withCompareableCheck - :: forall a m v ts. (SingI ts, MonadReader InstrCallStack m, MonadError TCError m) + :: forall a m v ts. (SingI ts, MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Sing a -> Un.ExpandedInstr -> HST ts @@ -299,208 +177,19 @@ Un.SeqEx sq -> typeCheckSeq sq where -- If we know source location from the untyped instruction, keep it in the typed one. - typeCheckPrimWithLoc :: InstrCallStack -> Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) - typeCheckPrimWithLoc loc op = local (const loc) + typeCheckPrimWithLoc :: ErrorSrcPos -> Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) + typeCheckPrimWithLoc loc op = local (set tcieErrorPos loc) (wrapWithLoc loc <$> typeCheckPrim op) typeCheckPrim :: Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) - typeCheckPrim op = tcInstr op hst <&> mapSeq addNotes + typeCheckPrim op = tcInstr op hst - typeCheckSeqWithLoc :: InstrCallStack -> [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) - typeCheckSeqWithLoc loc = fmap (wrapWithLoc loc) . local (const loc) . typeCheckSeq + typeCheckSeqWithLoc :: ErrorSrcPos -> [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) + typeCheckSeqWithLoc loc = fmap (wrapWithLoc loc) . local (set tcieErrorPos loc) . typeCheckSeq typeCheckSeq :: [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) typeCheckSeq sq = typeCheckImpl tcInstr sq hst - <&> mapSeq (addNotes . mapSomeInstr Nested) - - addNotes :: SomeInstr inp -> SomeInstr inp - addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes out i ::: out - addNotes i = i - - wrapWithNotes :: HST d -> Instr c d -> Instr c d - wrapWithNotes outputStack instr = case instr of - -- Abstractions for instructions: - Nop -> instr' - Seq _ _ -> instr' - Nested _ -> instr' - DocGroup _ _ -> instr' - Ext _ -> instr' - FrameInstr _ _ -> instr' - WithLoc _ _ -> instr' - Meta _ _ -> instr' - Fn {} -> instr' - -- These three shouldn't happen, since annotations are added here. - InstrWithNotes {} -> instr' - InstrWithVarAnns _ _ -> instr' - InstrWithVarNotes _ _ -> instr' - - -- Instructions that don't produce notes: - DROP -> instr' - DROPN _ -> instr' - SWAP -> instr' - DIG _ -> instr' - DUG _ -> instr' - IF_NONE _ _ -> instr' - IF_LEFT _ _ -> instr' - IF_CONS _ _ -> instr' - ITER _ -> instr' - IF _ _ -> instr' - LOOP _ -> instr' - LOOP_LEFT _ -> instr' - DIP _ -> instr' - DIPN _ _ -> instr' - FAILWITH -> instr' - NEVER -> instr' - - -- These instructions technically may have one/two explicit var anns, BUT because they support special var anns, - -- the var anns are stored directly inside the instruction's constructor. - -- For this reason, they must NOT be wrapped in `InstrWithVarNotes`. - AnnCAR _ _ -> instr' - AnnCDR _ _ -> instr' - AnnUNPAIR{} -> - case outputStack of - (notes1, _, varAnn1) ::& (notes2, _, varAnn2) ::& _ -> - let withNotes - | isStar notes1 && isStar notes2 = id - | isStar notes2 = InstrWithNotes Proxy (notes1 :& RNil) - | otherwise = InstrWithNotes Proxy (notes1 :& notes2 :& RNil) - withVarAnns - | varAnn1 == def && varAnn2 == def = id - | varAnn2 == def = InstrWithVarAnns $ Un.OneVarAnn varAnn1 - | otherwise = InstrWithVarAnns (Un.TwoVarAnns varAnn1 varAnn2) - in withNotes $ withVarAnns instr - - -- We purposefully don't wrap `UNPAIRN` in meta-instructions - -- like `InstrWithNotes` and `InstrWithVarAnns`. - -- See !769 for a lengthy explanation. - UNPAIRN _ -> instr - - -- Instructions that produce at most two notes: - CREATE_CONTRACT _ -> case outputStack of - ((np, _, vp) ::& (_, _, vs) ::& _) -> - let withNotes = if isStar np then id else InstrWithNotes Proxy (np :& RNil) - withVarNotes = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarNotes (vp :| [vs]) - withVarNotes' = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns vp vs - in withNotes . withVarNotes . withVarNotes' $ instr - - GET_AND_UPDATE -> case outputStack of - ((valNotes, _, valVarAnn) ::& (mapNotes, _, mapVarAnn) ::& _) -> - let - -- `GET_AND_UPDATE` can have one var ann argument (e.g. 'GET_AND_UPDATE @var'), - -- which is applied to the 2nd element of the stack (the updated map). - withVarNotes = if mapVarAnn == Un.noAnn then id else InstrWithVarNotes (one mapVarAnn) - -- `GET_AND_UPDATE` puts two elements on the top of the stack, both of which - -- can have type/field/var annotations. - withNotes = if isStar valNotes && isStar mapNotes then id else InstrWithNotes Proxy (valNotes :& mapNotes :& RNil) - withVarNotes' = if valVarAnn == Un.noAnn && mapVarAnn == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns valVarAnn mapVarAnn - in withNotes . withVarNotes . withVarNotes' $ instr - - DUP -> instr'' - DUPN _ -> instr'' - PUSH _ -> instr'' - UNIT -> instr'' - SOME -> instr'' - NONE -> instr'' - AnnPAIR{} -> instr'' - AnnLEFT{} -> instr'' - AnnRIGHT{} -> instr'' - NIL -> instr'' - CONS -> instr'' - SIZE -> instr'' - MAP _ -> instr'' - MEM -> instr'' - EMPTY_SET -> instr'' - EMPTY_MAP -> instr'' - EMPTY_BIG_MAP -> instr'' - UPDATE -> instr'' - UPDATEN _ -> instr'' - GET -> instr'' - GETN _ -> instr'' - LAMBDA _ -> instr'' - EXEC -> instr'' - ADD -> instr'' - SUB -> instr'' - SUB_MUTEZ -> instr'' - CONCAT -> instr'' - CONCAT' -> instr'' - MUL -> instr'' - OR -> instr'' - AND -> instr'' - XOR -> instr'' - NOT -> instr'' - ABS -> instr'' - ISNAT -> instr'' - INT -> instr'' - NEG -> instr'' - EDIV -> instr'' - LSL -> instr'' - LSR -> instr'' - COMPARE -> instr'' - EQ -> instr'' - NEQ -> instr'' - LT -> instr'' - GT -> instr'' - LE -> instr'' - GE -> instr'' - ADDRESS -> instr'' - CONTRACT _ _ -> instr'' - SET_DELEGATE -> instr'' - IMPLICIT_ACCOUNT -> instr'' - NOW -> instr'' - LEVEL -> instr'' - AMOUNT -> instr'' - BALANCE -> instr'' - HASH_KEY -> instr'' - CHECK_SIGNATURE -> instr'' - BLAKE2B -> instr'' - SOURCE -> instr'' - SENDER -> instr'' - VIEW{} -> instr'' - SELF _ -> instr'' - SELF_ADDRESS -> instr'' - CAST -> instr'' - RENAME -> instr'' - CHAIN_ID -> instr'' - APPLY -> instr'' - PAIRN _ -> instr'' - PACK -> instr'' - UNPACK -> instr'' - SLICE -> instr'' - TRANSFER_TOKENS -> instr'' - VOTING_POWER -> instr'' - TOTAL_VOTING_POWER -> instr'' - SHA256 -> instr'' - SHA512 -> instr'' - SHA3 -> instr'' - KECCAK -> instr'' - PAIRING_CHECK -> instr'' - TICKET -> instr'' - READ_TICKET -> instr'' - SPLIT_TICKET -> instr'' - JOIN_TICKETS -> instr'' - OPEN_CHEST -> instr'' - SAPLING_EMPTY_STATE _ -> instr'' - SAPLING_VERIFY_UPDATE -> instr'' - where - instr' = addNotesNoVarAnn outputStack instr - instr'' = addNotesOneVarAnn outputStack instr - - addNotesOneVarAnn :: HST d -> Instr c d -> Instr c d - addNotesOneVarAnn outputStack instr = case outputStack of - ((n, _, v) ::& _) -> - let withNotes = if isStar n then id else InstrWithNotes Proxy (n :& RNil) - withVarNotes = if v == Un.noAnn then id else InstrWithVarNotes (one v) - withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v - in withNotes . withVarNotes . withVarNotes' $ instr - SNil -> instr - - addNotesNoVarAnn :: HST d -> Instr c d -> Instr c d - addNotesNoVarAnn outputStack instr = case outputStack of - ((n, _, v) ::& _) -> - let withNotes = if isStar n then id else InstrWithNotes Proxy (n :& RNil) - withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v - in withNotes . withVarNotes' $ instr - SNil -> instr + <&> mapSeq (mapSomeInstr Nested) -- | Like 'typeCheckImpl' but doesn't add a stack type comment after the -- sequence. @@ -551,7 +240,7 @@ combine inp Nop (_ :/ nextPart) = inp :/ nextPart combine inp i1 (_ :/ nextPart) = inp :/ mapSomeInstrOut (Seq i1) nextPart - extractOpPos :: Un.ExpandedOp -> InstrCallStack + extractOpPos :: Un.ExpandedOp -> ErrorSrcPos extractOpPos (Un.WithSrcEx loc _) = loc extractOpPos _ = def @@ -601,8 +290,6 @@ isNop :: Instr inp out -> Bool isNop (WithLoc _ i) = isNop i -isNop (InstrWithNotes _ _ i) = isNop i -isNop (InstrWithVarNotes _ i) = isNop i isNop (FrameInstr _ i) = isNop i isNop (Seq i1 i2) = isNop i1 && isNop i2 isNop (Nested i) = isNop i @@ -632,22 +319,12 @@ noStackTypeComment :: Instr st st noStackTypeComment = Ext (COMMENT_ITEM (StackTypeComment Nothing)) -wrapWithLoc :: InstrCallStack -> TypeCheckedSeq inp -> TypeCheckedSeq inp +wrapWithLoc :: ErrorSrcPos -> TypeCheckedSeq inp -> TypeCheckedSeq inp wrapWithLoc loc = mapSeq $ \someInstr -> case someInstr of (_ :/ WithLoc{} ::: _) -> someInstr (inp :/ instr ::: out) -> inp :/ WithLoc loc instr ::: out (inp :/ AnyOutInstr instr) -> inp :/ (AnyOutInstr $ WithLoc loc instr) --- | Check whether given types are structurally equal and annotations converge. -matchTypes - :: forall t1 t2. - (Each '[SingI] [t1, t2]) - => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1) -matchTypes n1 n2 = do - Refl <- eqType @t1 @t2 - nr <- converge n1 n2 `onFirst` AnnError - return (Refl, nr) - -------------------------------------------- -- Some generic instruction implementation -------------------------------------------- @@ -659,24 +336,20 @@ , SingI (MemOpKey c) , inp ~ (memKey : c : rs) , SingI rs - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) - => Notes (MemOpKey c) - -> HST inp + => HST inp -> VarAnn -> m (SomeInstr inp) -memImpl cKeyNotes inputHST@(hst0 ::& _ ::& hstTail) varAnn = +memImpl inputHST@(_ ::& _ ::& hstTail) varAnn = case eqType @memKey @(MemOpKey c) of - Right Refl -> do - _ <- onTypeCheckInstrAnnErr uInstr inputHST - (Just ContainerKeyType) (converge memKeyNotes cKeyNotes) + Right Refl -> pure $ inputHST :/ - MEM ::: ((starNotes, Dict, varAnn) ::& hstTail) + AnnMEM (Anns1 varAnn) ::: ((sing, Dict) ::& hstTail) Left m -> typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m where - (memKeyNotes, Dict, _) = hst0 uInstr = Un.MEM varAnn getImpl @@ -685,25 +358,21 @@ , WellTyped (GetOpVal c) , inp ~ (getKey : c : rs) , SingI rs - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) - => Notes (GetOpKey c) - -> HST inp - -> Notes (GetOpVal c) + => HST inp + -> SingT (GetOpVal c) -> VarAnn -> m (SomeInstr inp) -getImpl notesKeyC inputHST@(hst0 ::& _ ::& hstTail) valueNotes varAnn = +getImpl inputHST@(_ ::& _ ::& hstTail) valueSing varAnn = case eqType @getKey @(GetOpKey c) of - Right Refl -> do - _ <- onTypeCheckInstrAnnErr uInstr inputHST - (Just ContainerKeyType) (converge getKeyNotes notesKeyC) + Right Refl -> pure $ inputHST :/ - GET ::: ((NTOption def valueNotes, Dict, varAnn) ::& hstTail) + AnnGET (Anns1 varAnn) ::: ((STOption valueSing, Dict) ::& hstTail) Left m -> typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m where - (getKeyNotes, Dict, _) = hst0 uInstr = Un.GET varAnn updImpl @@ -712,31 +381,22 @@ , SingI (UpdOpKey c), SingI (UpdOpParams c) , SingI rs , inp ~ (updKey : updParams : c : rs) - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) - => Notes (UpdOpKey c) - -> HST inp - -> Notes (UpdOpParams c) + => HST inp -> VarAnn -> m (SomeInstr inp) -updImpl cKeyNotes inputHST@(hst0 ::& hst1 ::& cTuple ::& hstTail) cValueNotes varAnn = +updImpl inputHST@(_ ::& _ ::& cTuple ::& hstTail) varAnn = case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of - (Right Refl, Right Refl) -> do - _ <- onTypeCheckInstrAnnErr uInstr inputHST - (Just ContainerKeyType) (converge updKeyNotes cKeyNotes) - _ <- onTypeCheckInstrAnnErr uInstr inputHST - (Just ContainerValueType) (converge updValueNotes cValueNotes) - let vn = varAnn `orAnn` (cTuple ^. _3) + (Right Refl, Right Refl) -> pure $ inputHST :/ - UPDATE ::: ((cTuple & _3 .~ vn) ::& hstTail) + AnnUPDATE (Anns1 varAnn) ::: (cTuple ::& hstTail) (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m (_, Left m) -> typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerValueType) m where - (updKeyNotes, Dict, _) = hst0 - (updValueNotes, Dict, _) = hst1 uInstr = Un.UPDATE varAnn getUpdImpl @@ -748,31 +408,22 @@ , SingI rs , GetOpKey c ~ UpdOpKey c , UpdOpParams c ~ 'TOption (GetOpVal c) - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) - => Notes (UpdOpKey c) - -> HST inp - -> Notes (UpdOpParams c) + => HST inp -> VarAnn -> m (SomeInstr inp) -getUpdImpl cKeyNotes inputHST@(hst0 ::& hst1 ::& cTuple ::& hstTail) cValueNotes varAnn = +getUpdImpl inputHST@(_ ::& hst1 ::& cTuple ::& hstTail) varAnn = case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of - (Right Refl, Right Refl) -> do - _ <- onTypeCheckInstrAnnErr uInstr inputHST - (Just ContainerKeyType) (converge updKeyNotes cKeyNotes) - _ <- onTypeCheckInstrAnnErr uInstr inputHST - (Just ContainerValueType) (converge updValueNotes cValueNotes) - let vn = varAnn `orAnn` (cTuple ^. _3) + (Right Refl, Right Refl) -> pure $ inputHST :/ - GET_AND_UPDATE ::: (hst1 ::& (cTuple & _3 .~ vn) ::& hstTail) + AnnGET_AND_UPDATE (Anns1 varAnn) ::: (hst1 ::& cTuple ::& hstTail) (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m (_, Left m) -> typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerValueType) m where - (updKeyNotes, Dict, _) = hst0 - (updValueNotes, Dict, _) = hst1 uInstr = Un.GET_AND_UPDATE varAnn sizeImpl @@ -781,67 +432,58 @@ -> VarAnn -> m (SomeInstr inp) sizeImpl i@(_ ::& rs) vn = - pure $ i :/ SIZE ::: ((starNotes, Dict, vn) ::& rs) + pure $ i :/ AnnSIZE (Anns1 vn) ::: ((sing, Dict) ::& rs) sliceImpl :: (SliceOp c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m) => HST inp -> Un.VarAnn -> m (SomeInstr inp) -sliceImpl i@(_ ::& _ ::& (cn, Dict, cvn) ::& rs) vn = do - let vn' = vn `orAnn` deriveVN [annQ|slice|] cvn - rn = NTOption def cn - pure $ i :/ SLICE ::: ((rn, Dict, vn') ::& rs) +sliceImpl i@(_ ::& _ ::& (cn, Dict) ::& rs) vn = do + let rn = STOption cn + pure $ i :/ AnnSLICE (Anns1 vn) ::: ((rn, Dict) ::& rs) concatImpl' :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m) => HST inp -> Un.VarAnn -> m (SomeInstr inp) -concatImpl' i@((NTList _ n, Dict, _) ::& rs) vn = do - pure $ i :/ CONCAT' ::: ((n, Dict, vn) ::& rs) +concatImpl' i@((STList n, Dict) ::& rs) vn = do + pure $ i :/ AnnCONCAT' (Anns1 vn) ::: ((n, Dict) ::& rs) concatImpl :: ( ConcatOp c, inp ~ (c ': c ': rs) , WellTyped c - , MonadReader InstrCallStack m - , MonadError TCError m + , MonadReader TypeCheckInstrEnv m ) => HST inp -> Un.VarAnn -> m (SomeInstr inp) -concatImpl i@((cn1, _, _) ::& (cn2, _, _) ::& rs) vn = do - cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i (Just ConcatArgument) (converge cn1 cn2) - pure $ i :/ CONCAT ::: ((cn, Dict, vn) ::& rs) +concatImpl i@((cn1, _) ::& (_, _) ::& rs) vn = do + pure $ i :/ AnnCONCAT (Anns1 vn) ::: ((cn1, Dict) ::& rs) -- | Helper function to construct instructions for binary arithmetic -- operations. arithImpl :: forall aop inp m n s t. - ( ArithOp aop n m - , WellTyped (ArithRes aop n m) + ( WellTyped (ArithRes aop n m) , inp ~ (n ': m ': s) - , MonadReader InstrCallStack t - , MonadError TCError t + , MonadReader TypeCheckInstrEnv t ) - => Instr inp (ArithRes aop n m ': s) + => (Anns '[VarAnn] -> Instr inp (ArithRes aop n m ': s)) -> HST inp -> VarAnn -> Un.ExpandedInstr -> t (SomeInstr inp) -arithImpl mkInstr i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do - case convergeArith (Proxy @aop) an bn of - Right cn -> - pure $ i :/ mkInstr ::: ((cn, Dict, vn) ::& rs) - Left err -> do - typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err +arithImpl mkInstr i@(_ ::& _ ::& rs) vn _ = + pure $ i :/ mkInstr (Anns1 vn) ::: ((sing, Dict) ::& rs) addImpl :: forall a b inp rs m. ( Each '[SingI] [a, b] , inp ~ (a ': b ': rs) , SingI rs - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) => Sing a -> Sing b @@ -850,16 +492,16 @@ -> Un.ExpandedInstr -> m (SomeInstr inp) addImpl t1 t2 = case (t1, t2) of - (STInt, STInt) -> arithImpl @Add ADD - (STInt, STNat) -> arithImpl @Add ADD - (STNat, STInt) -> arithImpl @Add ADD - (STNat, STNat) -> arithImpl @Add ADD - (STInt, STTimestamp) -> arithImpl @Add ADD - (STTimestamp, STInt) -> arithImpl @Add ADD - (STMutez, STMutez) -> arithImpl @Add ADD - (STBls12381Fr, STBls12381Fr) -> arithImpl @Add ADD - (STBls12381G1, STBls12381G1) -> arithImpl @Add ADD - (STBls12381G2, STBls12381G2) -> arithImpl @Add ADD + (STInt, STInt) -> arithImpl @Add AnnADD + (STInt, STNat) -> arithImpl @Add AnnADD + (STNat, STInt) -> arithImpl @Add AnnADD + (STNat, STNat) -> arithImpl @Add AnnADD + (STInt, STTimestamp) -> arithImpl @Add AnnADD + (STTimestamp, STInt) -> arithImpl @Add AnnADD + (STMutez, STMutez) -> arithImpl @Add AnnADD + (STBls12381Fr, STBls12381Fr) -> arithImpl @Add AnnADD + (STBls12381G1, STBls12381G1) -> arithImpl @Add AnnADD + (STBls12381G2, STBls12381G2) -> arithImpl @Add AnnADD _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ NotNumericTypes (demote @a) (demote @b) @@ -868,7 +510,7 @@ ( SingI rs , Each '[SingI] [a, b] , inp ~ (a ': b ': rs) - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) => Sing a -> Sing b @@ -889,30 +531,24 @@ edivImplDo :: ( ArithOp EDiv n m , ArithRes EDiv n m ~ 'TOption ('TPair (EDivOpRes n m) (EModOpRes n m)) - , EDivOp n m , WellTyped (EModOpRes n m) , WellTyped (EDivOpRes n m) , inp ~ (n ': m ': s) - , MonadReader InstrCallStack t - , MonadError TCError t + , MonadReader TypeCheckInstrEnv t ) => HST inp -> VarAnn -> Un.ExpandedInstr -> t (SomeInstr inp) -edivImplDo i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do - case convergeEDiv an bn of - Right cn -> - pure $ i :/ EDIV ::: ((cn, Dict, vn) ::& rs) - Left err -> do - typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err +edivImplDo i@(_ ::& _ ::& rs) vn _ = + pure $ i :/ AnnEDIV (Anns1 vn) ::: ((sing, Dict) ::& rs) subImpl :: forall a b inp rs m. ( Each '[SingI] [a, b] , inp ~ (a ': b ': rs) , SingI rs - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) => Sing a -> Sing b @@ -921,14 +557,14 @@ -> Un.ExpandedInstr -> m (SomeInstr inp) subImpl t1 t2 = case (t1, t2) of - (STInt, STInt) -> arithImpl @Sub SUB - (STInt, STNat) -> arithImpl @Sub SUB - (STNat, STInt) -> arithImpl @Sub SUB - (STNat, STNat) -> arithImpl @Sub SUB - (STTimestamp, STTimestamp) -> arithImpl @Sub SUB + (STInt, STInt) -> arithImpl @Sub AnnSUB + (STInt, STNat) -> arithImpl @Sub AnnSUB + (STNat, STInt) -> arithImpl @Sub AnnSUB + (STNat, STNat) -> arithImpl @Sub AnnSUB + (STTimestamp, STTimestamp) -> arithImpl @Sub AnnSUB (STMutez, STMutez) -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ InvalidInstruction uInstr "Use of SUB on `mutez` operands is deprecated; use SUB_MUTEZ" - (STTimestamp, STInt) -> arithImpl @Sub SUB + (STTimestamp, STInt) -> arithImpl @Sub AnnSUB _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ NotNumericTypes (demote @a) (demote @b) @@ -937,7 +573,7 @@ ( Each '[SingI] [a, b] , inp ~ (a ': b ': rs) , SingI rs - , MonadReader InstrCallStack m + , MonadReader TypeCheckInstrEnv m , MonadError TCError m ) => Sing a -> Sing b @@ -946,19 +582,19 @@ -> Un.ExpandedInstr -> m (SomeInstr inp) mulImpl t1 t2 = case (t1, t2) of - (STInt, STInt) -> arithImpl @Mul MUL - (STInt, STNat) -> arithImpl @Mul MUL - (STNat, STInt) -> arithImpl @Mul MUL - (STNat, STNat) -> arithImpl @Mul MUL - (STNat, STMutez) -> arithImpl @Mul MUL - (STMutez, STNat) -> arithImpl @Mul MUL - (STInt, STBls12381Fr) -> arithImpl @Mul MUL - (STNat, STBls12381Fr) -> arithImpl @Mul MUL - (STBls12381Fr, STInt) -> arithImpl @Mul MUL - (STBls12381Fr, STNat) -> arithImpl @Mul MUL - (STBls12381Fr, STBls12381Fr) -> arithImpl @Mul MUL - (STBls12381G1, STBls12381Fr) -> arithImpl @Mul MUL - (STBls12381G2, STBls12381Fr) -> arithImpl @Mul MUL + (STInt, STInt) -> arithImpl @Mul AnnMUL + (STInt, STNat) -> arithImpl @Mul AnnMUL + (STNat, STInt) -> arithImpl @Mul AnnMUL + (STNat, STNat) -> arithImpl @Mul AnnMUL + (STNat, STMutez) -> arithImpl @Mul AnnMUL + (STMutez, STNat) -> arithImpl @Mul AnnMUL + (STInt, STBls12381Fr) -> arithImpl @Mul AnnMUL + (STNat, STBls12381Fr) -> arithImpl @Mul AnnMUL + (STBls12381Fr, STInt) -> arithImpl @Mul AnnMUL + (STBls12381Fr, STNat) -> arithImpl @Mul AnnMUL + (STBls12381Fr, STBls12381Fr) -> arithImpl @Mul AnnMUL + (STBls12381G1, STBls12381Fr) -> arithImpl @Mul AnnMUL + (STBls12381G2, STBls12381Fr) -> arithImpl @Mul AnnMUL _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ NotNumericTypes (demote @a) (demote @b) @@ -971,10 +607,9 @@ ) => Instr inp (UnaryArithRes aop n ': s) -> HST inp - -> VarAnn -> t (SomeInstr inp) -unaryArithImpl mkInstr i@(_ ::& rs) vn = do - pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs) +unaryArithImpl mkInstr i@(_ ::& rs) = do + pure $ i :/ mkInstr ::: ((sing, Dict) ::& rs) -- | Helper function to construct instructions for unary arithmetic -- operations that should preserve annotations. @@ -986,7 +621,6 @@ ) => Instr inp (UnaryArithRes aop n ': s) -> HST inp - -> VarAnn -> t (SomeInstr inp) -unaryArithImplAnnotated mkInstr i@((n, _, _) ::& rs) vn = do - pure $ i :/ mkInstr ::: ((n, Dict, vn) ::& rs) +unaryArithImplAnnotated mkInstr i@((n, _) ::& rs) = do + pure $ i :/ mkInstr ::: ((n, Dict) ::& rs) diff --git a/src/Morley/Michelson/TypeCheck/Instr.hs b/src/Morley/Michelson/TypeCheck/Instr.hs --- a/src/Morley/Michelson/TypeCheck/Instr.hs +++ b/src/Morley/Michelson/TypeCheck/Instr.hs @@ -18,7 +18,7 @@ -- -- Function @typeCheck@ takes list of instructions and returns value of type -- @Instr inp out@ along with @HST inp@ and @HST out@ all wrapped into --- @SomeInstr@ data type. This wrapping is done to satsify Haskell type +-- @SomeInstr@ data type. This wrapping is done to satisfy Haskell type -- system (which has no support for dependent types). -- Functions @typeCheckInstr@, @typeCheckValue@ behave similarly. -- @@ -32,6 +32,7 @@ , typeCheckContractAndStorage , typeCheckInstr , typeCheckList + , tcList , typeCheckListNoExcept , typeCheckParameter , typeCheckStorage @@ -46,6 +47,7 @@ import Prelude hiding (EQ, GT, LT) +import Control.Lens ((.=)) import Control.Monad.Except (MonadError, catchError, liftEither, throwError) import Data.Constraint ((\\)) import Data.Default (def) @@ -57,7 +59,6 @@ import Data.Typeable ((:~:)(..)) import Fmt (pretty) -import Morley.Michelson.ErrorPos import Morley.Michelson.TypeCheck.Error import Morley.Michelson.TypeCheck.Ext import Morley.Michelson.TypeCheck.Helpers @@ -68,6 +69,7 @@ import Morley.Michelson.TypeCheck.Types import Morley.Michelson.TypeCheck.Value import Morley.Michelson.Typed hiding (Branch(..)) +import Morley.Michelson.Typed.Contract (giveNotInView) import Morley.Util.MismatchError import Morley.Util.Peano @@ -76,7 +78,7 @@ import Morley.Util.Type (knownListFromSingI, onFirst, type (++)) import Morley.Michelson.Untyped qualified as U -import Morley.Michelson.Untyped.Annotation (FieldTag, VarAnn, VarTag, annQ, convAnn, orAnn) +import Morley.Michelson.Untyped.Annotation (VarAnn) import Morley.Util.Peano qualified as Peano -- | Type check a contract and verify that the given storage @@ -120,7 +122,7 @@ withWTPInstr_ v t fn = case getWTP @t of Right Dict -> fn Left (NotWellTyped badType cause) -> do - loc <- ask + loc <- view tcieErrorPos throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause) withWTPInstr'_ @@ -132,7 +134,7 @@ withWTPInstr'_ v t fn = case getWTP @t of Right Dict -> fn Left (NotWellTyped badType cause) -> do - loc <- ask + loc <- view tcieErrorPos let err = TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause) pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx v] @@ -151,17 +153,17 @@ $ checkScope @(ParameterScope param) Dict <- either (hasTypeError @st "storage") pure $ checkScope @(StorageScope st) - let param = [annQ|parameter|] - let store = [annQ|storage|] - let inpNote = NTPair def def def param store paramNote storageNote - let inp = (inpNote, Dict, def) ::& SNil + let inp = (sing @('TPair param st), Dict) ::& SNil -- typecheck contract code codeRes <- usingReaderT def $ liftNoExcept $ - typeCheckImpl typeCheckInstr pCode inp - instr@(inp' :/ instrOut) <- + typeCheckImpl + (giveNotInView $ local (set tcieNotInView $ Just Dict) ... typeCheckInstr) + pCode + inp + instr@(_ :/ instrOut) <- tcsEither onFailedCodeTypeCheck pure codeRes -- typecheck views @@ -171,26 +173,23 @@ handleError (onFailedFullTypeCheck [someInstrToOp instr] (zipWith someViewToOp uViews views)) $ do -- match contract code with contract signature, construct contract - let (paramNotesRaw, cStoreNotes) = case inp' of - (NTPair _ _ _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes) + let cStoreNotes = storageNote cParamNotes <- liftEither $ - mkParamNotes paramNotesRaw rootAnn `onFirst` + mkParamNotes paramNote rootAnn `onFirst` (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl) let cEntriesOrder = entriesOrder cViews <- liftEither $ mkViewsSet views `onFirst` \e -> TCContractError (pretty e) Nothing case instrOut of instr' ::: out -> liftEither $ do - let ret = NTPair def def def def def - (starNotes :: Notes ('TList 'TOperation)) storageNote - case matchHST1 out ret of - Right (Refl, _) -> - pure $ SomeContract Contract{ cCode = instr', .. } + case eqHST1 @('TPair ('TList 'TOperation) st) out of + Right Refl -> + pure $ SomeContract Contract{ cCode = ContractCode instr', .. } Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err AnyOutInstr instr' -> - pure $ SomeContract Contract{ cCode = instr', .. } + pure $ SomeContract Contract{ cCode = ContractCode instr', .. } where hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a @@ -250,7 +249,7 @@ , U.viewName = viewName } = withWTP @param $ withWTP @ret $ do - let inp = (NTPair def def def def def argNote storageNote, Dict, def) ::& SNil + let inp = (STPair (notesSing argNote) (notesSing storageNote), Dict) ::& SNil Dict <- checkScope @(ViewableScope param) & either (hasTypeError @param "parameter") pure @@ -269,7 +268,7 @@ vReturn = returnNote case instrOut of instr ::: out -> liftEither do - (Refl, _) <- matchHST1 out returnNote + Refl <- eqHST1 @ret out `onFirst` (TCViewError "view return type mismatch:" viewName . Just) return $ SomeView View{ vCode = instr, .. } AnyOutInstr instr -> @@ -318,7 +317,7 @@ -- given in representation from @Morley.Michelson.Type@ module to representation -- in strictly typed GADT. -- --- Types are checked along the way which is neccessary to construct a +-- Types are checked along the way which is necessary to construct a -- strictly typed value. -- -- As a second argument, @typeCheckList@ accepts input stack type representation. @@ -356,7 +355,12 @@ :: forall t. SingI t => U.Value -> TypeCheckInstr (Value t) -typeCheckValue = typeCheckValImpl @t Nothing typeCheckInstr +typeCheckValue value = do + mode <- use tcModeL + tcModeL .= TypeCheckValue (value, demote @t) + res <- typeCheckValImpl @t Nothing typeCheckInstr value + tcModeL .= mode + pure res typeVerifyParameter :: SingI t @@ -472,11 +476,11 @@ (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr]) (pure . WellTypedSeq) --- | Less verbose version of `lift ... typeCheckListNoExcept`. +-- | Less verbose version of `typeCheckImpl typeCheckInstr`. tcList :: (SingI inp) => [U.ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) -tcList ops stack = lift $ typeCheckListNoExcept ops stack +tcList = typeCheckImpl typeCheckInstr -- | Function @typeCheckInstr@ converts a single Michelson instruction -- given in representation from @Morley.Michelson.Type@ module to representation @@ -486,7 +490,7 @@ -- -- Type checking algorithm pattern-matches on given instruction, input stack -- type and constructs strictly typed GADT value, checking necessary type --- equalities when neccessary. +-- equalities when necessary. -- -- If there was no match on a given pair of instruction and input stack, -- that is interpreted as input of wrong type and type check finishes with @@ -516,16 +520,16 @@ (n, (_ ::& iTail)) -> do go (n - 1) iTail <&> \(TCDropHelper s out) -> TCDropHelper (Succ s) out - (U.DUP vn1, a@(n :: Notes t, d, _vn2) ::& rs) -> workOnInstr uInstr $ do + (U.DUP vn1, a@(n :: SingT t, d) ::& rs) -> workOnInstr uInstr $ do Dict <- onScopeCheckInstrErr @t uInstr (SomeHST inp) Nothing $ checkScope @(DupableScope t) - pure (inp :/ DUP ::: ((n, d, vn1) ::& a ::& rs)) + pure (inp :/ AnnDUP (Anns1 vn1) ::: ((n, d) ::& a ::& rs)) (U.DUP _vn, SNil) -> notEnoughItemsOnStack (U.DUPN vn nTotal, inputHST) -> workOnInstr uInstr $ - go nTotal inputHST <&> \(TCDupNHelper s out) -> inputHST :/ DUPN s ::: out + go nTotal inputHST <&> \(TCDupNHelper s out) -> inputHST :/ AnnDUPN (Anns1 vn) s ::: out where go :: forall inp. SingI inp => Word @@ -539,11 +543,11 @@ -- Don't bind whatever variable annotation is here because DUP n doesn't -- duplicate variable annotations. This is consistent with tezos-client. - (1, i@((an :: Notes a, dict, _) ::& _)) -> do + (1, i@((an :: SingT a, dict) ::& _)) -> do Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing $ checkScope @(DupableScope a) - pure (TCDupNHelper One ((an, dict, vn) ::& i)) + pure (TCDupNHelper One ((an, dict) ::& i)) (n, (b ::& iTail)) -> go (n - 1) iTail <&> \(TCDupNHelper s@(Succ _) (a ::& resTail)) -> @@ -596,51 +600,45 @@ proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST i) Nothing $ checkScope @(ConstantScope t) case proofScope of - Dict -> withWTPInstr @t $ pure $ i :/ PUSH val ::: ((nt, Dict, vn) ::& i) + Dict -> withWTPInstr @t $ pure $ + i :/ AnnPUSH (Anns2' vn nt) val ::: ((notesSing nt, Dict) ::& i) - (U.SOME tn vn, (an, Dict, _) ::& rs) -> workOnInstr uInstr $ - pure (inp :/ SOME ::: ((NTOption tn an, Dict, vn) ::& rs)) + (U.SOME tn vn, (an, Dict) ::& rs) -> workOnInstr uInstr $ + pure (inp :/ AnnSOME (Anns2 tn vn) ::: ((STOption an, Dict) ::& rs)) (U.SOME _ _, SNil) -> notEnoughItemsOnStack (U.NONE tn vn elMt, _) -> workOnInstr uInstr $ withUType elMt $ \(elNotes :: Notes t) -> withWTPInstr @t $ - pure $ inp :/ NONE ::: ((NTOption tn elNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnNONE (Anns3' tn vn elNotes) ::: ((STOption (notesSing elNotes), Dict) ::& inp) (U.UNIT tn vn, _) -> workOnInstr uInstr $ - pure $ inp :/ UNIT ::: ((NTUnit tn, Dict, vn) ::& inp) + pure $ inp :/ AnnUNIT (Anns2 tn vn) ::: ((STUnit, Dict) ::& inp) - (U.IF_NONE mp mq, (STOption{}, (ons :: Notes ('TOption a)), Dict, ovn) ::&+ rs) -> do - let (an, avn) = deriveNsOption ons ovn + (U.MIN_BLOCK_TIME vn, _) -> workOnInstr uInstr $ + pure $ inp :/ AnnMIN_BLOCK_TIME vn ::: ((STNat, Dict) ::& inp) + + (U.IF_NONE mp mq, (STOption (asing :: SingT a), Dict) ::& rs) -> withWTPInstr' @a $ - genericIf IF_NONE U.IF_NONE mp mq rs ((an, Dict, avn) ::& rs) inp + genericIf IF_NONE U.IF_NONE mp mq rs ((asing, Dict) ::& rs) inp (U.IF_NONE _ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("option 'a" :| []) :| [] (U.IF_NONE _ _, SNil) -> notEnoughItemsOnStack - (U.PAIR tn vn pfn qfn, (an :: Notes a, _, avn) ::& (bn :: Notes b, _, bvn) ::& rs) -> workOnInstr uInstr $ do - let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn vn + (U.PAIR tn vn pfn qfn, (an :: SingT a, _) ::& (bn :: SingT b, _) ::& rs) -> workOnInstr uInstr $ withWTPInstr @('TPair a b) $ - pure (inp :/ AnnPAIR tn pfn qfn ::: ((NTPair tn pfn' qfn' avn bvn an bn, Dict, vn') ::& rs)) + pure (inp :/ AnnPAIR (Anns4 tn vn pfn qfn) ::: ((STPair an bn, Dict) ::& rs)) (U.PAIR {}, _) -> notEnoughItemsOnStack - (U.UNPAIR instrVn1 instrVn2 instrFn1 instrFn2, (NTPair _ fn1 fn2 vn1 vn2 n1 n2, Dict, vn) ::& rs) -> + (U.UNPAIR instrVn1 instrVn2 instrFn1 instrFn2, (STPair n1 n2, Dict) ::& rs) -> workOnInstr uInstr $ do - -- We purposefully ignore the result of `convergeDestrAnns` here. - -- We're only interested in checking that the instruction's field ann matches the pair's field ann, - -- we don't need to "unify" them. - _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn1 instrFn1) - _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn2 instrFn2) - - let vn1' = deriveSpecialVN instrVn1 fn1 vn vn1 - let vn2' = deriveSpecialVN instrVn2 fn2 vn vn2 pure $ - inp :/ AnnUNPAIR instrVn1 instrVn2 instrFn1 instrFn2 ::: - ( (n1, Dict, vn1') ::& - (n2, Dict, vn2') ::& + inp :/ AnnUNPAIR (Anns4 instrVn1 instrVn2 instrFn1 instrFn2) ::: + ( (n1, Dict) ::& + (n2, Dict) ::& rs ) @@ -650,7 +648,7 @@ (U.UNPAIR {}, _) -> notEnoughItemsOnStack (U.PAIRN varAnn nTotal, _) -> workOnInstr uInstr $ do go nTotal inp <&> \case - TCPairNHelper s out -> inp :/ PAIRN s ::: addVarAnn out + TCPairNHelper s out -> inp :/ AnnPAIRN (Anns1 varAnn) s ::: out where go :: forall inp. Word -> HST inp -> TypeCheckInstr (TCPairNHelper inp) go n hst @@ -659,38 +657,21 @@ (InvalidInstruction uInstr "'PAIR n' expects n ≥ 2") | n == 2 = case hst of - (an :: Notes a, _, _) ::& (bn :: Notes b, _, _) ::& hstTail -> do + (an :: SingT a, _) ::& (bn :: SingT b, _) ::& hstTail -> do withWTPInstr @('TPair a b) $ do pure $ TCPairNHelper Two $ - (mkNotes an bn, Dict, U.noAnn) ::& hstTail + (STPair an bn, Dict) ::& hstTail _ -> notEnoughItemsOnStack' | otherwise = case hst of - (an :: Notes a, _, _) ::& hstTail@(_ ::& _ ::& _) -> do + (an :: SingT a, _) ::& hstTail@(_ ::& _ ::& _) -> do go (n - 1) hstTail >>= \case - TCPairNHelper nSing@(Succ (Succ _)) ((bn :: Notes b, _, _) ::& hstTail') -> do + TCPairNHelper nSing@(Succ (Succ _)) ((bn :: SingT b, _) ::& hstTail') -> do withWTPInstr @('TPair a b) $ do pure $ TCPairNHelper (Succ nSing) $ - (mkNotes an bn, Dict, U.noAnn) ::& hstTail' + (STPair an bn, Dict) ::& hstTail' _ -> notEnoughItemsOnStack' - mkNotes :: forall a b. Notes a -> Notes b -> Notes ('TPair a b) - mkNotes an bn = - NTPair U.noAnn - U.noAnn U.noAnn - U.noAnn U.noAnn - an bn - - -- | If a @PAIR n@ instruction has a variable annotation, - -- the var annotation should be added ONLY to the top-most @pair@ value. - -- - -- > /* [ nat : nat : nat ] */ ; - -- > PAIR @aa 3 - -- > /* [ @aa pair nat nat nat ] */ ; - addVarAnn :: forall a inp. HST (a ': inp) -> HST (a ': inp) - addVarAnn = \case - (an, dict, _) ::& hstTail -> (an, dict, varAnn) ::& hstTail - (U.UNPAIRN _, SNil) -> notEnoughItemsOnStack (U.UNPAIRN nTotal, _ ::& _) -> workOnInstr uInstr $ do go nTotal inp <&> \case @@ -704,77 +685,64 @@ (InvalidInstruction uInstr "UNPAIR expects an argument of at least 2.") | n == 2 = case hst of - (NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes, Dict, _) ::& rest -> do + (STPair aT bT, Dict) ::& rest -> do pure $ TCUnpairNHelper Two $ - (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn) - ::& (bNotes, Dict, convAnn @FieldTag @VarTag bFieldAnn) + (aT, Dict) + ::& (bT, Dict) ::& rest _ -> unexpectedType | otherwise = case hst of - (NTPair _ aFieldAnn _ _ _ aNotes bNotes, Dict, _) ::& rest -> do - go (n - 1) ((bNotes, Dict, U.noAnn) ::& rest) >>= \case + (STPair aT bT, Dict) ::& rest -> do + go (n - 1) ((bT, Dict) ::& rest) >>= \case TCUnpairNHelper nSing@(Succ (Succ _)) out -> do pure $ TCUnpairNHelper (Succ nSing) $ - (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn) ::& out + (aT, Dict) ::& out _ -> unexpectedType unexpectedType :: TypeCheckInstr a unexpectedType = failWithErr' $ UnexpectedType $ (pairWithElems nTotal :| []) :| [] - (U.CAR vn fn, (STPair{}, NTPair _ pfn _ pvn _ pns _, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do - -- We purposefully ignore the result of `convergeDestrAnns` here. - -- We're only interested in checking that the instruction's field ann matches the pair's field ann, - -- we don't need to "unify" them. - _ <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeDestrAnns fn pfn) - let vn' = deriveSpecialVN vn pfn pairVN pvn - pure $ inp :/ AnnCAR vn fn ::: ((pns, Dict, vn') ::& rs) + (U.CAR vn fn, (STPair lt _, Dict) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnCAR (Anns2 vn fn) ::: ((lt, Dict) ::& rs) (U.CAR _ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| [] (U.CAR _ _, SNil) -> notEnoughItemsOnStack - (U.CDR vn fn, (STPair{}, NTPair _ _ qfn _ qvn _ qns, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do - -- We purposefully ignore the result of `convergeDestrAnns` here. - -- We're only interested in checking that the instruction's field ann matches the pair's field ann, - -- we don't need to "unify" them. - _ <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeDestrAnns fn qfn) - let vn' = deriveSpecialVN vn qfn pairVN qvn - pure $ inp :/ AnnCDR vn fn ::: ((qns, Dict, vn') ::& rs) + (U.CDR vn fn, (STPair _ rt, Dict) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnCDR (Anns2 vn fn) ::: ((rt, Dict) ::& rs) (U.CDR _ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| [] (U.CDR _ _, SNil) -> notEnoughItemsOnStack - (U.LEFT tn vn pfn qfn bMt, (an :: Notes l, Dict, avn) ::& rs) -> + (U.LEFT tn vn pfn qfn bMt, (an :: SingT l, Dict) ::& rs) -> withUType bMt $ \(bn :: Notes r) -> workOnInstr uInstr $ do - let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn U.noAnn vn withWTPInstr @r $ do - let ns = NTOr tn pfn' qfn' an bn - pure (inp :/ AnnLEFT tn pfn qfn ::: ((ns, Dict, vn') ::& rs)) + let ns = STOr an (notesSing bn) + pure (inp :/ AnnLEFT (Anns5' tn vn pfn qfn bn) ::: ((ns, Dict) ::& rs)) (U.LEFT {}, SNil) -> notEnoughItemsOnStack - (U.RIGHT tn vn pfn qfn aMt, (bn :: Notes r, Dict, bvn) ::& rs) -> + (U.RIGHT tn vn pfn qfn aMt, (bn :: SingT r, Dict) ::& rs) -> withUType aMt $ \(an :: Notes l) -> workOnInstr uInstr $ do - let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn U.noAnn bvn vn withWTPInstr @l $ do - let ns = NTOr tn pfn' qfn' an bn - pure (inp :/ AnnRIGHT tn pfn qfn ::: ((ns, Dict, vn') ::& rs)) + let ns = STOr (notesSing an) bn + pure (inp :/ AnnRIGHT (Anns5' tn vn pfn qfn an) ::: ((ns, Dict) ::& rs)) (U.RIGHT {}, SNil) -> notEnoughItemsOnStack - (U.IF_LEFT mp mq, (STOr lt rt, ons, _, ovn) ::&+ rs) -> do - case deriveNsOr ons ovn of - (an :: Notes a, bn :: Notes b, avn, bvn) -> withSingI lt $ withSingI rt $ - withWTPInstr' @a $ - withWTPInstr' @b $ do - let - ait = (an, Dict, avn) ::& rs - bit = (bn, Dict, bvn) ::& rs - genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp + (U.IF_LEFT mp mq, (STOr (lt :: SingT l) (rt :: SingT r), _) ::& rs) -> do + withSingI lt $ withSingI rt $ + withWTPInstr' @l $ + withWTPInstr' @r $ do + let + ait = (lt, Dict) ::& rs + bit = (rt, Dict) ::& rs + genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp (U.IF_LEFT _ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("or 'a 'b" :| []) :| [] @@ -784,35 +752,32 @@ (U.NIL tn vn elMt, i) -> workOnInstr uInstr $ withUType elMt $ \(elNotes :: Notes t) -> withWTPInstr @('TList t) $ - pure $ i :/ NIL ::: ((NTList tn elNotes, Dict, vn) ::& i) + pure $ i :/ AnnNIL (Anns3' tn vn elNotes) ::: ((STList (notesSing elNotes), Dict) ::& i) - (U.CONS vn, ((an :: Notes a), _, _) - ::& ((ln :: Notes l), _, _) ::& rs) -> workOnInstr uInstr + (U.CONS vn, ((_ :: SingT a), _) ::& ((ln :: SingT l), _) ::& rs) -> workOnInstr uInstr case eqType @('TList a) @l of Right Refl -> do - (n :: Notes t) <- onTypeCheckInstrAnnErr uInstr inp (Just ConsArgument) (converge ln (NTList def an)) - withWTPInstr @t $ - pure $ inp :/ CONS ::: ((n, Dict, vn) ::& rs) + withWTPInstr @('TList l) $ + pure $ inp :/ AnnCONS (Anns1 vn) ::: ((ln, Dict) ::& rs) Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just ConsArgument) m (U.CONS _, _) -> notEnoughItemsOnStack - (U.IF_CONS mp mq, (STList{}, ns, Dict, vn) ::&+ rs) -> do - case ns of - NTList _ (an :: Notes t1) -> withWTPInstr' @t1 $ do - let ait = (an, Dict, vn) ::& (ns, Dict, vn) ::& rs - genericIf IF_CONS U.IF_CONS mp mq ait rs inp + (U.IF_CONS mp mq, (ns@(STList (an :: SingT t1)), Dict) ::& rs) -> do + withWTPInstr' @t1 $ do + let ait = (an, Dict) ::& (ns, Dict) ::& rs + genericIf IF_CONS U.IF_CONS mp mq ait rs inp (U.IF_CONS _ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("list 'a" :| []) :| [] (U.IF_CONS _ _, SNil)-> notEnoughItemsOnStack - (U.SIZE vn, (NTList{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn - (U.SIZE vn, (NTSet{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn - (U.SIZE vn, (NTMap{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn - (U.SIZE vn, (NTString{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn - (U.SIZE vn, (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn + (U.SIZE vn, (STList{}, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn + (U.SIZE vn, (STSet{}, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn + (U.SIZE vn, (STMap{}, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn + (U.SIZE vn, (STString{}, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn + (U.SIZE vn, (STBytes{}, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn (U.SIZE _, _ ::& _) -> failWithErr $ UnexpectedType $ ("list 'a" :| []) :| @@ -827,36 +792,37 @@ (U.EMPTY_SET tn vn mv, i) -> workOnInstr uInstr $ withUType mv $ \(vns :: Notes v) -> withWTPInstr @('TSet v) $ - withCompareableCheck (notesSing vns) uInstr inp $ i :/ EMPTY_SET ::: ((STSet sing, NTSet tn vns, Dict, vn) ::&+ i) + withCompareableCheck (notesSing vns) uInstr inp $ + i :/ AnnEMPTY_SET (Anns3' tn vn vns) ::: ((STSet (notesSing vns), Dict) ::& i) (U.EMPTY_MAP tn vn mk mv, i) -> workOnInstr uInstr $ do withUType mv $ \(vns :: Notes v) -> withUType mk $ \(ktn :: Notes k) -> withWTPInstr @('TMap k v) $ - withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_MAP ::: ((STMap sing sing, NTMap tn ktn vns, Dict, vn) ::&+ i) + withCompareableCheck (notesSing ktn) uInstr inp $ + i :/ AnnEMPTY_MAP (Anns4'' tn vn ktn vns) ::: ((STMap (notesSing ktn) (notesSing vns), Dict) ::& i) (U.EMPTY_BIG_MAP tn vn mk mv, i) -> workOnInstr uInstr $ withUType mv $ \(vns :: Notes v) -> withUType mk $ \(ktn :: Notes k) -> withWTPInstr @('TBigMap k v) $ - withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_BIG_MAP ::: ((STBigMap sing sing, NTBigMap tn ktn vns, Dict, vn) ::&+ i) + withCompareableCheck (notesSing ktn) uInstr inp $ + i :/ AnnEMPTY_BIG_MAP (Anns4'' tn vn ktn vns) ::: ((STBigMap (notesSing ktn) (notesSing vns), Dict) ::& i) - (U.MAP vn mp, (STList l, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> withSingI l $ do + (U.MAP vn mp, (STList (vns :: SingT t1), Dict) ::& _) -> withSingI vns $ do withWTPInstr' @t1 $ - mapImpl (U.MAP vn) vns uInstr mp inp - (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $ (NTList def rn, Dict, vn) ::& hst) + mapImpl (U.MAP vn) vns vn uInstr mp inp + (\(rn :: SingT t) hst -> withWTPInstr @t $ pure $ (STList rn, Dict) ::& hst) - (U.MAP vn mp, (STOption l, NTOption _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> withSingI l $ do + (U.MAP vn mp, (STOption (vns :: SingT t1), Dict) ::& _) -> withSingI vns $ do withWTPInstr' @t1 $ - mapImpl (U.MAP vn) vns uInstr mp inp - (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $ (NTOption def rn, Dict, vn) ::& hst) + mapImpl (U.MAP vn) vns vn uInstr mp inp + (\(rn :: SingT t) hst -> withWTPInstr @t $ pure $ (STOption rn, Dict) ::& hst) - (U.MAP vn mp, (STMap k v, NTMap _ kns vns, Dict, _vn) ::&+ _) -> withSingI k $ withSingI v $ do - case NTPair def def def def def kns vns of - (pns :: Notes ('TPair k v1)) -> - withWTPInstr' @('TPair k v1) $ - mapImpl (U.MAP vn) pns uInstr mp inp - (\(rn :: Notes v) hst -> withWTPInstr @('TMap k v) $ pure $ (NTMap def kns rn, Dict, vn) ::& hst) + (U.MAP vn mp, (STMap (k :: SingT k) (v :: SingT v1), Dict) ::& _) -> withSingI k $ withSingI v $ do + withWTPInstr' @('TPair k v1) $ + mapImpl (U.MAP vn) (STPair k v) vn uInstr mp inp + (\(rn :: SingT v) hst -> withWTPInstr @('TMap k v) $ pure $ (STMap k rn, Dict) ::& hst) (U.MAP _ _, _ ::& _) -> failWithErr $ UnexpectedType @@ -867,18 +833,16 @@ (U.MAP _ _, SNil) -> notEnoughItemsOnStack - (U.ITER is, (STSet (s :: Sing t1), NTSet _ en, _, _) ::&+ _) -> withSingI s $ do + (U.ITER is, (STSet (s :: Sing t1), _) ::& _) -> withSingI s $ do withWTPInstr' @t1 $ - iterImpl en uInstr is inp + iterImpl s uInstr is inp - (U.ITER is, (STList (l :: Sing t1), NTList _ en, _, _) ::&+ _) -> withSingI l $ do + (U.ITER is, (STList (l :: Sing t1), _) ::& _) -> withSingI l $ do withWTPInstr' @t1 $ - iterImpl en uInstr is inp + iterImpl l uInstr is inp - (U.ITER is, (STMap k v, NTMap _ kns vns, _, _) ::&+ _) -> withSingI k $ withSingI v $ do - case NTPair def def def def def kns vns of - (en :: Notes ('TPair a b)) -> - withWTPInstr' @('TPair a b) $ iterImpl en uInstr is inp + (U.ITER is, (STMap (k :: SingT a) (v :: SingT b), _) ::& _) -> withSingI k $ withSingI v $ do + withWTPInstr' @('TPair a b) $ iterImpl (STPair k v) uInstr is inp (U.ITER _, _ ::& _) -> failWithErr $ UnexpectedType @@ -890,16 +854,16 @@ (U.ITER _, SNil) -> notEnoughItemsOnStack (U.MEM varNotes, - _ ::& (STSet s, NTSet _ notesK, _, _) ::&+ _) -> withSingI s $ workOnInstr uInstr $ - memImpl notesK inp varNotes + _ ::& (STSet s, _) ::& _) -> withSingI s $ workOnInstr uInstr $ + memImpl inp varNotes (U.MEM varNotes, - _ ::& (STMap k v, NTMap _ notesK _, _, _) ::&+ _) -> + _ ::& (STMap k v, _) ::& _) -> withSingI k $ withSingI v $ workOnInstr uInstr $ - memImpl notesK inp varNotes + memImpl inp varNotes (U.MEM varNotes, - _ ::& (STBigMap k v, NTBigMap _ notesK _, _, _) ::&+ _) -> + _ ::& (STBigMap k v, _) ::& _) -> withSingI k $ withSingI v $ workOnInstr uInstr $ - memImpl notesK inp varNotes + memImpl inp varNotes (U.MEM _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("'a" :| ["set 'a"]) :| @@ -910,13 +874,13 @@ (U.MEM _, _) -> notEnoughItemsOnStack (U.GET varNotes, - _ ::& (STMap k v, NTMap _ notesK (notesV :: Notes v), _, _) ::&+ _) -> + _ ::& (STMap k (v :: SingT v), _) ::& _) -> withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $ - getImpl notesK inp notesV varNotes + getImpl inp v varNotes (U.GET varNotes, - _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) -> + _ ::& (STBigMap k (v :: SingT v), _) ::& _) -> withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $ - getImpl notesK inp notesV varNotes + getImpl inp v varNotes (U.GET _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType @@ -930,27 +894,27 @@ (U.GETN getNVarAnn ix0, _ ::& _) -> workOnInstr uInstr $ do go ix0 inp <&> \case TCGetNHelper s out -> - inp :/ GETN s ::: out + inp :/ AnnGETN (Anns1 getNVarAnn) s ::: out where go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCGetNHelper (x : xs)) - go 0 ((a, Dict, _) ::& rest) = - pure $ TCGetNHelper Zero ((a, Dict, getNVarAnn) ::& rest) - go 1 ((NTPair _ _ _ _ _ leftNotes _, Dict, _) ::& rest) = - pure $ TCGetNHelper One $ (leftNotes, Dict, getNVarAnn) ::& rest - go ix ((NTPair _ _ _ _ _ _ rightNotes, Dict, _) ::& rest) = - go (ix - 2) ((rightNotes, Dict, U.noAnn) ::& rest) <&> \(TCGetNHelper ixSing out) -> + go 0 ((a, Dict) ::& rest) = + pure $ TCGetNHelper Zero ((a, Dict) ::& rest) + go 1 ((STPair leftNotes _, Dict) ::& rest) = + pure $ TCGetNHelper One $ (leftNotes, Dict) ::& rest + go ix ((STPair _ rightNotes, Dict) ::& rest) = + go (ix - 2) ((rightNotes, Dict) ::& rest) <&> \(TCGetNHelper ixSing out) -> TCGetNHelper (Succ (Succ ixSing)) out go _ _ = failWithErr' $ UnexpectedType $ (pairWithNodeIndex ix0 :| []) :| [] (U.UPDATE varAnn, - _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) -> - withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn + _ ::& _ ::& (STMap k v, _) ::& _) -> + withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl inp varAnn (U.UPDATE varAnn, - _ ::& _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) -> - withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn + _ ::& _ ::& (STBigMap k v, _) ::& _) -> + withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl inp varAnn (U.UPDATE varAnn, - _ ::& _ ::& (STSet s, NTSet _ (notesK :: Notes k), _, _) ::&+ _) -> - withSingI s $ workOnInstr uInstr $ updImpl notesK inp (NTBool U.noAnn) varAnn + _ ::& _ ::& (STSet s, _) ::& _) -> + withSingI s $ workOnInstr uInstr $ updImpl inp varAnn (U.UPDATE _, _ ::& _ ::& _ ::& _) -> failWithErr $ UnexpectedType @@ -964,33 +928,33 @@ (U.UPDATEN updateNVarAnn ix0, _ ::& _ ::& _) -> workOnInstr uInstr $ do go ix0 inp <&> \case TCUpdateNHelper s out -> - inp :/ UPDATEN s ::: out + inp :/ AnnUPDATEN (Anns1 updateNVarAnn) s ::: out where go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr (TCUpdateNHelper (val : pair : rest)) - go 0 ((valNotes, Dict, _) ::& (_, _, _) ::& rest) = + go 0 ((valNotes, Dict) ::& (_, _) ::& rest) = pure $ TCUpdateNHelper Zero $ - (valNotes, Dict, updateNVarAnn) ::& rest - go 1 ((valNotes, Dict, _) ::& (NTPair pairTA leftFA rightFA leftVA rightVA _ rightNotes, Dict, _) ::& rest) = + (valNotes, Dict) ::& rest + go 1 ((valNotes, Dict) ::& (STPair _ rightNotes, Dict) ::& rest) = pure $ TCUpdateNHelper One $ - (NTPair pairTA leftFA rightFA leftVA rightVA valNotes rightNotes, Dict, updateNVarAnn) ::& rest - go ix (val ::& (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes rightNotes, Dict, _) ::& rest) = - go (ix - 2) (val ::& (rightNotes, Dict, U.noAnn) ::& rest) <&> - \(TCUpdateNHelper ixSing ((updatedRightNotes, Dict, _) ::& outRest)) -> + (STPair valNotes rightNotes, Dict) ::& rest + go ix (val ::& (STPair leftNotes rightNotes, Dict) ::& rest) = + go (ix - 2) (val ::& (rightNotes, Dict) ::& rest) <&> + \(TCUpdateNHelper ixSing ((updatedRightNotes, Dict) ::& outRest)) -> TCUpdateNHelper (Succ (Succ ixSing)) $ - (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes updatedRightNotes, Dict, updateNVarAnn) ::& outRest + (STPair leftNotes updatedRightNotes, Dict) ::& outRest go _ _ = failWithErr' $ UnexpectedType $ ("'val" :| [pairWithNodeIndex ix0]) :| [] (U.UPDATEN _ _, _) -> notEnoughItemsOnStack (U.GET_AND_UPDATE varAnn, - _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) -> + _ ::& _ ::& (STMap k (v :: SingT v), _) ::& _) -> withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $ - getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn + getUpdImpl inp varAnn (U.GET_AND_UPDATE varAnn, - _ ::& _ ::& (STBigMap k v, (NTBigMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) -> + _ ::& _ ::& (STBigMap k (v :: SingT v), _) ::& _) -> withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $ - getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn + getUpdImpl inp varAnn (U.GET_AND_UPDATE _, _ ::& _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("'k" :| ["option 'v", "map 'k 'v"]) :| @@ -998,7 +962,7 @@ ] (U.GET_AND_UPDATE _, _) -> notEnoughItemsOnStack - (U.IF mp mq, (NTBool{}, _, _) ::& rs) -> + (U.IF mp mq, (STBool{}, _) ::& rs) -> genericIf IF U.IF mp mq rs rs inp (U.IF _ _, _ ::& _) -> @@ -1006,7 +970,7 @@ (U.IF _ _, SNil) -> notEnoughItemsOnStack - (U.LOOP is, (NTBool{}, _, _) ::& (rs :: HST rs)) -> do + (U.LOOP is, (STBool{}, _) ::& (rs :: HST rs)) -> do preserving (tcList is rs) U.LOOP $ \(_ :/ tp) -> case tp of subI ::: (o :: HST o) -> do @@ -1022,25 +986,19 @@ (U.LOOP _, _) -> notEnoughItemsOnStack - (U.LOOP_LEFT is, (os@STOr{}, ons, Dict, ovn) ::&+ rs) -> do - case deriveNsOr ons ovn of - (an :: Notes t, bn :: Notes b, avn, bvn) -> do - withWTPInstr' @t $ withWTPInstr' @b $ do - let ait = (an, Dict, avn) ::& rs - preserving (tcList is ait) U.LOOP_LEFT $ \(_ :/ tp) -> - case tp of - subI ::: o -> do - case (eqHST o (os -:& rs), o) of - (Right Refl, ((ons', Dict, ovn') ::& rs')) -> do - let (_, bn', _, bvn') = deriveNsOr ons' ovn' - br <- onTypeCheckInstrAnnErr uInstr inp - (Just Iteration) - (convergeHSTEl (bn, Dict, bvn) (bn', Dict, bvn')) - pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs') - (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m - AnyOutInstr subI -> do - let br = (bn, Dict, bvn) - pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs) + (U.LOOP_LEFT is, (os@(STOr (an :: SingT t) (bn :: SingT b)), Dict) ::& rs) -> do + withWTPInstr' @t $ withWTPInstr' @b $ do + let ait = (an, Dict) ::& rs + preserving (tcList is ait) U.LOOP_LEFT $ \(_ :/ tp) -> + case tp of + subI ::: o -> do + case (eqHST o (os -:& rs), o) of + (Right Refl, (_, Dict) ::& rs') -> + pure $ inp :/ LOOP_LEFT subI ::: ((bn, Dict) ::& rs') + (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m + AnyOutInstr subI -> do + let br = (bn, Dict) + pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs) (U.LOOP_LEFT _, _ ::& _) -> failWithErr $ UnexpectedType @@ -1053,21 +1011,15 @@ -- litter our main typechecking logic withWTPInstr' @t $ withWTPInstr' @u $ - lamImpl (U.LAMBDA vn p1 p2) uInstr is vn ins ons i + lamImpl (U.LAMBDA vn p1 p2) (Anns3'' vn ins ons) uInstr is (notesSing ins) (notesSing ons) i - (U.EXEC vn, ((tn :: Notes t1), _, _) - ::& ( STLambda v b - , NTLambda _ (t1n :: Notes t1') (t2n :: Notes t2') - , _ - , _ - ) - ::&+ rs) -> withSingI v $ withSingI b $ workOnInstr uInstr $ do - Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument) - (eqType @t1 @t1') - (Refl, _) <- errM $ matchTypes tn t1n - withWTPInstr @t2' $ pure $ inp :/ EXEC ::: ((t2n, Dict, vn) ::& rs) + (U.EXEC vn, ((_ :: SingT t1), _) + ::& ( STLambda (v :: SingT t1') (b :: SingT t2'), _) + ::& rs) -> withSingI v $ withSingI b $ workOnInstr uInstr $ do + Refl <- errM $ eqType @t1 @t1' + withWTPInstr @t2' $ pure $ inp :/ AnnEXEC (Anns1 vn) ::: ((b, Dict) ::& rs) where - errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a + errM :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Either TCTypeError a -> m a errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument) (U.EXEC _, _ ::& _ ::& _) -> @@ -1076,22 +1028,17 @@ (U.EXEC _, _) -> notEnoughItemsOnStack - (U.APPLY vn, ((_ :: Notes a'), _, _) - ::& ( STLambda (STPair lt rt) b - , NTLambda vann (NTPair _ _ _ _ _ (_ :: Notes a) (nb :: Notes b)) sc - , _ - , _) - ::&+ rs) -> withSingI lt $ withSingI rt $ withSingI b $ workOnInstr uInstr $ do - case NTLambda vann nb sc of - (l2n :: Notes ('TLambda t1 t2)) -> withWTPInstr @('TLambda t1 t2) $ do - - proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument) - (eqType @a' @a) - proofScope <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just LambdaArgument) - $ checkScope @(ConstantScope a) - case (proofArgEq, proofScope) of - (Refl, Dict) -> - pure $ inp :/ (APPLY @a) ::: ((l2n, Dict, vn) ::& rs) + (U.APPLY vn, ((_ :: SingT a'), _) + ::& ( STLambda (STPair (lt :: SingT a) (rt :: SingT b) :: SingT t1) (b :: SingT t2), _) + ::& rs) -> withSingI lt $ withSingI rt $ withSingI b $ workOnInstr uInstr $ do + withWTPInstr @('TLambda t1 t2) $ do + proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument) + (eqType @a' @a) + proofScope <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just LambdaArgument) + $ checkScope @(ConstantScope a) + case (proofArgEq, proofScope) of + (Refl, Dict) -> + pure $ inp :/ AnnAPPLY @a (Anns1 vn) ::: ((STLambda rt b, Dict) ::& rs) (U.APPLY _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType @@ -1120,7 +1067,7 @@ (TCDipHelperErr) (TCDipHelperOk Zero) (_, SNil) -> do - pos <- ask + pos <- view tcieErrorPos let err = TCFailedOnInstr uInstr (SomeHST inp) pos Nothing (Just NotEnoughItemsOnStack) pure $ TCDipHelperErr err [NonTypedInstr $ U.PrimEx uInstr] (_, hstHead ::& hstTail) -> @@ -1128,56 +1075,56 @@ TCDipHelperOk s subI out -> TCDipHelperOk (Succ s) subI (hstHead ::& out) TCDipHelperErr err rest -> TCDipHelperErr err rest - (U.FAILWITH, ((_ :: Notes a, _, _) ::& _)) -> workOnInstr uInstr $ do + (U.FAILWITH, ((_ :: SingT a, _) ::& _)) -> workOnInstr uInstr $ do Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just FailwithArgument) $ checkScope @(ConstantScope a) pure $ inp :/ AnyOutInstr FAILWITH (U.FAILWITH, _) -> notEnoughItemsOnStack - (U.CAST vn (AsUType (castToNotes :: Notes t)), (en, _, evn) ::& rs) -> + (U.CAST vn (AsUType (castToNotes :: Notes t)), (_ :: SingT t1, _) ::& rs) -> workOnInstr uInstr $ do - (Refl, _) <- errM $ matchTypes en castToNotes + Refl <- errM $ eqType @t @t1 withWTPInstr @t $ - pure $ inp :/ CAST ::: ((castToNotes, Dict, vn `orAnn` evn) ::& rs) + pure $ inp :/ AnnCAST (Anns2' vn castToNotes) ::: ((notesSing castToNotes, Dict) ::& rs) where - errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a + errM :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Either TCTypeError a -> m a errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just Cast) (U.CAST _ _, _) -> notEnoughItemsOnStack - (U.RENAME vn, (an, Dict, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ RENAME ::: ((an, Dict, vn) ::& rs) + (U.RENAME vn, (an, Dict) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnRENAME (Anns1 vn) ::: ((an, Dict) ::& rs) (U.RENAME _, SNil) -> notEnoughItemsOnStack - (U.UNPACK tn vn mt, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ + (U.UNPACK tn vn mt, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ withUType mt $ \(tns :: Notes tn) -> do case NTOption tn tns of (ns :: Notes ('TOption t1)) -> withWTPInstr @('TOption t1) $ do Dict <- onScopeCheckInstrErr @tn uInstr (SomeHST inp) Nothing $ checkScope @(UnpackedValScope tn) - pure $ inp :/ UNPACK ::: ((ns, Dict, vn) ::& rs) + pure $ inp :/ AnnUNPACK (Anns3' tn vn tns) ::: ((notesSing ns, Dict) ::& rs) (U.UNPACK {}, _ ::& _) -> failWithErr $ UnexpectedType $ ("bytes" :| []) :| [] (U.UNPACK {}, SNil) -> notEnoughItemsOnStack - (U.PACK vn, (_ :: Notes a, _, _) ::& rs) -> workOnInstr uInstr $ do + (U.PACK vn, (_ :: SingT a, _) ::& rs) -> workOnInstr uInstr $ do Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing $ checkScope @(PackedValScope a) - pure $ inp :/ PACK ::: ((starNotes, Dict, vn) ::& rs) + pure $ inp :/ AnnPACK (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.PACK _, SNil) -> notEnoughItemsOnStack - (U.CONCAT vn, (NTBytes{}, _, _) ::& (NTBytes{}, _, _) ::& _) -> + (U.CONCAT vn, (STBytes{}, _) ::& (STBytes{}, _) ::& _) -> workOnInstr uInstr $ concatImpl inp vn - (U.CONCAT vn, (NTString{}, _, _) ::& (NTString{}, _, _) ::& _) -> + (U.CONCAT vn, (STString{}, _) ::& (STString{}, _) ::& _) -> workOnInstr uInstr $ concatImpl inp vn - (U.CONCAT vn, (STList STBytes, _, _, _) ::&+ _) -> + (U.CONCAT vn, (STList STBytes, _) ::& _) -> workOnInstr uInstr $ concatImpl' inp vn - (U.CONCAT vn, (STList STString, _, _, _) ::&+ _) -> + (U.CONCAT vn, (STList STString, _) ::& _) -> workOnInstr uInstr $ concatImpl' inp vn (U.CONCAT _, _ ::& _) -> failWithErr $ UnexpectedType @@ -1188,12 +1135,12 @@ ] (U.CONCAT _, SNil) -> notEnoughItemsOnStack - (U.SLICE vn, (NTNat{}, _, _) ::& - (NTNat{}, _, _) ::& - (NTString{}, _, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn - (U.SLICE vn, (NTNat{}, _, _) ::& - (NTNat{}, _, _) ::& - (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn + (U.SLICE vn, (STNat{}, _) ::& + (STNat{}, _) ::& + (STString{}, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn + (U.SLICE vn, (STNat{}, _) ::& + (STNat{}, _) ::& + (STBytes{}, _) ::& _) -> workOnInstr uInstr $ sliceImpl inp vn (U.SLICE _, _ ::& _ ::& _ ::& _) -> failWithErr $ UnexpectedType @@ -1202,9 +1149,8 @@ ] (U.SLICE _, _) -> notEnoughItemsOnStack - (U.ISNAT vn', (NTInt{}, _, oldVn) ::& rs) -> workOnInstr uInstr $ do - let vn = vn' `orAnn` oldVn - pure $ inp :/ ISNAT ::: ((starNotes, Dict, vn) ::& rs) + (U.ISNAT vn', (STInt{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnISNAT (Anns1 vn') ::: ((sing, Dict) ::& rs) (U.ISNAT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] @@ -1212,49 +1158,49 @@ (U.ISNAT _, SNil)-> notEnoughItemsOnStack -- Type checking is already done inside `addImpl`. - (U.ADD vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $ + (U.ADD vn, (a, _) ::& (b, _) ::& _) -> workOnInstr uInstr $ addImpl a b inp vn uInstr (U.ADD _, _) -> notEnoughItemsOnStack - (U.SUB vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $ + (U.SUB vn, (a, _) ::& (b, _) ::& _) -> workOnInstr uInstr $ subImpl a b inp vn uInstr (U.SUB _, _) -> notEnoughItemsOnStack - (U.SUB_MUTEZ vn, (STMutez, _, _, _) ::&+ (STMutez, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @SubMutez SUB_MUTEZ inp vn uInstr - (U.SUB_MUTEZ _, _ ::&+ _ ::&+ _) -> + (U.SUB_MUTEZ vn, (STMutez, _) ::& (STMutez, _) ::& _) -> workOnInstr uInstr $ + arithImpl @SubMutez AnnSUB_MUTEZ inp vn uInstr + (U.SUB_MUTEZ _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("mutez" :| ["mutez"]) :| [] (U.SUB_MUTEZ _, _) -> notEnoughItemsOnStack - (U.MUL vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $ + (U.MUL vn, (a, _) ::& (b, _) ::& _) -> workOnInstr uInstr $ mulImpl a b inp vn uInstr (U.MUL _, _) -> notEnoughItemsOnStack - (U.EDIV vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> workOnInstr uInstr $ + (U.EDIV vn, (a, _) ::& (b, _) ::& _) -> workOnInstr uInstr $ edivImpl a b inp vn uInstr (U.EDIV _, _) -> notEnoughItemsOnStack - (U.ABS vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImpl @Abs ABS inp vn + (U.ABS vn, (STInt, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Abs (AnnABS (Anns1 vn)) inp vn (U.ABS _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.ABS _, SNil) -> notEnoughItemsOnStack - (U.NEG vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImplAnnotated @Neg NEG inp vn - (U.NEG vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImpl @Neg NEG inp vn - (U.NEG vn, (STBls12381Fr, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImplAnnotated @Neg NEG inp vn - (U.NEG vn, (STBls12381G1, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImplAnnotated @Neg NEG inp vn - (U.NEG vn, (STBls12381G2, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImplAnnotated @Neg NEG inp vn + (U.NEG vn, (STInt, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImplAnnotated @Neg (AnnNEG (Anns1 vn)) inp vn + (U.NEG vn, (STNat, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Neg (AnnNEG (Anns1 vn)) inp vn + (U.NEG vn, (STBls12381Fr, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImplAnnotated @Neg (AnnNEG (Anns1 vn)) inp vn + (U.NEG vn, (STBls12381G1, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImplAnnotated @Neg (AnnNEG (Anns1 vn)) inp vn + (U.NEG vn, (STBls12381G2, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImplAnnotated @Neg (AnnNEG (Anns1 vn)) inp vn (U.NEG _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| @@ -1265,26 +1211,26 @@ ] (U.NEG _, SNil) -> notEnoughItemsOnStack - (U.LSL vn, (STNat, _, _, _) ::&+ - (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @Lsl LSL inp vn uInstr + (U.LSL vn, (STNat, _) ::& + (STNat, _) ::& _) -> workOnInstr uInstr $ + arithImpl @Lsl AnnLSL inp vn uInstr (U.LSL _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| [] (U.LSL _, _) -> notEnoughItemsOnStack - (U.LSR vn, (STNat, _, _, _) ::&+ - (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @Lsr LSR inp vn uInstr + (U.LSR vn, (STNat, _) ::& + (STNat, _) ::& _) -> workOnInstr uInstr $ + arithImpl @Lsr AnnLSR inp vn uInstr (U.LSR _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| [] (U.LSR _, _) -> notEnoughItemsOnStack - (U.OR vn, (STBool, _, _, _) ::&+ - (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @Or OR inp vn uInstr - (U.OR vn, (STNat, _, _, _) ::&+ - (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @Or OR inp vn uInstr + (U.OR vn, (STBool, _) ::& + (STBool, _) ::& _) -> workOnInstr uInstr $ + arithImpl @Or AnnOR inp vn uInstr + (U.OR vn, (STNat, _) ::& + (STNat, _) ::& _) -> workOnInstr uInstr $ + arithImpl @Or AnnOR inp vn uInstr (U.OR _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("bool" :| ["bool"]) :| @@ -1292,15 +1238,15 @@ ] (U.OR _, _) -> notEnoughItemsOnStack - (U.AND vn, (STInt, _, _, _) ::&+ - (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @And AND inp vn uInstr - (U.AND vn, (STNat, _, _, _) ::&+ - (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @And AND inp vn uInstr - (U.AND vn, (STBool, _, _, _) ::&+ - (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @And AND inp vn uInstr + (U.AND vn, (STInt, _) ::& + (STNat, _) ::& _) -> workOnInstr uInstr $ + arithImpl @And AnnAND inp vn uInstr + (U.AND vn, (STNat, _) ::& + (STNat, _) ::& _) -> workOnInstr uInstr $ + arithImpl @And AnnAND inp vn uInstr + (U.AND vn, (STBool, _) ::& + (STBool, _) ::& _) -> workOnInstr uInstr $ + arithImpl @And AnnAND inp vn uInstr (U.AND _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| ["nat"]) :| @@ -1309,12 +1255,12 @@ ] (U.AND _, _) -> notEnoughItemsOnStack - (U.XOR vn, (STBool, _, _, _) ::&+ - (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @Xor XOR inp vn uInstr - (U.XOR vn, (STNat, _, _, _) ::&+ - (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - arithImpl @Xor XOR inp vn uInstr + (U.XOR vn, (STBool, _) ::& + (STBool, _) ::& _) -> workOnInstr uInstr $ + arithImpl @Xor AnnXOR inp vn uInstr + (U.XOR vn, (STNat, _) ::& + (STNat, _) ::& _) -> workOnInstr uInstr $ + arithImpl @Xor AnnXOR inp vn uInstr (U.XOR _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("bool" :| ["bool"]) :| @@ -1322,12 +1268,12 @@ ] (U.XOR _, _) -> notEnoughItemsOnStack - (U.NOT vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImpl @Not NOT inp vn - (U.NOT vn, (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImplAnnotated @Not NOT inp vn - (U.NOT vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $ - unaryArithImplAnnotated @Not NOT inp vn + (U.NOT vn, (STNat, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Not (AnnNOT (Anns1 vn)) inp vn + (U.NOT vn, (STBool, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImplAnnotated @Not (AnnNOT (Anns1 vn)) inp vn + (U.NOT vn, (STInt, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImplAnnotated @Not (AnnNOT (Anns1 vn)) inp vn (U.NOT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("nat" :| []) :| @@ -1337,87 +1283,83 @@ (U.NOT _, SNil) -> notEnoughItemsOnStack (U.COMPARE vn, - (an :: Notes aT, _, _) - ::& (bn :: Notes bT, _, _) + (_ :: SingT aT, _) + ::& (_ :: SingT bT, _) ::& rs ) -> workOnInstr uInstr $ do case eqType @aT @bT of Right Refl -> do - void . errConv $ converge an bn proofScope <- onScopeCheckInstrErr @aT (U.COMPARE vn) (SomeHST inp) (Just ComparisonArguments) $ checkScope @(ComparabilityScope aT) case proofScope of Dict -> - pure $ inp :/ COMPARE ::: ((starNotes, Dict, vn) ::& rs) + pure $ inp :/ AnnCOMPARE (Anns1 vn) ::: ((sing, Dict) ::& rs) Left err -> do typeCheckInstrErr' uInstr (SomeHST inp) (Just ComparisonArguments) err - where - errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a - errConv = onTypeCheckInstrAnnErr uInstr inp (Just ComparisonArguments) (U.COMPARE _, _) -> notEnoughItemsOnStack - (U.EQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $ - unaryArithImpl @Eq' EQ inp vn + (U.EQ vn, (STInt{}, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Eq' (AnnEQ (Anns1 vn)) inp vn (U.EQ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.EQ _, SNil) -> notEnoughItemsOnStack - (U.NEQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $ - unaryArithImpl @Neq NEQ inp vn + (U.NEQ vn, (STInt{}, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Neq (AnnNEQ (Anns1 vn)) inp vn (U.NEQ _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.NEQ _, SNil) -> notEnoughItemsOnStack - (U.LT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $ - unaryArithImpl @Lt LT inp vn + (U.LT vn, (STInt{}, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Lt (AnnLT (Anns1 vn)) inp vn (U.LT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.LT _, SNil) -> notEnoughItemsOnStack - (U.GT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $ - unaryArithImpl @Gt GT inp vn + (U.GT vn, (STInt{}, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Gt (AnnGT (Anns1 vn)) inp vn (U.GT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.GT _, SNil) -> notEnoughItemsOnStack - (U.LE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $ - unaryArithImpl @Le LE inp vn + (U.LE vn, (STInt{}, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Le (AnnLE (Anns1 vn)) inp vn (U.LE _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.LE _, SNil) -> notEnoughItemsOnStack - (U.GE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $ - unaryArithImpl @Ge GE inp vn + (U.GE vn, (STInt{}, _) ::& _) -> workOnInstr uInstr $ + pure $ unaryArithImpl @Ge (AnnGE (Anns1 vn)) inp vn (U.GE _, _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| []) :| [] (U.GE _, SNil) -> notEnoughItemsOnStack - (U.INT vn, (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs) - (U.INT vn, (NTBls12381Fr{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs) + (U.INT vn, (STNat{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnINT (Anns1 vn) ::: ((sing, Dict) ::& rs) + (U.INT vn, (STBls12381Fr{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnINT (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.INT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("nat" :| []) :| ["bls12_381_fr" :| []] (U.INT _, SNil) -> notEnoughItemsOnStack - (U.VIEW vn name (AsUType (retNotes :: Notes ret)), _ ::& (NTAddress{}, _, _) ::& rs) -> + (U.VIEW vn name (AsUType (retNotes :: Notes ret)), _ ::& (STAddress{}, _) ::& rs) -> workOnInstr uInstr $ withWTPInstr @ret $ do Dict <- onScopeCheckInstrErr @ret uInstr (SomeHST inp) Nothing $ checkScope @(ViewableScope ret) - pure $ inp :/ VIEW name retNotes ::: ((NTOption U.noAnn retNotes, Dict, vn) ::& rs) + pure $ inp :/ AnnVIEW (Anns2' vn retNotes) name ::: ((STOption (notesSing retNotes), Dict) ::& rs) (U.VIEW{}, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("'arg" :| ["address"]) :| [] (U.VIEW{}, _) -> notEnoughItemsOnStack - (U.SELF vn fn, _) -> workOnInstr uInstr $ do + (U.SELF vn fn, _) -> workOnInstr uInstr $ withNotInView uInstr do mode <- gets tcMode case mode of TypeCheckValue (value, ty) -> - tcFailedOnValue value ty "The SELF instruction cannot appear in a lambda." Nothing + tcFailedOnValue value ty "The SELF instruction cannot appear in a lambda" Nothing TypeCheckContract (SomeParamType notescp) -> do let epName = U.epNameFromSelfAnn fn MkEntrypointCallRes (argNotes :: Notes arg) epc <- @@ -1428,12 +1370,10 @@ case NTContract U.noAnn argNotes of (ntRes :: Notes ('TContract t1)) -> withWTPInstr @('TContract t1) $ - pure $ inp :/ SELF @arg (SomeEpc epc) ::: ((ntRes, Dict, vn) ::& inp) + pure $ inp :/ AnnSELF @arg (Anns1 vn) (SomeEpc epc) ::: ((notesSing ntRes, Dict) ::& inp) TypeCheckTest -> - error "'SELF' appears in test typechecking." - TypeCheckPack -> - error "'SELF' appears in packed data." - (U.CONTRACT vn fn mt, (NTAddress{}, _, _) ::& rs) -> workOnInstr uInstr $ + failWithErr' $ InvalidInstruction uInstr "'SELF' appears in test typechecking" + (U.CONTRACT vn fn mt, (STAddress{}, _) ::& rs) -> workOnInstr uInstr $ withUType mt $ \(tns :: Notes t) -> do proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter) $ checkScope @(ParameterScope t) @@ -1442,22 +1382,23 @@ $ epNameFromRefAnn fn `onFirst` IllegalEntrypoint case proofScope of Dict -> - withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs) + withWTPInstr @t $ pure $ inp :/ AnnCONTRACT (Anns2' vn tns) epName ::: ((notesSing ns, Dict) ::& rs) (U.CONTRACT {}, _ ::& _) -> failWithErr $ UnexpectedType $ ("address" :| []) :| [] (U.CONTRACT {}, SNil) -> notEnoughItemsOnStack - (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _, _) - ::& (NTMutez{}, _, _) - ::& (STContract (s :: Sing p), _, _, _) ::&+ rs) -> withSingI s $ workOnInstr uInstr $ do - proofScope <- onScopeCheckInstrErr @p uInstr (SomeHST inp) (Just ContractParameter) - $ checkScope @(ParameterScope p) - case (eqType @p @p', proofScope) of - (Right Refl, Dict) -> - pure $ inp :/ TRANSFER_TOKENS ::: ((starNotes, Dict, vn) ::& rs) - (Left m, _) -> - typeCheckInstrErr' uInstr (SomeHST inp) (Just ContractParameter) m + (U.TRANSFER_TOKENS vn, ((_ :: SingT p'), _) + ::& (STMutez{}, _) + ::& (STContract (s :: Sing p), _) ::& rs) -> withSingI s $ workOnInstr uInstr $ + withNotInView uInstr do + proofScope <- onScopeCheckInstrErr @p uInstr (SomeHST inp) (Just ContractParameter) + $ checkScope @(ParameterScope p) + case (eqType @p @p', proofScope) of + (Right Refl, Dict) -> + pure $ inp :/ AnnTRANSFER_TOKENS (Anns1 vn) ::: ((sing, Dict) ::& rs) + (Left m, _) -> + typeCheckInstrErr' uInstr (SomeHST inp) (Just ContractParameter) m (U.TRANSFER_TOKENS _, _ ::& _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("'p" :| ["mutez", "contract 'p"]) :| [] @@ -1465,9 +1406,9 @@ (U.TRANSFER_TOKENS _, _) -> notEnoughItemsOnStack (U.SET_DELEGATE vn, - (STOption STKeyHash, NTOption _ NTKeyHash{}, _, _) - ::&+ rs) -> workOnInstr uInstr $ do - pure $ inp :/ SET_DELEGATE ::: ((starNotes, Dict, vn) ::& rs) + (STOption STKeyHash, _) + ::& rs) -> workOnInstr uInstr $ withNotInView uInstr do + pure $ inp :/ AnnSET_DELEGATE (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.SET_DELEGATE _, _ ::& _) -> failWithErr $ UnexpectedType $ ("option key_hash" :| []) :| [] @@ -1475,169 +1416,168 @@ (U.SET_DELEGATE _, _) -> notEnoughItemsOnStack (U.CREATE_CONTRACT ovn avn contract, - (STOption STKeyHash, NTOption _ (_ :: Notes ('TKeyHash)), _, _) - ::&+ (NTMutez{}, _, _) - ::& (gn :: Notes g, Dict, _) ::& rs) -> workOnInstr uInstr $ do - (SomeContract contr@(Contract _ _ storeNotes _ _)) + (STOption STKeyHash, _) + ::& (STMutez{}, _) + ::& (_ :: SingT g, Dict) ::& rs) -> workOnInstr uInstr $ withNotInView uInstr do + (SomeContract contr@(Contract _ _ (_ :: Notes st) _ _)) <- lift $ typeCheckContractImpl contract - (Refl, _) <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage) $ - matchTypes gn storeNotes + Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage) $ + eqType @g @st pure - $ inp :/ CREATE_CONTRACT contr - ::: ((starNotes, Dict, ovn) ::& (starNotes, Dict, avn) ::& rs) + $ inp :/ AnnCREATE_CONTRACT (Anns2 ovn avn) contr + ::: ((sing, Dict) ::& (sing, Dict) ::& rs) (U.CREATE_CONTRACT {}, _ ::& _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("option key_hash" :| ["mutez", "'a"]) :| [] (U.CREATE_CONTRACT {}, _) -> notEnoughItemsOnStack - (U.IMPLICIT_ACCOUNT vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, Dict, vn) ::& rs) + (U.IMPLICIT_ACCOUNT vn, (STKeyHash{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnIMPLICIT_ACCOUNT (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.IMPLICIT_ACCOUNT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("key_hash" :| []) :| [] (U.IMPLICIT_ACCOUNT _, SNil) -> notEnoughItemsOnStack (U.NOW vn, _) -> workOnInstr uInstr $ - pure $ inp :/ NOW ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnNOW (Anns1 vn) ::: ((sing, Dict) ::& inp) (U.AMOUNT vn, _) -> workOnInstr uInstr $ - pure $ inp :/ AMOUNT ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnAMOUNT (Anns1 vn) ::: ((sing, Dict) ::& inp) (U.BALANCE vn, _) -> workOnInstr uInstr $ - pure $ inp :/ BALANCE ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnBALANCE (Anns1 vn) ::: ((sing, Dict) ::& inp) - (U.VOTING_POWER vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ VOTING_POWER ::: ((starNotes, Dict, vn) ::& rs) + (U.VOTING_POWER vn, (STKeyHash{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnVOTING_POWER (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.VOTING_POWER _, _ ::& _) -> failWithErr $ UnexpectedType $ ("key_hash" :| []) :| [] (U.VOTING_POWER _, SNil) -> notEnoughItemsOnStack (U.TOTAL_VOTING_POWER vn, _) -> workOnInstr uInstr $ - pure $ inp :/ TOTAL_VOTING_POWER ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnTOTAL_VOTING_POWER (Anns1 vn) ::: ((sing, Dict) ::& inp) (U.CHECK_SIGNATURE vn, - (NTKey _, _, _) - ::& (NTSignature _, _, _) ::& (NTBytes{}, _, _) ::& rs) -> + (STKey{}, _) + ::& (STSignature{}, _) ::& (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, Dict, vn) ::& rs) + pure $ inp :/ AnnCHECK_SIGNATURE (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.CHECK_SIGNATURE _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("key" :| ["signature", "bytes"]) :| [] (U.CHECK_SIGNATURE _, _) -> notEnoughItemsOnStack - (U.SHA256 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ SHA256 ::: ((starNotes, Dict, vn) ::& rs) + (U.SHA256 vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnSHA256 (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.SHA256 _, _ ::& _) -> failWithErr $ UnexpectedType $ ("bytes" :| []) :| [] (U.SHA256 _, SNil) -> notEnoughItemsOnStack - (U.SHA512 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ SHA512 ::: ((starNotes, Dict, vn) ::& rs) + (U.SHA512 vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnSHA512 (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.SHA512 _, _ ::& _) -> failWithErr $ UnexpectedType $ ("bytes" :| []) :| [] (U.SHA512 _, SNil) -> notEnoughItemsOnStack - (U.BLAKE2B vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ BLAKE2B ::: ((starNotes, Dict, vn) ::& rs) + (U.BLAKE2B vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnBLAKE2B (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.BLAKE2B _, _ ::& _) -> failWithErr $ UnexpectedType $ ("bytes" :| []) :| [] (U.BLAKE2B _, SNil) -> notEnoughItemsOnStack - (U.SHA3 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ SHA3 ::: ((starNotes, Dict, vn) ::& rs) + (U.SHA3 vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnSHA3 (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.SHA3 _, _ ::& _) -> failWithErr $ UnexpectedType $ ("bytes" :| []) :| [] (U.SHA3 _, SNil) -> notEnoughItemsOnStack - (U.KECCAK vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ KECCAK ::: ((starNotes, Dict, vn) ::& rs) + (U.KECCAK vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnKECCAK (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.KECCAK _, _ ::& _) -> failWithErr $ UnexpectedType $ ("bytes" :| []) :| [] (U.KECCAK _, SNil) -> notEnoughItemsOnStack - (U.HASH_KEY vn, (NTKey{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ HASH_KEY ::: ((starNotes, Dict, vn) ::& rs) + (U.HASH_KEY vn, (STKey{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnHASH_KEY (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.HASH_KEY _, _ ::& _) -> failWithErr $ UnexpectedType $ ("key" :| []) :| [] (U.HASH_KEY _, SNil) -> notEnoughItemsOnStack - (U.PAIRING_CHECK vn, (NTList _ (NTPair _ _ _ _ _ (NTBls12381G1 _) - (NTBls12381G2 _)), _, _) ::& rs) -> + (U.PAIRING_CHECK vn, (STList (STPair STBls12381G1 STBls12381G2), _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ PAIRING_CHECK ::: ((starNotes, Dict, vn) ::& rs) + pure $ inp :/ AnnPAIRING_CHECK (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.PAIRING_CHECK _, _ ::& _) -> failWithErr $ UnexpectedType $ ("list (pair bls12_381_g1 bls12_381_g2)" :| []) :| [] (U.PAIRING_CHECK _, SNil) -> notEnoughItemsOnStack (U.SOURCE vn, _) -> workOnInstr uInstr $ - pure $ inp :/ SOURCE ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnSOURCE (Anns1 vn) ::: ((sing, Dict) ::& inp) (U.SENDER vn, _) -> workOnInstr uInstr $ - pure $ inp :/ SENDER ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnSENDER (Anns1 vn) ::: ((sing, Dict) ::& inp) - (U.ADDRESS vn, (NTContract{}, _, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ ADDRESS ::: ((starNotes, Dict, vn) ::& rs) + (U.ADDRESS vn, (STContract{}, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnADDRESS (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.ADDRESS _, _ ::& _) -> failWithErr $ UnexpectedType $ ("contract 'p" :| []) :| [] (U.ADDRESS _, SNil) -> notEnoughItemsOnStack (U.CHAIN_ID vn, _) -> workOnInstr uInstr $ - pure $ inp :/ CHAIN_ID ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnCHAIN_ID (Anns1 vn) ::: ((sing, Dict) ::& inp) (U.LEVEL vn, _) -> workOnInstr uInstr $ - pure $ inp :/ LEVEL ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnLEVEL (Anns1 vn) ::: ((sing, Dict) ::& inp) (U.SELF_ADDRESS vn, _) -> workOnInstr uInstr $ - pure $ inp :/ SELF_ADDRESS ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnSELF_ADDRESS (Anns1 vn) ::: ((sing, Dict) ::& inp) - (U.NEVER, (NTNever{}, _, _) ::& _) -> workOnInstr uInstr $ + (U.NEVER, (STNever{}, _) ::& _) -> workOnInstr uInstr $ pure $ inp :/ AnyOutInstr NEVER (U.NEVER, _ ::& _) -> failWithErr $ UnexpectedType $ ("never" :| []) :| [] (U.NEVER, SNil) -> notEnoughItemsOnStack - (U.TICKET vn, (stVal :: Sing v, _, _, _) ::&+ (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $ + (U.TICKET vn, (stVal :: Sing v, _) ::& (STNat{}, _) ::& rs) -> workOnInstr uInstr $ withWTPInstr @v $ withCompareableCheck stVal uInstr inp $ - inp :/ TICKET ::: ((starNotes, Dict, vn) ::& rs) + inp :/ AnnTICKET (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.TICKET _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("a'" :| ["nat"]) :| [] (U.TICKET _, _) -> notEnoughItemsOnStack - (U.READ_TICKET vn, ticket@(NTTicket{}, Dict, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ READ_TICKET ::: ((starNotes, Dict, vn) ::& ticket ::& rs) + (U.READ_TICKET vn, ticket@(STTicket{}, Dict) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ AnnREAD_TICKET (Anns1 vn) ::: ((sing, Dict) ::& ticket ::& rs) (U.READ_TICKET _, _ ::& _) -> failWithErr $ UnexpectedType $ ("ticket 'a" :| []) :| [] (U.READ_TICKET _, _) -> notEnoughItemsOnStack - (U.SPLIT_TICKET vn, (NTTicket{}, Dict, _) ::& (NTPair _ _ _ _ _ NTNat{} NTNat{}, _, _) ::& rs) -> + (U.SPLIT_TICKET vn, (STTicket{}, Dict) ::& (STPair STNat{} STNat{}, _) ::& rs) -> workOnInstr uInstr $ - pure $ inp :/ SPLIT_TICKET ::: ((starNotes, Dict, vn) ::& rs) + pure $ inp :/ AnnSPLIT_TICKET (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.SPLIT_TICKET _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("pair nat nat" :| ["ticket 'a"]) :| [] (U.SPLIT_TICKET _, _) -> notEnoughItemsOnStack (U.JOIN_TICKETS vn, - (STPair{}, NTPair _ _ _ _ _ nt1@NTTicket{} nt2@NTTicket{}, Dict, _) ::&+ rs) -> + (STPair (nt1@STTicket{} :: SingT t1) (STTicket{} :: SingT t2), Dict) ::& rs) -> workOnInstr uInstr $ do - (Refl, nt) <- + Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just TicketsJoin) $ - matchTypes nt1 nt2 - pure $ inp :/ JOIN_TICKETS ::: ((NTOption U.noAnn nt, Dict, vn) ::& rs) + eqType @t1 @t2 + pure $ inp :/ AnnJOIN_TICKETS (Anns1 vn) ::: ((STOption nt1, Dict) ::& rs) (U.JOIN_TICKETS _, _ ::& _) -> failWithErr $ UnexpectedType $ ("pair (ticket 'a) (ticket 'a)" :| []) :| [] (U.JOIN_TICKETS _, _) -> notEnoughItemsOnStack (U.OPEN_CHEST vn, - (NTChestKey _, Dict, _) - ::& (NTChest _, Dict, _) - ::& (NTNat _, Dict, _) + (STChestKey, Dict) + ::& (STChest, Dict) + ::& (STNat, Dict) ::& rs) -> workOnInstr uInstr $ do - pure $ inp :/ OPEN_CHEST ::: ( - (NTOr U.noAnn U.noAnn U.noAnn (NTBytes U.noAnn) (NTBool U.noAnn), Dict, vn) + pure $ inp :/ AnnOPEN_CHEST (Anns1 vn) ::: ( + (STOr STBytes STBool, Dict) ::& rs) (U.OPEN_CHEST _, _ ::& _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("chest_key" :| ["chest", "nat"]) :| [] @@ -1645,21 +1585,18 @@ (U.SAPLING_EMPTY_STATE vn n, _) -> workOnInstr uInstr $ (\(SomeSing (s :: Sing a)) -> withSingI s $ - pure $ inp :/ (SAPLING_EMPTY_STATE s) ::: ((starNotes, Dict, vn) ::& inp) + pure $ inp :/ AnnSAPLING_EMPTY_STATE (Anns1 vn) s ::: ((sing, Dict) ::& inp) ) $ Peano.someSingNat n (U.SAPLING_VERIFY_UPDATE vn, - (STSaplingTransaction s1, NTSaplingTransaction _ n, Dict, _) - ::&+ (STSaplingState s2, NTSaplingState _ _, Dict, _) - ::&+ rs) -> + (STSaplingTransaction s1, Dict) + ::& (STSaplingState s2, Dict) + ::& rs) -> workOnInstr uInstr $ case testEquality s1 s2 of Just Refl -> - pure $ inp :/ SAPLING_VERIFY_UPDATE ::: ( - (NTOption U.noAnn (NTPair U.noAnn U.noAnn U.noAnn U.noAnn U.noAnn - (NTInt U.noAnn) - (NTSaplingState U.noAnn n) - ), Dict, vn) + pure $ inp :/ AnnSAPLING_VERIFY_UPDATE (Anns1 vn) ::: ( + (STOption (STPair STBytes (STPair STInt (STSaplingState s1))), Dict) ::& rs) Nothing -> failWithErr' $ InvalidInstruction uInstr "Memo sizes of two sapling states or transactions do not match." @@ -1691,6 +1628,15 @@ notEnoughItemsOnStack' :: TypeCheckInstr a notEnoughItemsOnStack' = failWithErr' NotEnoughItemsOnStack + withNotInView :: U.ExpandedInstr -> (IsNotInView => TypeCheckInstr r) -> TypeCheckInstr r + withNotInView instr act = gets tcMode >>= \case + -- we provide the not-in-view constraint in the isolated mode + TypeCheckTest -> giveNotInView act + _ -> view tcieNotInView >>= \case + Just Dict -> act + Nothing -> failWithErr' $ + InvalidInstruction instr "This instruction cannot be used on the top level of a view" + -- | Helper function for two-branch if where each branch is given a single -- value. genericIf @@ -1718,8 +1664,7 @@ let instr = mCons mbt mbf Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just If) $ eqHST po qo - o <- onTypeCheckInstrAnnErr instr i (Just If) (convergeHST po qo) - pure $ cons p q ::: o + pure $ cons p q ::: qo (AnyOutInstr p, q ::: qo) -> do pure $ cons p q ::: qo (p ::: po, AnyOutInstr q) -> do @@ -1734,23 +1679,24 @@ , SingI1 (MapOpRes c) ) => ([TypeCheckedOp] -> TypeCheckedInstr) - -> Notes (MapOpInp c) + -> SingT (MapOpInp c) + -> VarAnn -> U.ExpandedInstr -> [U.ExpandedOp] -> HST (c ': rs) -> (forall v'. (SingI v') => - Notes v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs))) + SingT v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs))) -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs)) -mapImpl cons vn instr mp i@(_ ::& rs) mkRes = do - preserving (tcList mp ((vn, Dict, def) ::& rs)) cons $ \(_ :/ subp) -> +mapImpl cons vn anns instr mp i@(_ ::& rs) mkRes = do + preserving (tcList mp ((vn, Dict) ::& rs)) cons $ \(_ :/ subp) -> case subp of sub ::: subo -> case subo of - (bn :: Notes v', _, _bvn) ::& rs' -> do + (bn :: SingT v', _) ::& rs' -> do Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration) $ eqHST rs rs' x <- mkRes bn rs' - pure $ i :/ withSingI1 @(MapOpRes c) @v' (MAP sub ::: x) + pure $ i :/ withSingI1 @(MapOpRes c) @v' (AnnMAP (Anns1 anns) sub ::: x) _ -> typeCheckInstrErr instr (SomeHST i) (Just Iteration) AnyOutInstr _ -> typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails @@ -1760,17 +1706,16 @@ ( IterOp c , WellTyped (IterOpEl c) ) - => Notes (IterOpEl c) + => SingT (IterOpEl c) -> U.ExpandedInstr -> [U.ExpandedOp] -> HST (c ': rs) -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs)) -iterImpl en instr mp i@((_, _, lvn) ::& rs) = do - let evn = deriveVN [annQ|elt|] lvn +iterImpl en instr mp i@((_, _) ::& rs) = do let tcAction = case mp of [] -> workOnInstr instr (typeCheckInstrErr' instr (SomeHST i) (Just Iteration) EmptyCode) - _ -> typeCheckImpl typeCheckInstr mp ((en, Dict, evn) ::& rs) + _ -> typeCheckImpl typeCheckInstr mp ((en, Dict) ::& rs) preserving tcAction U.ITER $ \(_ :/ subp) -> case subp of subI ::: o -> do Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration) $ eqHST o rs @@ -1784,32 +1729,31 @@ , SingI ts ) => ([TypeCheckedOp] -> TypeCheckedInstr) + -> Anns '[VarAnn, Notes it, Notes ot] -> U.ExpandedInstr -> [U.ExpandedOp] - -> VarAnn - -> Notes it - -> Notes ot + -> SingT it + -> SingT ot -> HST ts -> TypeCheckInstrNoExcept (TypeCheckedSeq ts) -lamImpl cons instr is vn ins ons i = +lamImpl cons anns instr is ins ons i = guarding_ instr (whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr -> do let err = InvalidInstruction selfInstr "SELF instruction cannot be used in a LAMBDA" typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) err) $ - preserving (tcList is ((ins, Dict, def) ::& SNil)) cons $ \(_ :/ lamI) -> do - let lamNotes onsr = NTLambda def ins onsr - let lamSt onsr = (lamNotes onsr, Dict, vn) ::& i + preserving tcInstr cons $ \(_ :/ lamI) -> do + let lamNotes onsr = STLambda ins onsr + let lamSt onsr = (lamNotes onsr, Dict) ::& i fmap (i :/) $ case lamI of lam ::: lo -> do case eqHST1 @ot lo of Right Refl -> do - let (ons', _, _) ::& SNil = lo - onsr <- onTypeCheckInstrAnnErr instr i (Just LambdaCode) (converge ons ons') - pure (LAMBDA (VLam $ RfNormal lam) ::: lamSt onsr) + pure (AnnLAMBDA anns (VLam $ RfNormal lam) ::: lamSt ons) Left m -> typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) m AnyOutInstr lam -> - pure (LAMBDA (VLam $ RfAlwaysFails lam) ::: lamSt ons) + pure (AnnLAMBDA anns (VLam $ RfAlwaysFails lam) ::: lamSt ons) where + tcInstr = giveNotInView $ local (set tcieNotInView $ Just Dict) $ tcList is ((ins, Dict) ::& SNil) hasSelf :: U.ExpandedOp -> First U.ExpandedInstr hasSelf = everything (<>) (mkQ (First Nothing) @@ -1841,8 +1785,8 @@ -> (forall out. SingI out => Instr inp out -> HST out -> r) -> TypeCheckInstrNoExcept r typeCheckDipBody cons mainInstr instructions inputHST onErr onOk = do - listRes <- lift $ typeCheckListNoExcept instructions inputHST - pos <- ask + listRes <- tcList instructions inputHST + pos <- view tcieErrorPos pure $ listRes & tcsEither (\tcOps err -> onErr err [SemiTypedInstr $ cons tcOps]) (\someInstr@(_ :/ iAndOut) -> case iAndOut of diff --git a/src/Morley/Michelson/TypeCheck/TypeCheck.hs b/src/Morley/Michelson/TypeCheck/TypeCheck.hs --- a/src/Morley/Michelson/TypeCheck/TypeCheck.hs +++ b/src/Morley/Michelson/TypeCheck/TypeCheck.hs @@ -30,14 +30,19 @@ , TypeCheckMode(..) , SomeParamType(..) , mkSomeParamType + , TypeCheckInstrEnv (..) + , tcieErrorPos + , tcieNotInView ) where +import Control.Lens (makeLenses) import Control.Monad.Except (Except, mapExceptT, runExcept, throwError) import Control.Monad.Reader (mapReaderT) +import Data.Constraint (Dict) import Data.Default (Default(..)) import Fmt (Buildable, build, pretty) -import Morley.Michelson.ErrorPos (InstrCallStack) +import Morley.Michelson.ErrorPos (ErrorSrcPos) import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..)) import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp, @@ -106,7 +111,6 @@ = TypeCheckValue (U.Value, T.T) | TypeCheckContract SomeParamType | TypeCheckTest - | TypeCheckPack -- | The typechecking state data TypeCheckEnv = TypeCheckEnv @@ -156,11 +160,21 @@ typeCheckingWith options = runExcept . usingReaderT options type TypeCheckInstr = - ReaderT InstrCallStack TypeCheck + ReaderT TypeCheckInstrEnv TypeCheck type TypeCheckInstrNoExcept = - ReaderT InstrCallStack TypeCheckNoExcept + ReaderT TypeCheckInstrEnv TypeCheckNoExcept +data TypeCheckInstrEnv = TypeCheckInstrEnv + { _tcieErrorPos :: ErrorSrcPos + , _tcieNotInView :: Maybe (Dict T.IsNotInView) + } + +makeLenses ''TypeCheckInstrEnv + +instance Default TypeCheckInstrEnv where + def = TypeCheckInstrEnv def Nothing + -- | Similar to 'runTypeCheckIsolated', but for 'TypeCheckInstr.' runTypeCheckInstrIsolated :: TypeCheckInstr a -> TypeCheckResult a runTypeCheckInstrIsolated = runTypeCheckIsolated . flip runReaderT def @@ -259,7 +273,7 @@ -- have to be refactored too. -- Therefore, I am using ReaderT over TypeCheck. type TcInstrHandler - = forall inp. (T.SingI inp, HasCallStack) + = forall inp. (T.SingI inp) => U.ExpandedInstr -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) diff --git a/src/Morley/Michelson/TypeCheck/Types.hs b/src/Morley/Michelson/TypeCheck/Types.hs --- a/src/Morley/Michelson/TypeCheck/Types.hs +++ b/src/Morley/Michelson/TypeCheck/Types.hs @@ -4,7 +4,6 @@ module Morley.Michelson.TypeCheck.Types ( HST (..) , (-:&) - , pattern (::&+) , SomeHST (..) , SomeInstrOut (..) , SomeInstr (..) @@ -26,13 +25,12 @@ import Text.PrettyPrint.Leijen.Text (Doc, (<+>)) import Morley.Michelson.Printer.Util -import Morley.Michelson.Typed (Notes(..), SomeContract(..), T(..), notesT, starNotes) +import Morley.Michelson.Typed (SomeContract(..), T(..)) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Contract import Morley.Michelson.Typed.Instr import Morley.Michelson.Typed.Scope (WellTyped, getWTP) -import Morley.Michelson.Untyped (Ty, Var, noAnn) -import Morley.Michelson.Untyped.Annotation (VarAnn) +import Morley.Michelson.Untyped (Ty, Var) import Morley.Util.Sing (eqParamSing) -- | Data type holding type information for stack (Heterogeneous Stack Type). @@ -61,7 +59,7 @@ data HST (ts :: [T]) where SNil :: HST '[] (::&) :: (T.SingI x, T.SingI xs) - => (Notes x, Dict (WellTyped x), VarAnn) + => (T.SingT x, Dict (WellTyped x)) -> HST xs -> HST (x ': xs) @@ -69,7 +67,7 @@ instance NFData (HST ts) where rnf (SNil) = () - rnf ((a, d, b) ::& hst) = rnf (a, d, b, hst) + rnf ((d, b) ::& hst) = rnf (d, b, hst) instance Buildable (HST ts) where build = buildRenderDocExtended @@ -79,15 +77,15 @@ renderDoc context (r ::& rs) = "[" <+> doRender (r ::& rs) <+> "]" where doRender :: HST (t ': ts_) -> Doc - doRender ((notesT -> t, Dict, _vn) ::& (b ::& c)) = + doRender ((t, Dict) ::& (b ::& c)) = renderDoc context t <> "," <+> doRender (b ::& c) - doRender ((notesT -> t, Dict, _vn) ::& SNil) = renderDoc context t + doRender ((t, Dict) ::& SNil) = renderDoc context t infixr 7 ::& instance Eq (HST ts) where SNil == SNil = True - (n1, Dict, a1) ::& h1 == (n2, Dict, a2) ::& h2 = - n1 == n2 && a1 == a2 && h1 == h2 + (n1, Dict) ::& h1 == (n2, Dict) ::& h2 = + n1 == n2 && h1 == h2 -- | Append a type to 'HST', assuming that notes and annotations -- for this type are unknown. @@ -96,21 +94,8 @@ => Sing x -> HST xs -> HST (x ': xs) -_ -:& hst = (starNotes, Dict, noAnn) ::& hst +s -:& hst = (s, Dict) ::& hst infixr 7 -:& - --- | Extended pattern-match - adds @Sing x@ argument. -infixr 7 ::&+ -pattern (::&+) - :: () - => ( ys ~ (x ': xs) - , SingI x, SingI xs - ) - => (Sing x, Notes x, Dict (WellTyped x), VarAnn) - -> HST xs - -> HST ys -pattern x ::&+ hst <- ((\(n, d, v) -> (T.notesSing n, n, d, v)) -> x) ::& hst - where (_, n, d, v) ::&+ hst = (n, d, v) ::& hst -- | No-argument type wrapper for @HST@ data type. data SomeHST where diff --git a/src/Morley/Michelson/TypeCheck/Value.hs b/src/Morley/Michelson/TypeCheck/Value.hs --- a/src/Morley/Michelson/TypeCheck/Value.hs +++ b/src/Morley/Michelson/TypeCheck/Value.hs @@ -8,7 +8,6 @@ import Control.Monad.Except (liftEither, throwError) import Data.Constraint (Dict(..)) -import Data.Default (def) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Set qualified as S @@ -22,12 +21,13 @@ import Morley.Michelson.TypeCheck.Helpers import Morley.Michelson.TypeCheck.TypeCheck (SomeParamType(..), TcInstrHandler, TcOriginatedContracts, TypeCheckInstr, TypeCheckOptions(..), - throwingTCError) + tcieErrorPos, tcieNotInView, throwingTCError) import Morley.Michelson.TypeCheck.Types -import Morley.Michelson.Typed (EpAddress(..), Notes(..), SingT(..), Value'(..), starNotes) +import Morley.Michelson.Typed (EpAddress(..), Notes(..), SingT(..), Value'(..)) import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Typed.Contract (giveNotInView) import Morley.Michelson.Untyped qualified as U -import Morley.Tezos.Address (Address(..)) +import Morley.Tezos.Address (Address(..), TxRollupL2Address(..)) import Morley.Tezos.Core import Morley.Tezos.Crypto import Morley.Tezos.Crypto.BLS12381 qualified as BLS @@ -36,7 +36,7 @@ tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a tcFailedOnValue v t msg err = do - loc <- ask + loc <- view tcieErrorPos throwError $ TCFailedOnValue v t msg loc err -- | Function @typeCheckValImpl@ converts a single Michelson value @@ -80,13 +80,20 @@ (v@(U.ValueBytes b), t@STAddress) -> case T.parseEpAddressRaw (U.unInternalByteString b) of Right addr -> pure $ VAddress addr Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err) - (v@(U.ValueString s), t@STKeyHash) -> case parseKeyHash (unMText s) of + (v@(U.ValueString s), t@STKeyHash) -> case parseHash (unMText s) of Right kHash -> pure $ VKeyHash kHash Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err) (v@(U.ValueBytes b), t@STKeyHash) -> case parseKeyHashRaw (U.unInternalByteString b) of Right kHash -> pure $ VKeyHash kHash Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err) + (v@(U.ValueString s), t@STTxRollupL2Address) -> case parseHash (unMText s) of + Right kHash -> pure $ VTxRollupL2Address $ TxRollupL2Address kHash + Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err) + (v@(U.ValueBytes b), t@STTxRollupL2Address) -> + case parseKeyHashL2Raw (U.unInternalByteString b) of + Right kHash -> pure $ VTxRollupL2Address $ TxRollupL2Address kHash + Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err) (U.ValueInt i, STBls12381Fr) -> pure $ VBls12381Fr (fromIntegralOverflowing @Integer @Bls12381Fr i) (v@(U.ValueBytes b), t@STBls12381Fr) -> @@ -193,14 +200,14 @@ withSingI l $ pure $ VList els (U.ValueNil, STSet s) -> do - instrPos <- ask + instrPos <- view tcieErrorPos case T.getComparableProofS s of Just Dict -> withSingI s $ pure (T.VSet S.empty) Nothing -> throwError $ TCFailedOnValue uvalue (fromSing s) "Non comparable types are not allowed in Sets" instrPos (Just $ UnsupportedTypeForScope (fromSing s) T.BtNotComparable) (sq@(U.ValueSeq (toList -> mels)), s@(STSet vt)) -> withComparable vt sq s $ do - instrPos <- ask + instrPos <- view tcieErrorPos els <- typeCheckValsImpl (mels, vt) elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els @@ -243,17 +250,22 @@ _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing _ :/ instr <- withWTP @it uvalue $ throwingTCError $ - typeCheckImpl tcDo mp ((starNotes @it, Dict, def) ::& SNil) + typeCheckImpl + -- lambdas can contain operations forbidden inside views, hence + -- we invent a "not in view" constraint here. + (giveNotInView $ local (set tcieNotInView $ Just Dict) ... tcDo) + mp + ((sing @it, Dict) ::& SNil) case instr of lam ::: (lo :: HST lo) -> withWTP @ot uvalue $ do case eqHST1 @ot lo of Right Refl -> do - pure $ VLam (T.RfNormal lam) + pure $ T.mkVLam (T.RfNormal lam) Left m -> tcFailedOnValue v (demote @ty) "wrong output type of lambda's value:" (Just m) AnyOutInstr lam -> - pure $ VLam (T.RfAlwaysFails lam) + pure $ T.mkVLam (T.RfAlwaysFails lam) (v@(U.ValueBytes (U.InternalByteString bs)), STChest) -> case chestFromBytes bs of @@ -330,7 +342,7 @@ -> Sing vt -> TypeCheckInstr [(T.Value kt, T.Value vt)] typeCheckMapVal mels sq kt vt = withComparable kt sq kt $ do - instrPos <- ask + instrPos <- view tcieErrorPos ks <- typeCheckValsImpl (map (\(U.Elt k _) -> k) mels, kt) vals <- typeCheckValsImpl (map (\(U.Elt _ v) -> v) mels, vt) ksS <- liftEither $ ensureDistinctAsc id ks @@ -342,7 +354,7 @@ => U.Value -> EpAddress -> Sing cp -> TypeCheckInstr (T.Value tz) typecheckContractValue cv (EpAddress addr epName) pc = do - instrPos <- ask + instrPos <- view tcieErrorPos let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr (cp :~: t') ensureTypeMatches = liftEither @_ @TypeCheckInstr $ first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $ @@ -370,6 +382,9 @@ Nothing -> throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown" instrPos (Just $ UnknownContract addr) + TransactionRollupAddress _ -> + throwError $ TCFailedOnValue cv (demote @ty) "txr1 address passed as contract" + instrPos (Just $ UnknownContract addr) withComparable :: forall a (t :: T.T) ty. Sing a @@ -380,7 +395,7 @@ withComparable s uv t act = case T.getComparableProofS s of Just Dict -> act Nothing -> do - instrPos <- ask + instrPos <- view tcieErrorPos liftEither . Left $ TCFailedOnValue uv (fromSing t) "Require a comparable type here" instrPos Nothing @@ -393,7 +408,7 @@ withBigMapAbsence s uv t act = case T.bigMapAbsense s of Just Dict -> act Nothing -> do - instrPos <- ask + instrPos <- view tcieErrorPos liftEither . Left $ TCFailedOnValue uv (fromSing t) "Require a type which doesn't contain `big_map` here" instrPos Nothing diff --git a/src/Morley/Michelson/Typed.hs b/src/Morley/Michelson/Typed.hs --- a/src/Morley/Michelson/Typed.hs +++ b/src/Morley/Michelson/Typed.hs @@ -9,7 +9,7 @@ import Morley.Michelson.Typed.AnnotatedValue as Exports (AnnotatedValue(..), SomeAnnotatedValue(..)) import Morley.Michelson.Typed.Annotation as Exports import Morley.Michelson.Typed.Arith as Exports -import Morley.Michelson.Typed.Contract as Exports +import Morley.Michelson.Typed.Contract as Exports hiding (giveNotInView) import Morley.Michelson.Typed.Convert as Exports import Morley.Michelson.Typed.Doc as Exports import Morley.Michelson.Typed.Entrypoints as Exports @@ -17,7 +17,6 @@ import Morley.Michelson.Typed.Extract as Exports import Morley.Michelson.Typed.Haskell as Exports import Morley.Michelson.Typed.Instr as Exports -import Morley.Michelson.Typed.OpSize as Exports import Morley.Michelson.Typed.Polymorphic as Exports import Morley.Michelson.Typed.Scope as Exports import Morley.Michelson.Typed.Sing as Exports diff --git a/src/Morley/Michelson/Typed/Annotation.hs b/src/Morley/Michelson/Typed/Annotation.hs --- a/src/Morley/Michelson/Typed/Annotation.hs +++ b/src/Morley/Michelson/Typed/Annotation.hs @@ -20,36 +20,34 @@ module Morley.Michelson.Typed.Annotation ( Notes (..) - , AnnConvergeError(..) - , converge - , convergeAnns - , convergeDestrAnns , insertTypeAnn , isStar , starNotes , mkUType , notesSing , notesT + -- * Helpers + , AnnVar + , Anns(.., Anns1, Anns2, Anns2', Anns3, Anns3', Anns3'', Anns4, Anns4'', Anns5') + , AnnotateInstr(..) ) where +import Data.Default (Default(def)) import Data.Singletons (Sing, SingI(..), fromSing) -import Fmt (Buildable(..), (+|), (|+)) +import Fmt (Buildable(..)) import Language.Haskell.TH.Syntax (Lift) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc) import Morley.Michelson.Typed.Sing import Morley.Michelson.Typed.T (T(..)) import Morley.Michelson.Untyped qualified as Un -import Morley.Michelson.Untyped.Annotation - (Annotation, FieldAnn, TypeAnn, VarAnn, convergeVarAnns, noAnn, unifyAnn, unifyPairFieldAnn) +import Morley.Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, VarAnn, noAnn) import Morley.Util.Peano qualified as Peano import Morley.Util.PeanoNatural (singPeanoVal) import Morley.Util.TH -import Morley.Util.Typeable {-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} - -- | Data type, holding annotation data for a given Michelson type @t@. -- -- Each constructor corresponds to exactly one constructor of 'T' @@ -89,6 +87,7 @@ NTChest :: TypeAnn -> Notes 'TChest NTChestKey :: TypeAnn -> Notes 'TChestKey NTNever :: TypeAnn -> Notes 'TNever + NTTxRollupL2Address :: TypeAnn -> Notes 'TTxRollupL2Address NTSaplingState :: forall (n :: Peano.Peano). TypeAnn -> Sing n -> Notes ('TSaplingState n) NTSaplingTransaction :: forall (n :: Peano.Peano). TypeAnn -> Sing n -> Notes ('TSaplingTransaction n) @@ -129,6 +128,7 @@ NTOperation _ -> sing NTChest _ -> sing NTChestKey _ -> sing + NTTxRollupL2Address _ -> sing NTNever _ -> sing NTSaplingState _ s -> STSaplingState s NTSaplingTransaction _ s -> STSaplingTransaction s @@ -169,9 +169,10 @@ NTOperation tn -> Un.Ty Un.TOperation tn NTChest tn -> Un.Ty Un.TChest tn NTChestKey tn -> Un.Ty Un.TChestKey tn + NTTxRollupL2Address tn -> Un.Ty Un.TTxRollupL2Address tn NTNever tn -> Un.Ty Un.TNever tn NTSaplingState tn s -> Un.Ty (Un.TSaplingState (singPeanoVal s)) tn - NTSaplingTransaction tn s -> Un.Ty (Un.TSaplingState (singPeanoVal s)) tn + NTSaplingTransaction tn s -> Un.Ty (Un.TSaplingTransaction (singPeanoVal s)) tn NTContract tn n -> Un.Ty (Un.TContract $ mkUType n) tn NTTicket tn n -> Un.Ty (Un.TTicket $ mkUType n) tn NTPair tn fl fr vl vr nl nr -> @@ -203,6 +204,7 @@ STAddress -> NTAddress noAnn STKey -> NTKey noAnn STUnit -> NTUnit noAnn + STTxRollupL2Address -> NTTxRollupL2Address noAnn STNever -> NTNever noAnn STSaplingState s -> NTSaplingState noAnn s STSaplingTransaction s -> NTSaplingTransaction noAnn s @@ -227,63 +229,6 @@ isStar :: SingI t => Notes t -> Bool isStar = (== starNotes) --- | Combines two annotations trees @a@ and @b@ into a new one @c@ --- in such a way that @c@ can be obtained from both @a@ and @b@ by replacing --- some empty leaves with type or/and field annotations. -converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t) -converge n1 n2 = case (n1, n2) of - (NTInt a, NTInt b) -> NTInt <$> convergeAnns a b - (NTNat a, NTNat b) -> NTNat <$> convergeAnns a b - (NTString a, NTString b) -> NTString <$> convergeAnns a b - (NTBytes a, NTBytes b) -> NTBytes <$> convergeAnns a b - (NTMutez a, NTMutez b) -> NTMutez <$> convergeAnns a b - (NTBool a, NTBool b) -> NTBool <$> convergeAnns a b - (NTKeyHash a, NTKeyHash b) -> NTKeyHash <$> convergeAnns a b - (NTBls12381Fr a, NTBls12381Fr b) -> NTBls12381Fr <$> convergeAnns a b - (NTBls12381G1 a, NTBls12381G1 b) -> NTBls12381G1 <$> convergeAnns a b - (NTBls12381G2 a, NTBls12381G2 b) -> NTBls12381G2 <$> convergeAnns a b - (NTTimestamp a, NTTimestamp b) -> NTTimestamp <$> convergeAnns a b - (NTAddress a, NTAddress b) -> NTAddress <$> convergeAnns a b - (NTKey a, NTKey b) -> NTKey <$> convergeAnns a b - (NTUnit a, NTUnit b) -> NTUnit <$> convergeAnns a b - (NTChest a, NTChest b) -> NTChest <$> convergeAnns a b - (NTChestKey a, NTChestKey b) -> NTChestKey <$> convergeAnns a b - (NTNever a, NTNever b) -> NTNever <$> convergeAnns a b - (NTSaplingState a _, NTSaplingState b s) -> - (\c -> NTSaplingState c s) <$> convergeAnns a b - (NTSaplingTransaction a _, NTSaplingTransaction b s) -> - (\c -> NTSaplingTransaction c s) <$> convergeAnns a b - (NTSignature a, NTSignature b) -> - NTSignature <$> convergeAnns a b - (NTChainId a, NTChainId b) -> - NTChainId <$> convergeAnns a b - (NTOption a n, NTOption b m) -> - NTOption <$> convergeAnns a b <*> converge n m - (NTList a n, NTList b m) -> - NTList <$> convergeAnns a b <*> converge n m - (NTSet a n, NTSet b m) -> - NTSet <$> convergeAnns a b <*> converge n m - (NTOperation a, NTOperation b) -> - NTOperation <$> convergeAnns a b - (NTContract a n, NTContract b m) -> - NTContract <$> convergeAnns a b <*> converge n m - (NTTicket a n, NTTicket b m) -> - NTTicket <$> convergeAnns a b <*> converge n m - (NTPair a pF qF pV qV pN qN, NTPair b pG qG pW qW pM qM) -> - NTPair <$> convergeAnns a b - <*> convergeAnns pF pG <*> convergeAnns qF qG - <*> pure (convergeVarAnns pV pW) <*> pure (convergeVarAnns qV qW) - <*> converge pN pM <*> converge qN qM - (NTOr a pF qF pN qN, NTOr b pG qG pM qM) -> - NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG - <*> converge pN pM <*> converge qN qM - (NTLambda a pN qN, NTLambda b pM qM) -> - NTLambda <$> convergeAnns a b <*> converge pN pM <*> converge qN qM - (NTMap a kN vN, NTMap b kM vM) -> - NTMap <$> convergeAnns a b <*> converge kN kM <*> converge vN vM - (NTBigMap a kN vN, NTBigMap b kM vM) -> - NTBigMap <$> convergeAnns a b <*> converge kN kM <*> converge vN vM - -- | Insert the provided type annotation into the provided notes. insertTypeAnn :: forall (b :: T). TypeAnn -> Notes b -> Notes b insertTypeAnn nt s = case s of @@ -316,43 +261,152 @@ NTChainId _ -> NTChainId nt NTChest _ -> NTChest nt NTChestKey _ -> NTChestKey nt + NTTxRollupL2Address _ -> NTTxRollupL2Address nt NTNever _ -> NTNever nt NTSaplingState _ n -> NTSaplingState nt n NTSaplingTransaction _ n -> NTSaplingTransaction nt n -data AnnConvergeError where - AnnConvergeError - :: forall (tag :: Type). - (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) - => Annotation tag -> Annotation tag -> AnnConvergeError +-- | A typed heterogenous list of annotations. Simplified pattern synonyms for +-- common use cases are provided. +data Anns xs where + AnnsCons :: Typeable tag => !(Annotation tag) -> Anns xs -> Anns (Annotation tag ': xs) + AnnsTyCons :: SingI t => !(Notes t) -> Anns xs -> Anns (Notes t ': xs) + AnnsNil :: Anns '[] -deriving stock instance Show AnnConvergeError +infixr 5 `AnnsCons` +infixr 5 `AnnsTyCons` -instance Eq AnnConvergeError where - AnnConvergeError ann1 ann2 == AnnConvergeError ann1' ann2' = - (ann1 `eqParam1` ann1') && (ann2 `eqParam1` ann2') +deriveGADTNFData ''Anns -instance Buildable AnnConvergeError where - build (AnnConvergeError ann1 ann2) = - "Annotations do not converge: " +| ann1 |+ " /= " +| ann2 |+ "" +deriving stock instance (Each '[Show] rs) => Show (Anns rs) +deriving stock instance (Eq r, Eq (Anns rs)) => Eq (Anns (r ': rs)) -convergeAnnsImpl - :: forall (tag :: Type). - (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) - => (Annotation tag -> Annotation tag -> Maybe (Annotation tag)) - -> Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag) -convergeAnnsImpl unify a b = maybe (Left $ AnnConvergeError a b) pure $ unify a b +instance Eq (Anns '[]) where + AnnsNil == AnnsNil = True --- | Converge two type or field notes (which may be wildcards). -convergeAnns - :: forall (tag :: Type). - (Buildable (Annotation tag), Show (Annotation tag), Typeable tag) - => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag) -convergeAnns = convergeAnnsImpl unifyAnn +-- | 'Anns' only containing a single 'VarAnn'. +type AnnVar = Anns '[VarAnn] --- | Converge two field notes in CAR, CDR or UNPAIR, given that one of them may be a --- special annotation. -convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn -convergeDestrAnns = convergeAnnsImpl unifyPairFieldAnn +instance Default (Anns '[]) where + def = AnnsNil -$(deriveGADTNFData ''AnnConvergeError) +instance (Typeable tag, Default (Anns xs)) => Default (Anns (Annotation tag ': xs)) where + def = noAnn `AnnsCons` def + +instance (SingI t, Default (Anns xs)) => Default (Anns (Notes t ': xs)) where + def = starNotes `AnnsTyCons` def + +type family AnnotateInstrArg (xs :: [Type]) r where + AnnotateInstrArg (Notes _ ': xs) r = Un.Ty -> AnnotateInstrArg xs r + AnnotateInstrArg (x ': xs) r = x -> AnnotateInstrArg xs r + AnnotateInstrArg '[] r = r + +-- | Utility typeclass to simplify extracting annotations from 'Anns' and +-- passing those as arguments to an untyped instruction data constructor. +class AnnotateInstr (xs :: [Type]) r where + annotateInstr :: Anns xs -> AnnotateInstrArg xs r -> r + +instance AnnotateInstr '[] r where + annotateInstr (AnnsNil) c = c + +instance AnnotateInstr xs r => AnnotateInstr (Annotation tag ': xs) r where + annotateInstr (AnnsCons va xs) c = annotateInstr @_ @r xs $ c va + +instance AnnotateInstr xs r => AnnotateInstr (Notes t ': xs) r where + annotateInstr (AnnsTyCons va xs) c = annotateInstr @_ @r xs $ c (mkUType va) + +-- | Convenience pattern synonym matching a single simple annotation. +pattern Anns1 :: Typeable a => Annotation a -> Anns '[Annotation a] +pattern Anns1 x = x `AnnsCons` AnnsNil + +-- | Convenience pattern synonym matching two simple annotations. +pattern Anns2 + :: Each '[Typeable] '[a, b] + => Annotation a + -> Annotation b + -> Anns '[Annotation a, Annotation b] +pattern Anns2 x y = x `AnnsCons` y `AnnsCons` AnnsNil + +-- | Convenience pattern synonym matching two annotations, first being +-- a simple one, the second being 'Notes', corresponding to an annotated +-- type. +pattern Anns2' :: (Typeable a, SingI t) => Annotation a -> Notes t -> Anns '[Annotation a, Notes t] +pattern Anns2' x y = x `AnnsCons` y `AnnsTyCons` AnnsNil + +-- | Convenience pattern synonym matching three simple annotations. +pattern Anns3 + :: Each '[Typeable] '[a, b, c] + => Annotation a + -> Annotation b + -> Annotation c + -> Anns '[Annotation a, Annotation b, Annotation c] +pattern Anns3 x y z = x `AnnsCons` y `AnnsCons` z `AnnsCons` AnnsNil + +-- | Convenience pattern synonym matching three annotations, first two being +-- simple, the last one being 'Notes', corresponding to an annotated +-- type. +pattern Anns3' + :: (Each '[Typeable] '[a, b], SingI t) + => Annotation a + -> Annotation b + -> Notes t + -> Anns '[Annotation a, Annotation b, Notes t] +pattern Anns3' x y z = x `AnnsCons` y `AnnsCons` z `AnnsTyCons` AnnsNil + +-- | Convenience pattern synonym matching three annotations, first being +-- a simple one, the last two being 'Notes', corresponding to annotated +-- types. +pattern Anns3'' + :: (Typeable a, SingI t, SingI u) + => Annotation a + -> Notes t + -> Notes u + -> Anns '[Annotation a, Notes t, Notes u] +pattern Anns3'' x y z = x `AnnsCons` y `AnnsTyCons` z `AnnsTyCons` AnnsNil + +-- | Convenience pattern synonym matching four simple annotations. +pattern Anns4 + :: Each '[Typeable] '[a, b, c, d] + => Annotation a + -> Annotation b + -> Annotation c + -> Annotation d + -> Anns '[Annotation a, Annotation b, Annotation c, Annotation d] +pattern Anns4 x y z w = x `AnnsCons` y `AnnsCons` z `AnnsCons` w `AnnsCons` AnnsNil + +-- | Convenience pattern synonym matching four annotations, first two being +-- simple, the last two being 'Notes', corresponding to annotated +-- types. +pattern Anns4'' + :: (Each '[Typeable] '[a, b], SingI t, SingI u) + => Annotation a + -> Annotation b + -> Notes t + -> Notes u + -> Anns '[Annotation a, Annotation b, Notes t, Notes u] +pattern Anns4'' x y z w + = x `AnnsCons` y `AnnsCons` z `AnnsTyCons` w `AnnsTyCons` AnnsNil + +-- | Convenience pattern synonym matching five annotations, first four being +-- simple, the last one being 'Notes', corresponding to an annotated +-- type. +pattern Anns5' + :: (Each '[Typeable] '[a, b, c, d], SingI t) + => Annotation a + -> Annotation b + -> Annotation c + -> Annotation d + -> Notes t + -> Anns '[Annotation a, Annotation b, Annotation c, Annotation d, Notes t] +pattern Anns5' x y z v w + = x `AnnsCons` y `AnnsCons` z `AnnsCons` v `AnnsCons` w `AnnsTyCons` AnnsNil + +{-# COMPLETE Anns1 #-} +{-# COMPLETE Anns2 #-} +{-# COMPLETE Anns2' #-} +{-# COMPLETE Anns3 #-} +{-# COMPLETE Anns3' #-} +{-# COMPLETE Anns3'' #-} +{-# COMPLETE Anns4 #-} +{-# COMPLETE Anns4'' #-} +{-# COMPLETE Anns5' #-} diff --git a/src/Morley/Michelson/Typed/Arith.hs b/src/Morley/Michelson/Typed/Arith.hs --- a/src/Morley/Michelson/Typed/Arith.hs +++ b/src/Morley/Michelson/Typed/Arith.hs @@ -42,13 +42,10 @@ import Fmt (Buildable(build), (+|), (|+)) import Unsafe qualified (fromIntegral) -import Morley.Michelson.Typed.Annotation - (AnnConvergeError, Notes(..), converge, convergeAnns, starNotes) import Morley.Michelson.Typed.Polymorphic import Morley.Michelson.Typed.Scope (Comparable) import Morley.Michelson.Typed.T (T(..)) import Morley.Michelson.Typed.Value (Value'(..)) -import Morley.Michelson.Untyped.Annotation (noAnn) import Morley.Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds) import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Morley.Util.TypeLits @@ -70,13 +67,6 @@ -- @ArithRes Add CNat CInt = CInt@. type ArithRes aop n m :: T - -- | Converge the notes of given operands. - convergeArith - :: proxy aop - -> Notes n - -> Notes m - -> Either AnnConvergeError (Notes (ArithRes aop n m)) - -- | Evaluate arithmetic operation on given operands. evalOp :: proxy aop @@ -155,200 +145,161 @@ instance ArithOp Add 'TNat 'TInt where type ArithRes Add 'TNat 'TInt = 'TInt - convergeArith _ _ n2 = Right n2 evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i + j) commutativityProof = Just Dict instance ArithOp Add 'TInt 'TNat where type ArithRes Add 'TInt 'TNat = 'TInt - convergeArith _ n1 _ = Right n1 evalOp _ (VInt i) (VNat j) = Right $ VInt (i + toInteger j) commutativityProof = Just Dict instance ArithOp Add 'TNat 'TNat where type ArithRes Add 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VNat i) (VNat j) = Right $ VNat (i + j) commutativityProof = Just Dict instance ArithOp Add 'TInt 'TInt where type ArithRes Add 'TInt 'TInt = 'TInt - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VInt i) (VInt j) = Right $ VInt (i + j) commutativityProof = Just Dict instance ArithOp Add 'TTimestamp 'TInt where type ArithRes Add 'TTimestamp 'TInt = 'TTimestamp - convergeArith _ n1 _ = Right n1 evalOp _ (VTimestamp i) (VInt j) = Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i + j commutativityProof = Just Dict instance ArithOp Add 'TInt 'TTimestamp where type ArithRes Add 'TInt 'TTimestamp = 'TTimestamp - convergeArith _ _ n2 = Right n2 evalOp _ (VInt i) (VTimestamp j) = Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds j + i commutativityProof = Just Dict instance ArithOp Add 'TMutez 'TMutez where type ArithRes Add 'TMutez 'TMutez = 'TMutez - convergeArith _ n1 n2 = converge n1 n2 evalOp _ n@(VMutez i) m@(VMutez j) = res where res = maybe (Left $ MutezArithError AddOverflow n m) (Right . VMutez) $ i `addMutez` j commutativityProof = Just Dict instance ArithOp Add 'TBls12381Fr 'TBls12381Fr where type ArithRes Add 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VBls12381Fr i) (VBls12381Fr j) = Right $ VBls12381Fr (BLS.add i j) commutativityProof = Just Dict instance ArithOp Add 'TBls12381G1 'TBls12381G1 where type ArithRes Add 'TBls12381G1 'TBls12381G1 = 'TBls12381G1 - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VBls12381G1 i) (VBls12381G1 j) = Right $ VBls12381G1 (BLS.add i j) commutativityProof = Just Dict instance ArithOp Add 'TBls12381G2 'TBls12381G2 where type ArithRes Add 'TBls12381G2 'TBls12381G2 = 'TBls12381G2 - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VBls12381G2 i) (VBls12381G2 j) = Right $ VBls12381G2 (BLS.add i j) commutativityProof = Just Dict instance ArithOp Sub 'TNat 'TInt where type ArithRes Sub 'TNat 'TInt = 'TInt - convergeArith _ _ n2 = Right n2 evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i - j) instance ArithOp Sub 'TInt 'TNat where type ArithRes Sub 'TInt 'TNat = 'TInt - convergeArith _ n1 _ = Right n1 evalOp _ (VInt i) (VNat j) = Right $ VInt (i - toInteger j) instance ArithOp Sub 'TNat 'TNat where type ArithRes Sub 'TNat 'TNat = 'TInt - -- | Subtraction between @Nat@ and @Nat@ does not retain annotation. - convergeArith _ n1 n2 = starNotes <$ converge n1 n2 evalOp _ (VNat i) (VNat j) = Right $ VInt (toInteger i - toInteger j) instance ArithOp Sub 'TInt 'TInt where type ArithRes Sub 'TInt 'TInt = 'TInt - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VInt i) (VInt j) = Right $ VInt (i - j) instance ArithOp Sub 'TTimestamp 'TInt where type ArithRes Sub 'TTimestamp 'TInt = 'TTimestamp - convergeArith _ n1 _ = Right n1 evalOp _ (VTimestamp i) (VInt j) = Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i - j instance ArithOp Sub 'TTimestamp 'TTimestamp where type ArithRes Sub 'TTimestamp 'TTimestamp = 'TInt - convergeArith _ (NTTimestamp a) (NTTimestamp b) = NTInt <$> (convergeAnns a b) evalOp _ (VTimestamp i) (VTimestamp j) = Right $ VInt $ timestampToSeconds i - timestampToSeconds j instance ArithOp SubMutez 'TMutez 'TMutez where type ArithRes SubMutez 'TMutez 'TMutez = 'TOption 'TMutez - convergeArith _ n1 n2 = NTOption noAnn <$> converge n1 n2 evalOp _ (VMutez i) (VMutez j) = Right $ VOption $ fmap VMutez $ i `subMutez` j instance ArithOp Mul 'TNat 'TInt where type ArithRes Mul 'TNat 'TInt = 'TInt - convergeArith _ _ n2 = Right n2 evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i * j) commutativityProof = Just Dict instance ArithOp Mul 'TInt 'TNat where type ArithRes Mul 'TInt 'TNat = 'TInt - convergeArith _ n1 _ = Right n1 evalOp _ (VInt i) (VNat j) = Right $ VInt (i * toInteger j) commutativityProof = Just Dict instance ArithOp Mul 'TNat 'TNat where type ArithRes Mul 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VNat i) (VNat j) = Right $ VNat (i * j) commutativityProof = Just Dict instance ArithOp Mul 'TInt 'TInt where type ArithRes Mul 'TInt 'TInt = 'TInt - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VInt i) (VInt j) = Right $ VInt (i * j) commutativityProof = Just Dict instance ArithOp Mul 'TNat 'TMutez where type ArithRes Mul 'TNat 'TMutez = 'TMutez - convergeArith _ _ n2 = Right n2 evalOp _ n@(VNat i) m@(VMutez j) = res where res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ j `mulMutez` i commutativityProof = Just Dict instance ArithOp Mul 'TMutez 'TNat where type ArithRes Mul 'TMutez 'TNat = 'TMutez - convergeArith _ n1 _ = Right n1 evalOp _ n@(VMutez i) m@(VNat j) = res where res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ i `mulMutez` j commutativityProof = Just Dict instance ArithOp Mul 'TInt 'TBls12381Fr where type ArithRes Mul 'TInt 'TBls12381Fr = 'TBls12381Fr - convergeArith _ (NTInt n1) _ = Right $ (NTBls12381Fr n1) evalOp _ (VInt i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegralOverflowing @Integer @BLS.Bls12381Fr i * j) commutativityProof = Just Dict instance ArithOp Mul 'TNat 'TBls12381Fr where type ArithRes Mul 'TNat 'TBls12381Fr = 'TBls12381Fr - convergeArith _ (NTNat n1) _ = Right (NTBls12381Fr n1) evalOp _ (VNat i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegralOverflowing @Natural @BLS.Bls12381Fr i * j) commutativityProof = Just Dict instance ArithOp Mul 'TBls12381Fr 'TInt where type ArithRes Mul 'TBls12381Fr 'TInt = 'TBls12381Fr - convergeArith _ n1 _ = Right n1 evalOp _ (VBls12381Fr i) (VInt j) = Right $ VBls12381Fr (i * fromIntegralOverflowing @Integer @BLS.Bls12381Fr j) commutativityProof = Just Dict instance ArithOp Mul 'TBls12381Fr 'TNat where type ArithRes Mul 'TBls12381Fr 'TNat = 'TBls12381Fr - convergeArith _ n1 _ = Right n1 evalOp _ (VBls12381Fr i) (VNat j) = Right $ VBls12381Fr (i * fromIntegralOverflowing @Natural @BLS.Bls12381Fr j) commutativityProof = Just Dict instance ArithOp Mul 'TBls12381Fr 'TBls12381Fr where type ArithRes Mul 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr - convergeArith _ n1 _ = Right n1 evalOp _ (VBls12381Fr i) (VBls12381Fr j) = Right $ VBls12381Fr (i * j) commutativityProof = Just Dict instance ArithOp Mul 'TBls12381G1 'TBls12381Fr where type ArithRes Mul 'TBls12381G1 'TBls12381Fr = 'TBls12381G1 - convergeArith _ n1 _ = Right n1 evalOp _ (VBls12381G1 i) (VBls12381Fr j) = Right $ VBls12381G1 (BLS.multiply j i) commutativityProof = Nothing instance ArithOp Mul 'TBls12381G2 'TBls12381Fr where type ArithRes Mul 'TBls12381G2 'TBls12381Fr = 'TBls12381G2 - convergeArith _ n1 _ = Right n1 evalOp _ (VBls12381G2 i) (VBls12381Fr j) = Right $ VBls12381G2 (BLS.multiply j i) commutativityProof = Nothing instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G1 => ArithOp Mul 'TBls12381Fr 'TBls12381G1 where type ArithRes Mul 'TBls12381Fr 'TBls12381G1 = 'TBls12381G1 - convergeArith = error "impossible" evalOp = error "impossible" commutativityProof = error "impossible" instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G2 => ArithOp Mul 'TBls12381Fr 'TBls12381G2 where type ArithRes Mul 'TBls12381Fr 'TBls12381G2 = 'TBls12381G2 - convergeArith = error "impossible" evalOp = error "impossible" commutativityProof = error "impossible" instance ArithOp EDiv 'TNat 'TInt where type ArithRes EDiv 'TNat 'TInt = 'TOption ('TPair (EDivOpRes 'TNat 'TInt) (EModOpRes 'TNat 'TInt)) - convergeArith _ n1 n2 = convergeEDiv n1 n2 evalOp _ i j = Right $ evalEDivOp i j instance ArithOp EDiv 'TInt 'TNat where type ArithRes EDiv 'TInt 'TNat = 'TOption ('TPair (EDivOpRes 'TInt 'TNat) (EModOpRes 'TInt 'TNat)) - convergeArith _ n1 n2 = convergeEDiv n1 n2 evalOp _ i j = Right $ evalEDivOp i j instance ArithOp EDiv 'TNat 'TNat where type ArithRes EDiv 'TNat 'TNat = 'TOption ('TPair (EDivOpRes 'TNat 'TNat) (EModOpRes 'TNat 'TNat)) - convergeArith _ n1 n2 = convergeEDiv n1 n2 evalOp _ i j = Right $ evalEDivOp i j instance ArithOp EDiv 'TInt 'TInt where type ArithRes EDiv 'TInt 'TInt = 'TOption ('TPair (EDivOpRes 'TInt 'TInt) (EModOpRes 'TInt 'TInt)) - convergeArith _ n1 n2 = convergeEDiv n1 n2 evalOp _ i j = Right $ evalEDivOp i j instance ArithOp EDiv 'TMutez 'TMutez where type ArithRes EDiv 'TMutez 'TMutez = 'TOption ('TPair (EDivOpRes 'TMutez 'TMutez) (EModOpRes 'TMutez 'TMutez)) - convergeArith _ n1 n2 = convergeEDiv n1 n2 evalOp _ i j = Right $ evalEDivOp i j instance ArithOp EDiv 'TMutez 'TNat where type ArithRes EDiv 'TMutez 'TNat = 'TOption ('TPair (EDivOpRes 'TMutez 'TNat) (EModOpRes 'TMutez 'TNat)) - convergeArith _ n1 n2 = convergeEDiv n1 n2 evalOp _ i j = Right $ evalEDivOp i j type family Bls12381MulBadOrder a1 a2 where @@ -380,44 +331,36 @@ instance ArithOp Or 'TNat 'TNat where type ArithRes Or 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VNat i) (VNat j) = Right $ VNat (i .|. j) commutativityProof = Just Dict instance ArithOp Or 'TBool 'TBool where type ArithRes Or 'TBool 'TBool = 'TBool - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VBool i) (VBool j) = Right $ VBool (i .|. j) commutativityProof = Just Dict instance ArithOp And 'TInt 'TNat where type ArithRes And 'TInt 'TNat = 'TNat - convergeArith _ _ n2 = Right n2 evalOp _ (VInt i) (VNat j) = Right $ VNat (fromInteger (i .&. toInteger j)) instance ArithOp And 'TNat 'TNat where type ArithRes And 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VNat i) (VNat j) = Right $ VNat (i .&. j) commutativityProof = Just Dict instance ArithOp And 'TBool 'TBool where type ArithRes And 'TBool 'TBool = 'TBool - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VBool i) (VBool j) = Right $ VBool (i .&. j) commutativityProof = Just Dict instance ArithOp Xor 'TNat 'TNat where type ArithRes Xor 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VNat i) (VNat j) = Right $ VNat (i `xor` j) commutativityProof = Just Dict instance ArithOp Xor 'TBool 'TBool where type ArithRes Xor 'TBool 'TBool = 'TBool - convergeArith _ n1 n2 = converge n1 n2 evalOp _ (VBool i) (VBool j) = Right $ VBool (i `xor` j) commutativityProof = Just Dict instance ArithOp Lsl 'TNat 'TNat where type ArithRes Lsl 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ n@(VNat i) m@(VNat j) = if j > 256 then Left $ ShiftArithError LslOverflow n m @@ -425,7 +368,6 @@ instance ArithOp Lsr 'TNat 'TNat where type ArithRes Lsr 'TNat 'TNat = 'TNat - convergeArith _ n1 n2 = converge n1 n2 evalOp _ n@(VNat i) m@(VNat j) = if j > 256 then Left $ ShiftArithError LsrUnderflow n m diff --git a/src/Morley/Michelson/Typed/Contract.hs b/src/Morley/Michelson/Typed/Contract.hs --- a/src/Morley/Michelson/Typed/Contract.hs +++ b/src/Morley/Michelson/Typed/Contract.hs @@ -11,8 +11,11 @@ , ContractInp , ContractOut1 , ContractOut - , ContractCode' + , ContractCode' (..) + , mkContractCode , Contract' (..) + , IsNotInView + , giveNotInView , defaultContract , mapContractCode , mapContractCodeBlock @@ -20,7 +23,10 @@ , mapEntriesOrdered ) where +import Data.Constraint (Dict(..)) import Data.Default (Default(..)) +import GHC.TypeLits (TypeError, pattern Text) +import Unsafe.Coerce (unsafeCoerce) import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Entrypoints @@ -35,8 +41,52 @@ type ContractOut1 st = 'TPair ('TList 'TOperation) st type ContractOut st = '[ ContractOut1 st ] -type ContractCode' instr cp st = instr (ContractInp cp st) (ContractOut st) +-- | A wrapper for contract code. The newtype is mostly there to avoid +-- accidentally passing code from inside @ContractCode@ into a view for example, +-- as semantics are slightly different. +newtype ContractCode' instr cp st = + ContractCode { unContractCode :: instr (ContractInp cp st) (ContractOut st) } +deriving stock instance Show (instr (ContractInp cp st) (ContractOut st)) + => Show (ContractCode' instr cp st) + +deriving stock instance Eq (instr (ContractInp cp st) (ContractOut st)) + => Eq (ContractCode' instr cp st) + +deriving newtype instance NFData (instr (ContractInp cp st) (ContractOut st)) + => NFData (ContractCode' instr cp st) + +-- | A helper to construct @ContractCode'@. This helper provides the constraint +-- that the contract code is not in a view. +mkContractCode + :: (IsNotInView => instr (ContractInp cp st) (ContractOut st)) + -> ContractCode' instr cp st +mkContractCode x = ContractCode $ giveNotInView x + +-- | Constraint ensuring the given code does not appear on the top level of a +-- view. Some Michelson instructions are forbidden on the top level of views, +-- but allowed in main contract code, and also inside lambdas in views. Hence, +-- this constraint can be provided by 'mkContractCode' or by @mkVLam@. +class IsNotInView + +-- NB: This instance is a giant hack. It happens to work because explicit dicts +-- override other in-scope instances. The good news is, if this hack stops +-- working, we'll notice right away because morley will refuse to compile. +instance TypeError ('Text "Not allowed on the top level of a view") => IsNotInView + +-- | An empty typeclass that has an in-scope instance that we @unsafeCoerce@ +-- into 'IsNotInView' in 'giveNotInView'. Not intended to be exported. +-- +-- Dicts of all empty classes are representationally equivalent, so this is +-- "safe" (as in we won't get segfaults). +class FakeClass +instance FakeClass + +-- | Pull a constraint 'IsNotInView' out of thin air. Use this with caution, +-- as you could easily construct an invalid contract by using this directly. +giveNotInView :: (IsNotInView => r) -> r +giveNotInView = withDict (unsafeCoerce (Dict :: Dict FakeClass) :: Dict IsNotInView) + -- | Typed contract and information about annotations -- which is not present in the contract code. data Contract' instr cp st = (ParameterScope cp, StorageScope st) => Contract @@ -60,9 +110,12 @@ NFData (Contract' instr cp st) where rnf (Contract a b c d e) = rnf (a, b, c, d, e) -defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode' instr cp st -> Contract' instr cp st +defaultContract + :: (ParameterScope cp, StorageScope st) + => (IsNotInView => instr (ContractInp cp st) (ContractOut st)) + -> Contract' instr cp st defaultContract code = Contract - { cCode = code + { cCode = mkContractCode code , cParamNotes = starParamNotes , cStoreNotes = starNotes , cEntriesOrder = def @@ -73,10 +126,13 @@ -- -- To map e.g. views too, see 'mapContractCode'. mapContractCodeBlock - :: (ContractCode' instr cp st -> ContractCode' instr cp st) + :: (instr (ContractInp cp st) (ContractOut st) + -> instr (ContractInp cp st) (ContractOut st)) -> Contract' instr cp st -> Contract' instr cp st -mapContractCodeBlock f contract = contract { cCode = f $ cCode contract } +mapContractCodeBlock f contract = contract { cCode = + case cCode contract of + ContractCode c -> ContractCode $ f c } mapContractViewBlocks :: (forall arg ret. ViewCode' instr arg st ret -> ViewCode' instr arg st ret) diff --git a/src/Morley/Michelson/Typed/Convert.hs b/src/Morley/Michelson/Typed/Convert.hs --- a/src/Morley/Michelson/Typed/Convert.hs +++ b/src/Morley/Michelson/Typed/Convert.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - {-# OPTIONS_GHC -Wno-orphans #-} module Morley.Michelson.Typed.Convert @@ -24,6 +21,7 @@ -- * Misc , flattenEntrypoints + , eqInstrExt ) where import Data.ByteArray qualified as ByteArray @@ -31,15 +29,14 @@ import Data.List.NonEmpty ((<|)) import Data.Map qualified as Map import Data.Singletons (Sing, demote, withSingI) -import Data.Vinyl (Rec(..)) -import Fmt (Buildable(..), Builder, blockListF, fmt, indentF, listF, pretty, unlinesF) +import Fmt (Buildable(..), fmt, listF, pretty) import Text.PrettyPrint.Leijen.Text (Doc) import Unsafe qualified (fromIntegral) import Morley.Michelson.Printer.Util import Morley.Michelson.Text import Morley.Michelson.Typed.Aliases -import Morley.Michelson.Typed.Annotation (Notes(..), mkUType) +import Morley.Michelson.Typed.Annotation (annotateInstr, mkUType) import Morley.Michelson.Typed.Contract import Morley.Michelson.Typed.Entrypoints import Morley.Michelson.Typed.Extract (toUType) @@ -51,7 +48,7 @@ import Morley.Michelson.Typed.View import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Annotation (Annotation(unAnnotation)) -import Morley.Tezos.Address (Address(..), ContractHash(..)) +import Morley.Tezos.Address hiding (ta) import Morley.Tezos.Core (ChainId(unChainId), mformatChainId, parseChainId, timestampFromSeconds, timestampToSeconds, tz, unMutez) @@ -69,7 +66,7 @@ convertParamNotes (ParamNotes notes rootAnn) = U.ParameterType (mkUType notes) rootAnn --- | Convert typed 'ContractCode' to an untyped t'U.Contract'. +-- | Convert typed t'ContractCode' to an untyped t'U.Contract'. convertContractCode :: forall param store . (SingI param, SingI store) => ContractCode param store -> U.Contract @@ -77,7 +74,7 @@ U.Contract { contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn , contractStorage = untypeDemoteT @store - , contractCode = instrToOps contract + , contractCode = instrToOps $ unContractCode contract , entriesOrder = U.canonicalEntriesOrder , contractViews = [] } @@ -158,8 +155,8 @@ (VBool False, _) -> U.ValueFalse (VKeyHash h, _) -> case opts of - Readable -> U.ValueString $ mformatKeyHash h - _ -> U.ValueBytes $ U.InternalByteString $ keyHashToBytes h + Readable -> U.ValueString $ mformatHash h + _ -> U.ValueBytes $ U.InternalByteString $ hashToBytes h (VBls12381Fr v, _) -> case opts of Readable -> U.ValueInt $ toInteger v @@ -176,6 +173,10 @@ case opts of Readable -> U.ValueString $ mformatEpAddress a _ -> U.ValueBytes . U.InternalByteString $ encodeEpAddress a + (VTxRollupL2Address (TxRollupL2Address a), _) -> + case opts of + Readable -> U.ValueString $ mformatHash a + _ -> U.ValueBytes . U.InternalByteString $ hashToBytes a (VKey b, _) -> case opts of Readable -> U.ValueString $ mformatPublicKey b @@ -256,12 +257,15 @@ OpAbsent -> untypeValueImpl opts l a <| pairToSeq (b, r) (v, vt) -> untypeValueImpl opts vt v :| [] - keyHashToBytes :: KeyHash -> ByteString - keyHashToBytes kh = (<> (khBytes kh)) $ - case khTag kh of - KeyHashEd25519 -> "\x00" - KeyHashSecp256k1 -> "\x01" - KeyHashP256 -> "\x02" + hashToBytes :: Hash kind -> ByteString + hashToBytes Hash{..} = (<> hBytes) $ + case hTag of + HashEd25519 -> "\x00" + HashSecp256k1 -> "\x01" + HashP256 -> "\x02" + HashContract -> "" + HashBLS -> "" + HashTXR -> "" keyToBytes :: PublicKey -> ByteString keyToBytes = \case @@ -276,9 +280,11 @@ encodeAddress :: Address -> ByteString encodeAddress = \case KeyAddress keyHash -> - "\x00" <> keyHashToBytes keyHash - ContractAddress (ContractHash address) -> - "\x01" <> address <> "\x00" + "\x00" <> hashToBytes keyHash + ContractAddress hash -> + "\x01" <> hashToBytes hash <> "\x00" + TransactionRollupAddress hash -> + "\x02" <> hashToBytes hash <> "\x00" encodeEpName :: EpName -> ByteString encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize @@ -311,455 +317,159 @@ Seq i1 i2 -> instrToOpsImpl opts i1 <> instrToOpsImpl opts i2 Nested sq -> one $ U.SeqEx $ instrToOps sq DocGroup _ sq -> instrToOpsImpl opts sq - Fn t sfn i -> [U.PrimEx . U.EXT . U.FN t sfn $ instrToOps i] Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext FrameInstr _ i -> instrToOpsImpl opts i -- TODO [#283]: After representation of locations is polished, -- this place should be updated to pass it from typed to untyped ASTs. WithLoc _ i -> instrToOpsImpl opts i Meta _ i -> instrToOpsImpl opts i - InstrWithVarAnns _ i -> instrToOpsImpl opts i - InstrWithNotes proxy n i -> case i of - Nop -> instrToOpsImpl opts i - Seq _ _ -> instrToOpsImpl opts i - Nested _ -> instrToOpsImpl opts i - DocGroup _ _ -> instrToOpsImpl opts i - Ext _ -> instrToOpsImpl opts i - WithLoc _ i0 -> instrToOpsImpl opts (InstrWithNotes proxy n i0) - Meta _ i0 -> instrToOpsImpl opts (InstrWithNotes proxy n i0) - InstrWithNotes {} -> instrToOpsImpl opts i - -- For inner instruction, filter out values that we don't want to apply - -- annotations to and delegate it's conversion to this function itself. - -- If none of the above, convert a single instruction and copy annotations - -- to it. - InstrWithVarNotes n0 (InstrWithVarAnns _ i0) -> - instrToOpsImpl opts $ InstrWithNotes proxy n $ InstrWithVarNotes n0 i0 - InstrWithVarNotes n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n n0] - InstrWithVarAnns _ _ -> instrToOpsImpl opts i - _ -> [U.PrimEx $ handleInstrAnnotate i n] - InstrWithVarNotes n i -> case i of - Nop -> instrToOpsImpl opts i - Seq _ _ -> instrToOpsImpl opts i - Nested _ -> instrToOpsImpl opts i - DocGroup _ _ -> instrToOpsImpl opts i - Ext _ -> instrToOpsImpl opts i - WithLoc _ i0 -> instrToOpsImpl opts (InstrWithVarNotes n i0) - Meta _ i0 -> instrToOpsImpl opts (InstrWithVarNotes n i0) - InstrWithNotes p0 n0 (InstrWithVarAnns _ i0) -> - instrToOpsImpl opts $ InstrWithNotes p0 n0 $ InstrWithVarNotes n i0 - InstrWithNotes _ n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n0 n] - InstrWithVarNotes _ _ -> instrToOpsImpl opts i - InstrWithVarAnns _ i0 -> instrToOpsImpl opts $ InstrWithVarNotes n i0 - _ -> [U.PrimEx $ handleInstrVarNotes i n] i -> [U.PrimEx $ handleInstr i] where - handleInstrAnnotateWithVarNotes - :: forall inp' out' topElems . HasCallStack - => Instr inp' out' - -> Rec Notes topElems - -> NonEmpty U.VarAnn - -> U.ExpandedInstr - handleInstrAnnotateWithVarNotes instr notes varAnns = - addVarNotes (addInstrNote (handleInstr instr) notes) varAnns - - handleInstrAnnotate - :: forall inp' out' topElems. HasCallStack - => Instr inp' out' -> Rec Notes topElems -> U.ExpandedInstr - handleInstrAnnotate ins' notes = - addInstrNote (handleInstr ins') notes - - addInstrNote - :: forall topElems. HasCallStack - => U.ExpandedInstr -> Rec Notes topElems -> U.ExpandedInstr - addInstrNote instr notes = - case (instr, notes) of - (U.PUSH va _ v, notes' :& _) -> U.PUSH va (mkUType notes') v - (U.SOME _ va, NTOption ta _ :& _) -> U.SOME ta va - (U.NONE _ va _, (NTOption ta nt :: Notes t) :& _) -> - U.NONE ta va $ mkUType nt - (U.UNIT _ va, NTUnit ta :& _) -> U.UNIT ta va - (U.PAIRN va n, _) -> U.PAIRN va n - (U.LEFT ta va fa1 fa2 _, (NTOr _ _ _ _ n2 :: Notes t) :& _) -> - U.LEFT ta va fa1 fa2 $ mkUType n2 - (U.RIGHT ta va fa1 fa2 _, (NTOr _ _ _ n1 _ :: Notes t) :& _) -> - U.RIGHT ta va fa1 fa2 $ mkUType n1 - (U.NIL _ va _, (NTList ta n :: Notes t) :& _) -> - U.NIL ta va $ mkUType n - (U.EMPTY_SET _ va _, (NTSet ta1 n :: Notes t) :& _) -> - U.EMPTY_SET ta1 va $ mkUType n - (U.EMPTY_MAP _ va _ _, (NTMap ta1 k n :: Notes t) :& _) -> - U.EMPTY_MAP ta1 va (mkUType k) (mkUType n) - (U.EMPTY_BIG_MAP _ va _ _, (NTBigMap ta1 k n :: Notes t) :& _) -> - U.EMPTY_BIG_MAP ta1 va (mkUType k) (mkUType n) - (U.LAMBDA va _ _ ops, (NTLambda _ n1 n2 :: Notes t) :& _) -> - U.LAMBDA va (mkUType n1) (mkUType n2) ops - (U.CAST va _, n :& _) -> U.CAST va (mkUType n) - (U.UNPACK _ va _, (NTOption ta nt :: Notes t) :& _) -> - U.UNPACK ta va (mkUType nt) - (U.CONTRACT va fa _, (NTOption _ (NTContract _ nt :: Notes t) :: Notes t2) :& _) -> - U.CONTRACT va fa (mkUType nt) - (U.CONTRACT va fa t, NTOption _ _ :& _) -> U.CONTRACT va fa t - (U.CAR {}, _) -> instr - (U.CDR {}, _) -> instr - (U.PAIR {}, _) -> instr - (U.UNPAIR {}, _) -> instr - (U.APPLY {}, _) -> instr - (U.CHAIN_ID {}, _) -> instr - (U.EXT _, _) -> instr - (U.DROP, _) -> instr - (U.DROPN _, _) -> instr - (U.DUP _, _) -> instr - (U.DUPN _ _, _) -> instr - (U.SWAP, _) -> instr - (U.DIG {}, _) -> instr - (U.DUG {}, _) -> instr - (U.IF_NONE _ _, _) -> instr - (U.CONS _, _) -> instr - (U.IF_LEFT _ _, _) -> instr - (U.IF_CONS _ _, _) -> instr - (U.SIZE _, _) -> instr - (U.MAP _ _, _) -> instr - (U.ITER _, _) -> instr - (U.MEM _, _) -> instr - (U.GET _, _) -> instr - (U.GETN _ _, _) -> instr - (U.UPDATE _, _) -> instr - (U.UPDATEN _ _, _) -> instr - (U.GET_AND_UPDATE _, _) -> instr - (U.IF _ _, _) -> instr - (U.LOOP _, _) -> instr - (U.LOOP_LEFT _, _) -> instr - (U.EXEC _, _) -> instr - (U.DIP _, _) -> instr - (U.DIPN {}, _) -> instr - (U.FAILWITH, _) -> instr - (U.RENAME _, _) -> instr - (U.PACK _, _) -> instr - (U.CONCAT _, _) -> instr - (U.SLICE _, _) -> instr - (U.ISNAT _, _) -> instr - (U.ADD _, _) -> instr - (U.SUB _, _) -> instr - (U.SUB_MUTEZ _, _) -> instr - (U.MUL _, _) -> instr - (U.EDIV _, _) -> instr - (U.ABS _, _) -> instr - (U.NEG _, _) -> instr - (U.LSL _, _) -> instr - (U.LSR _, _) -> instr - (U.OR _, _) -> instr - (U.AND _, _) -> instr - (U.XOR _, _) -> instr - (U.NOT _, _) -> instr - (U.COMPARE _, _) -> instr - (U.EQ _, _) -> instr - (U.NEQ _, _) -> instr - (U.LT _, _) -> instr - (U.GT _, _) -> instr - (U.LE _, _) -> instr - (U.GE _, _) -> instr - (U.INT _, _) -> instr - (U.VIEW{}, _) -> instr - (U.SELF _ _, _) -> instr - (U.TRANSFER_TOKENS _, _) -> instr - (U.SET_DELEGATE _, _) -> instr - (U.CREATE_CONTRACT {}, _) -> instr - (U.IMPLICIT_ACCOUNT _, _) -> instr - (U.NOW _, _) -> instr - (U.LEVEL _, _) -> instr - (U.AMOUNT _, _) -> instr - (U.BALANCE _, _) -> instr - (U.VOTING_POWER _, _) -> instr - (U.TOTAL_VOTING_POWER _, _) -> instr - (U.CHECK_SIGNATURE _, _) -> instr - (U.SHA256 _, _) -> instr - (U.SHA512 _, _) -> instr - (U.BLAKE2B _, _) -> instr - (U.SHA3 _, _) -> instr - (U.KECCAK _, _) -> instr - (U.HASH_KEY _, _) -> instr - (U.SOURCE _, _) -> instr - (U.SENDER _, _) -> instr - (U.ADDRESS _, _) -> instr - (U.SELF_ADDRESS _, _) -> instr - (U.NEVER, _) -> instr - (U.TICKET _, _) -> instr - (U.READ_TICKET _, _) -> instr - (U.SPLIT_TICKET _, _) -> instr - (U.JOIN_TICKETS _, _) -> instr - _ -> error $ pretty $ unlinesF - [ "addInstrNote: Unexpected instruction/annotation combination" - , "Instruction:" - , indentF 2 $ build instr - , "Annotations:" - , indentF 2 $ blockListF $ buildNotes notes - ] - where - buildNotes :: Rec Notes ts -> [Builder] - buildNotes = \case - RNil -> [] - n :& ns -> build n : buildNotes ns - - handleInstrVarNotes :: forall inp' out' . HasCallStack - => Instr inp' out' -> NonEmpty U.VarAnn -> U.ExpandedInstr - handleInstrVarNotes ins' varAnns = - let x = handleInstr ins' in addVarNotes x varAnns - - addVarNotes - :: HasCallStack - => U.ExpandedInstr -> NonEmpty U.VarAnn -> U.ExpandedInstr - addVarNotes ins varNotes = case varNotes of - va1 :| [va2] -> case ins of - U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va1 va2 c - _ -> error $ - "addVarNotes: Cannot add two var annotations to instr: " <> pretty ins - va :| [] -> case ins of - U.DUP _ -> U.DUP va - U.DUPN _ s -> U.DUPN va s - U.PUSH _ t v -> U.PUSH va t v - U.SOME ta _ -> U.SOME ta va - U.NONE ta _ t -> U.NONE ta va t - U.UNIT ta _ -> U.UNIT ta va - U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2 - U.PAIRN _ n -> U.PAIRN va n - U.LEFT ta _ fa1 fa2 t -> U.LEFT ta va fa1 fa2 t - U.RIGHT ta _ fa1 fa2 t -> U.RIGHT ta va fa1 fa2 t - U.NIL ta _ t -> U.NIL ta va t - U.CONS _ -> U.CONS va - U.SIZE _ -> U.SIZE va - U.EMPTY_SET ta _ c -> U.EMPTY_SET ta va c - U.EMPTY_MAP ta _ c t -> U.EMPTY_MAP ta va c t - U.EMPTY_BIG_MAP ta _ c t -> U.EMPTY_BIG_MAP ta va c t - U.MAP _ ops -> U.MAP va ops - U.MEM _ -> U.MEM va - U.GET _ -> U.GET va - U.GETN _ n -> U.GETN va n - U.UPDATE _ -> U.UPDATE va - U.UPDATEN _ n -> U.UPDATEN va n - U.GET_AND_UPDATE _ -> U.GET_AND_UPDATE va - U.LAMBDA _ t1 t2 ops -> U.LAMBDA va t1 t2 ops - U.EXEC _ -> U.EXEC va - U.APPLY _ -> U.APPLY va - U.CAST _ t -> U.CAST va t - U.RENAME _ -> U.RENAME va - U.PACK _ -> U.PACK va - U.UNPACK ta _ t -> U.UNPACK ta va t - U.CONCAT _ -> U.CONCAT va - U.SLICE _ -> U.SLICE va - U.ISNAT _ -> U.ISNAT va - U.ADD _ -> U.ADD va - U.SUB _ -> U.SUB va - U.SUB_MUTEZ _ -> U.SUB_MUTEZ va - U.MUL _ -> U.MUL va - U.EDIV _ -> U.EDIV va - U.ABS _ -> U.ABS va - U.NEG _ -> U.NEG va - U.LSL _ -> U.LSL va - U.LSR _ -> U.LSR va - U.OR _ -> U.OR va - U.AND _ -> U.AND va - U.XOR _ -> U.XOR va - U.NOT _ -> U.NOT va - U.COMPARE _ -> U.COMPARE va - U.EQ _ -> U.EQ va - U.NEQ _ -> U.NEQ va - U.LT _ -> U.LT va - U.GT _ -> U.GT va - U.LE _ -> U.LE va - U.GE _ -> U.GE va - U.INT _ -> U.INT va - U.VIEW _ n t -> U.VIEW va n t - U.SELF _ fa -> U.SELF va fa - U.CONTRACT _ fa t -> U.CONTRACT va fa t - U.TRANSFER_TOKENS _ -> U.TRANSFER_TOKENS va - U.SET_DELEGATE _ -> U.SET_DELEGATE va - U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va U.noAnn c - U.IMPLICIT_ACCOUNT _ -> U.IMPLICIT_ACCOUNT va - U.NOW _ -> U.NOW va - U.AMOUNT _ -> U.AMOUNT va - U.BALANCE _ -> U.BALANCE va - U.VOTING_POWER _ -> U.VOTING_POWER va - U.TOTAL_VOTING_POWER _ -> U.TOTAL_VOTING_POWER va - U.CHECK_SIGNATURE _ -> U.CHECK_SIGNATURE va - U.SHA256 _ -> U.SHA256 va - U.SHA512 _ -> U.SHA512 va - U.BLAKE2B _ -> U.BLAKE2B va - U.SHA3 _ -> U.SHA3 va - U.KECCAK _ -> U.KECCAK va - U.HASH_KEY _ -> U.HASH_KEY va - U.SOURCE _ -> U.SOURCE va - U.SENDER _ -> U.SENDER va - U.ADDRESS _ -> U.ADDRESS va - U.CHAIN_ID _ -> U.CHAIN_ID va - U.LEVEL _ -> U.LEVEL va - U.SELF_ADDRESS _ -> U.SELF_ADDRESS va - U.TICKET _ -> U.TICKET va - U.READ_TICKET _ -> U.READ_TICKET va - U.SPLIT_TICKET _ -> U.SPLIT_TICKET va - U.JOIN_TICKETS _ -> U.JOIN_TICKETS va - _ -> error $ - "addVarNotes: Cannot add single var annotation to instr: " <> (pretty ins) <> " with " <> pretty va - _ -> error $ - "addVarNotes: Trying to add more than two var annotations to instr: " <> (pretty ins) - handleInstr :: HasCallStack => Instr inp out -> U.ExpandedInstr handleInstr = \case - (WithLoc _ _) -> error "impossible" - InstrWithNotes {} -> error "impossible" - (InstrWithVarNotes _ _) -> error "impossible" - (InstrWithVarAnns _ _) -> error "impossible" - (FrameInstr _ _) -> error "impossible" - (Seq _ _) -> error "impossible" + WithLoc _ _ -> error "impossible" + FrameInstr _ _ -> error "impossible" + Seq _ _ -> error "impossible" Nop -> error "impossible" - (Ext _) -> error "impossible" - (Nested _) -> error "impossible" + Ext _ -> error "impossible" + Nested _ -> error "impossible" DocGroup{} -> error "impossible" Meta _ i -> handleInstr i - Fn t sfn i -> U.EXT . U.FN t sfn $ instrToOpsImpl opts i DROP -> U.DROP - (DROPN s) -> U.DROPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) - DUP -> U.DUP U.noAnn - (DUPN s) -> U.DUPN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) + DROPN s -> U.DROPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) + AnnDUP ann -> annotateInstr ann U.DUP + AnnDUPN ann s -> annotateInstr ann U.DUPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) SWAP -> U.SWAP - (DIG s) -> U.DIG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) - (DUG s) -> U.DUG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) - i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i -> + DIG s -> U.DIG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) + DUG s -> U.DUG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) + i@(AnnPUSH ann val) | _ :: Instr inp1 (t ': s) <- i -> let value = untypeValueImpl opts (sing @t) val - in U.PUSH U.noAnn (untypeDemoteT @t) value - i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i -> - U.NONE U.noAnn U.noAnn (untypeDemoteT @a) - SOME -> U.SOME U.noAnn U.noAnn - UNIT -> U.UNIT U.noAnn U.noAnn + in annotateInstr ann U.PUSH value + i@(AnnNONE ann) | _ :: Instr inp1 ('TOption a ': inp1) <- i -> + annotateInstr ann U.NONE + AnnSOME ann -> annotateInstr ann U.SOME + AnnUNIT ann -> annotateInstr ann U.UNIT (IF_NONE i1 i2) -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2) - - -- TODO [#580]: `AnnUNPAIR` accepts special var anns, so it carries them inside its constructor, - -- so we can use them here to re-construct an untyped `U.UNPAIR`. - -- `AnnPAIR`, on the other hand, doesn't accept special var anns, so the var anns - -- are carried in the `InstrWithVarNotes` meta-instruction instead. - -- - -- See: Note [Annotations - Exceptional scenarios] in `Morley.Michelson.Typed.Instr` - AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2 - AnnUNPAIR vn1 vn2 fn1 fn2 -> U.UNPAIR vn1 vn2 fn1 fn2 - - PAIRN n -> U.PAIRN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) + AnnPAIR ann -> annotateInstr ann U.PAIR + AnnUNPAIR ann -> annotateInstr ann U.UNPAIR + AnnPAIRN ann n -> annotateInstr ann U.PAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) UNPAIRN n -> U.UNPAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) - (AnnCAR vn fn) -> U.CAR vn fn - (AnnCDR vn fn) -> U.CDR vn fn - i@(AnnLEFT tn fn1 fn2) | _ :: Instr (a ': s) ('TOr a b ': s) <- i -> - U.LEFT tn U.noAnn fn1 fn2 (untypeDemoteT @b) - i@(AnnRIGHT tn fn1 fn2) | _ :: Instr (b ': s) ('TOr a b ': s) <- i -> - U.RIGHT tn U.noAnn fn1 fn2 (untypeDemoteT @a) + AnnCAR ann -> annotateInstr ann U.CAR + AnnCDR ann -> annotateInstr ann U.CDR + i@(AnnLEFT ann) | _ :: Instr (a ': s) ('TOr a b ': s) <- i -> + annotateInstr ann U.LEFT + i@(AnnRIGHT ann) | _ :: Instr (b ': s) ('TOr a b ': s) <- i -> + annotateInstr ann U.RIGHT (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOpsImpl opts i1) (instrToOpsImpl opts i2) - i@NIL | _ :: Instr s ('TList p ': s) <- i -> - U.NIL U.noAnn U.noAnn (untypeDemoteT @p) - CONS -> U.CONS U.noAnn + i@(AnnNIL ann) | _ :: Instr s ('TList p ': s) <- i -> + annotateInstr ann U.NIL + AnnCONS ann -> annotateInstr ann U.CONS (IF_CONS i1 i2) -> U.IF_CONS (instrToOpsImpl opts i1) (instrToOpsImpl opts i2) - SIZE -> U.SIZE U.noAnn - i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i -> - U.EMPTY_SET U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @e) U.noAnn) - i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i -> - U.EMPTY_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn) - (untypeDemoteT @b) - i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i -> - U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn) - (untypeDemoteT @b) - (MAP op) -> U.MAP U.noAnn $ instrToOpsImpl opts op + AnnSIZE ann -> annotateInstr ann U.SIZE + i@(AnnEMPTY_SET ann) | _ :: Instr s ('TSet e ': s) <- i -> + annotateInstr ann U.EMPTY_SET + i@(AnnEMPTY_MAP ann) | _ :: Instr s ('TMap a b ': s) <- i -> + annotateInstr ann U.EMPTY_MAP + i@(AnnEMPTY_BIG_MAP ann) | _ :: Instr s ('TBigMap a b ': s) <- i -> + annotateInstr ann U.EMPTY_BIG_MAP + (AnnMAP ann op) -> annotateInstr ann U.MAP $ instrToOpsImpl opts op (ITER op) -> U.ITER $ instrToOpsImpl opts op - MEM -> U.MEM U.noAnn - GET -> U.GET U.noAnn - GETN n -> U.GETN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) - UPDATE -> U.UPDATE U.noAnn - UPDATEN n -> U.UPDATEN U.noAnn (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) - GET_AND_UPDATE -> U.GET_AND_UPDATE U.noAnn + AnnMEM ann -> annotateInstr ann U.MEM + AnnGET ann -> annotateInstr ann U.GET + AnnGETN ann n -> annotateInstr ann U.GETN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) + AnnUPDATE ann -> annotateInstr ann U.UPDATE + AnnUPDATEN ann n -> annotateInstr ann U.UPDATEN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n) + AnnGET_AND_UPDATE ann -> annotateInstr ann U.GET_AND_UPDATE (IF op1 op2) -> U.IF (instrToOpsImpl opts op1) (instrToOpsImpl opts op2) (LOOP op) -> U.LOOP (instrToOpsImpl opts op) (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOpsImpl opts op) - i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i -> - U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOpsImpl opts $ rfAnyInstr l) - EXEC -> U.EXEC U.noAnn - APPLY -> U.APPLY U.noAnn - (DIP op) -> U.DIP (instrToOpsImpl opts op) - (DIPN s op) -> + AnnLAMBDA ann l'@(VLam l) | VLam _ :: Value ('TLambda i o) <- l' -> + annotateInstr ann U.LAMBDA (instrToOpsImpl opts $ rfAnyInstr l) + AnnEXEC ann -> annotateInstr ann U.EXEC + AnnAPPLY ann -> annotateInstr ann U.APPLY + DIP op -> U.DIP (instrToOpsImpl opts op) + DIPN s op -> U.DIPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) (instrToOpsImpl opts op) FAILWITH -> U.FAILWITH - i@CAST | _ :: Instr (a ': s) (a ': s) <- i -> - U.CAST U.noAnn (untypeDemoteT @a) - RENAME -> U.RENAME U.noAnn - PACK -> U.PACK U.noAnn - i@UNPACK + i@(AnnCAST ann) | _ :: Instr (a ': s) (a ': s) <- i -> + annotateInstr ann U.CAST + AnnRENAME ann -> annotateInstr ann U.RENAME + AnnPACK ann -> annotateInstr ann U.PACK + i@(AnnUNPACK ann) | _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i -> - U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a) - CONCAT -> U.CONCAT U.noAnn - CONCAT' -> U.CONCAT U.noAnn - SLICE -> U.SLICE U.noAnn - ISNAT -> U.ISNAT U.noAnn - ADD -> U.ADD U.noAnn - SUB -> U.SUB U.noAnn - SUB_MUTEZ -> U.SUB_MUTEZ U.noAnn - MUL -> U.MUL U.noAnn - EDIV -> U.EDIV U.noAnn - ABS -> U.ABS U.noAnn - NEG -> U.NEG U.noAnn - LSL -> U.LSL U.noAnn - LSR -> U.LSR U.noAnn - OR -> U.OR U.noAnn - AND -> U.AND U.noAnn - XOR -> U.XOR U.noAnn - NOT -> U.NOT U.noAnn - COMPARE -> U.COMPARE U.noAnn - Instr.EQ -> U.EQ U.noAnn - NEQ -> U.NEQ U.noAnn - Instr.LT -> U.LT U.noAnn - Instr.GT -> U.GT U.noAnn - LE -> U.LE U.noAnn - GE -> U.GE U.noAnn - INT -> U.INT U.noAnn - VIEW viewName nt -> U.VIEW U.noAnn viewName (mkUType nt) - SELF sepc -> - U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc) - i@(CONTRACT nt epName) + annotateInstr ann U.UNPACK + AnnCONCAT ann -> annotateInstr ann U.CONCAT + AnnCONCAT' ann -> annotateInstr ann U.CONCAT + AnnSLICE ann -> annotateInstr ann U.SLICE + AnnISNAT ann -> annotateInstr ann U.ISNAT + AnnADD ann -> annotateInstr ann U.ADD + AnnSUB ann -> annotateInstr ann U.SUB + AnnSUB_MUTEZ ann -> annotateInstr ann U.SUB_MUTEZ + AnnMUL ann -> annotateInstr ann U.MUL + AnnEDIV ann -> annotateInstr ann U.EDIV + AnnABS ann -> annotateInstr ann U.ABS + AnnNEG ann -> annotateInstr ann U.NEG + AnnLSL ann -> annotateInstr ann U.LSL + AnnLSR ann -> annotateInstr ann U.LSR + AnnOR ann -> annotateInstr ann U.OR + AnnAND ann -> annotateInstr ann U.AND + AnnXOR ann -> annotateInstr ann U.XOR + AnnNOT ann -> annotateInstr ann U.NOT + AnnCOMPARE ann -> annotateInstr ann U.COMPARE + AnnEQ ann -> annotateInstr ann U.EQ + AnnNEQ ann -> annotateInstr ann U.NEQ + AnnLT ann -> annotateInstr ann U.LT + AnnGT ann -> annotateInstr ann U.GT + AnnLE ann -> annotateInstr ann U.LE + AnnGE ann -> annotateInstr ann U.GE + AnnINT ann -> annotateInstr ann U.INT + AnnVIEW ann viewName -> annotateInstr ann (flip U.VIEW viewName) + AnnSELF ann sepc -> + annotateInstr ann U.SELF (epNameToRefAnn $ sepcName sepc) + i@(AnnCONTRACT ann epName) | _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i -> let fa = epNameToRefAnn epName - 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 contract) + in annotateInstr ann (flip U.CONTRACT fa) + AnnTRANSFER_TOKENS ann -> annotateInstr ann U.TRANSFER_TOKENS + AnnSET_DELEGATE ann -> annotateInstr ann U.SET_DELEGATE + i@(AnnCREATE_CONTRACT ann contract) | _ :: Instr ( 'TOption ('TKeyHash) ': 'TMutez ': g ': s) ('TOperation ': 'TAddress ': s) <- i -> - U.CREATE_CONTRACT U.noAnn U.noAnn (convertContract contract) - IMPLICIT_ACCOUNT -> U.IMPLICIT_ACCOUNT U.noAnn - NOW -> U.NOW U.noAnn - AMOUNT -> U.AMOUNT U.noAnn - BALANCE -> U.BALANCE U.noAnn - VOTING_POWER -> U.VOTING_POWER U.noAnn - TOTAL_VOTING_POWER -> U.TOTAL_VOTING_POWER U.noAnn - CHECK_SIGNATURE -> U.CHECK_SIGNATURE U.noAnn - SHA256 -> U.SHA256 U.noAnn - SHA512 -> U.SHA512 U.noAnn - BLAKE2B -> U.BLAKE2B U.noAnn - SHA3 -> U.SHA3 U.noAnn - KECCAK -> U.KECCAK U.noAnn - HASH_KEY -> U.HASH_KEY U.noAnn - PAIRING_CHECK -> U.PAIRING_CHECK U.noAnn - SOURCE -> U.SOURCE U.noAnn - SENDER -> U.SENDER U.noAnn - ADDRESS -> U.ADDRESS U.noAnn - CHAIN_ID -> U.CHAIN_ID U.noAnn - LEVEL -> U.LEVEL U.noAnn - SELF_ADDRESS -> U.SELF_ADDRESS U.noAnn + annotateInstr ann U.CREATE_CONTRACT (convertContract contract) + AnnIMPLICIT_ACCOUNT ann -> annotateInstr ann U.IMPLICIT_ACCOUNT + AnnNOW ann -> annotateInstr ann U.NOW + AnnAMOUNT ann -> annotateInstr ann U.AMOUNT + AnnBALANCE ann -> annotateInstr ann U.BALANCE + AnnVOTING_POWER ann -> annotateInstr ann U.VOTING_POWER + AnnTOTAL_VOTING_POWER ann -> annotateInstr ann U.TOTAL_VOTING_POWER + AnnCHECK_SIGNATURE ann -> annotateInstr ann U.CHECK_SIGNATURE + AnnSHA256 ann -> annotateInstr ann U.SHA256 + AnnSHA512 ann -> annotateInstr ann U.SHA512 + AnnBLAKE2B ann -> annotateInstr ann U.BLAKE2B + AnnSHA3 ann -> annotateInstr ann U.SHA3 + AnnKECCAK ann -> annotateInstr ann U.KECCAK + AnnHASH_KEY ann -> annotateInstr ann U.HASH_KEY + AnnPAIRING_CHECK ann -> annotateInstr ann U.PAIRING_CHECK + AnnSOURCE ann -> annotateInstr ann U.SOURCE + AnnSENDER ann -> annotateInstr ann U.SENDER + AnnADDRESS ann -> annotateInstr ann U.ADDRESS + AnnCHAIN_ID ann -> annotateInstr ann U.CHAIN_ID + AnnLEVEL ann -> annotateInstr ann U.LEVEL + AnnSELF_ADDRESS ann -> annotateInstr ann U.SELF_ADDRESS NEVER -> U.NEVER - TICKET -> U.TICKET U.noAnn - READ_TICKET -> U.READ_TICKET U.noAnn - SPLIT_TICKET -> U.SPLIT_TICKET U.noAnn - JOIN_TICKETS -> U.JOIN_TICKETS U.noAnn - OPEN_CHEST -> U.OPEN_CHEST U.noAnn - SAPLING_EMPTY_STATE s -> - U.SAPLING_EMPTY_STATE U.noAnn (singPeanoVal s) - SAPLING_VERIFY_UPDATE -> U.SAPLING_VERIFY_UPDATE U.noAnn + AnnTICKET ann -> annotateInstr ann U.TICKET + AnnREAD_TICKET ann -> annotateInstr ann U.READ_TICKET + AnnSPLIT_TICKET ann -> annotateInstr ann U.SPLIT_TICKET + AnnJOIN_TICKETS ann -> annotateInstr ann U.JOIN_TICKETS + AnnOPEN_CHEST ann -> annotateInstr ann U.OPEN_CHEST + AnnSAPLING_EMPTY_STATE ann s -> + annotateInstr ann U.SAPLING_EMPTY_STATE (singPeanoVal s) + AnnSAPLING_VERIFY_UPDATE ann -> annotateInstr ann U.SAPLING_VERIFY_UPDATE + AnnMIN_BLOCK_TIME ann -> U.MIN_BLOCK_TIME ann untypeStackRef :: StackRef s -> U.StackRef untypeStackRef (StackRef n) = U.StackRef (fromPeanoNatural n) @@ -785,6 +495,9 @@ StackTypeComment Nothing -> one $ U.UCOMMENT $ fmt "any stack type" STACKTYPE s -> one $ U.STACKTYPE s +-- | Extended equality of 'Instr' - this behaves like '(==)' +-- but does not require the compared instructions to be of strictly +-- the same type. eqInstrExt :: Instr i1 o1 -> Instr i2 o2 -> Bool eqInstrExt i1 i2 = instrToOps i1 == instrToOps i2 @@ -847,6 +560,8 @@ -- primes involved. STChest -> Nothing STChestKey -> Nothing + STTxRollupL2Address -> Just $ VTxRollupL2Address $ TxRollupL2Address $ + unsafe $ parseHash "tz4LVHYD4P4T5NHCuwJbxQvwVURF62seE3Qa" STNever -> Nothing STSaplingState _ -> Nothing STSaplingTransaction _ -> Nothing @@ -892,8 +607,8 @@ case checkScope @(ConstantScope t2) of Right Dict -> do val <- sampleTypedValue t2 - pure $ VLam $ RfNormal (DROP `Seq` PUSH val) - _ -> pure $ VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH) + pure $ mkVLam $ RfNormal (DROP `Seq` PUSH val) + _ -> pure $ mkVLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH) where sampleAddress = (unsafe . parseEpAddress) "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB" samplePublicKey = fromRight (error "impossible") $ parsePublicKey diff --git a/src/Morley/Michelson/Typed/Doc.hs b/src/Morley/Michelson/Typed/Doc.hs --- a/src/Morley/Michelson/Typed/Doc.hs +++ b/src/Morley/Michelson/Typed/Doc.hs @@ -5,18 +5,13 @@ -- | Extracting documentation from instructions set. module Morley.Michelson.Typed.Doc - ( buildInstrDoc - , buildInstrDocWithGitRev - , modifyInstrDoc - , modifyInstrAllDoc - , cutInstrNonDoc + ( cutInstrNonDoc , docInstr ) where import Control.Lens (at) import Control.Monad.Writer.Strict (Writer, runWriter, writer) import Data.Default (def) -import Data.Typeable (cast) import Prelude hiding (Ordering(..)) import Morley.Michelson.Doc @@ -58,81 +53,45 @@ docInstr :: DocItem di => di -> Instr s s docInstr = Ext . DOC_ITEM . SomeDocItem --- | Assemble contract documentation with the revision of the contract. -{-# DEPRECATED buildInstrDocWithGitRev - "Use `buildDoc . attachDocCommons gitRev` instead." - #-} -buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc -buildInstrDocWithGitRev gitRev contract = - let toc = DToc $ contractDocToToc $ buildInstrDoc contract - c = pure contract - >>= attachGitInfo gitRev - >>= attachToc toc - in buildDoc c - --- | Assemble contract documentation. -{-# DEPRECATED buildInstrDoc "Use 'buildDoc' instead." #-} -buildInstrDoc :: Instr inp out -> ContractDoc -buildInstrDoc = dfsFoldInstr dfsSettings $ \case - Ext ext -> case ext of - DOC_ITEM sdi -> - execState (someDocItemToContractDoc sdi) mempty +instance ContainsDoc (Instr inp out) where + buildDocUnfinalized = dfsFoldInstr dfsSettings \case + Ext ext -> case ext of + DOC_ITEM sdi -> + execState (someDocItemToContractDoc sdi) mempty + _ -> mempty _ -> mempty - _ -> mempty - where - dfsSettings :: DfsSettings (Writer ContractDoc) - dfsSettings = def - { dsCtorEffectsApp = CtorEffectsApp - { ceaName = "Building DocGroup" - , ceaPostStep = \_old -> \case - (runWriter -> (i@(DocGroup grouping _), resChildren)) -> - writer (i, docGroupContent grouping resChildren) - other -> other - } - } - --- | Modify all documentation items recursively. -{-# DEPRECATED modifyInstrAllDoc "Use 'modifyDocEntirely' instead." #-} -modifyInstrAllDoc - :: (SomeDocItem -> SomeDocItem) - -> Instr inp out - -> Instr inp out -modifyInstrAllDoc mapper = dfsModifyInstr def $ \case - Ext ext -> Ext $ - case ext of - DOC_ITEM sdi -> DOC_ITEM (mapper sdi) - i -> i - i -> i + where + dfsSettings :: DfsSettings (Writer ContractDoc) + dfsSettings = def + { dsCtorEffectsApp = CtorEffectsApp + { ceaName = "Building DocGroup" + , ceaPostStep = \_old -> \case + (runWriter -> (i@(DocGroup grouping _), resChildren)) -> + writer (i, docGroupContent grouping resChildren) + other -> other + } + } --- | Recursevly traverse an instruction and modify documentation items --- matching given type. --- --- If mapper returns 'Nothing', doc item will remain unmodified. -{-# DEPRECATED modifyInstrDoc "Use 'modifyDoc' instead." #-} -modifyInstrDoc - :: (DocItem i1, DocItem i2) - => (i1 -> Maybe i2) - -> Instr inp out - -> Instr inp out -modifyInstrDoc mapper = modifyInstrAllDoc untypedMapper - where - untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do - di' <- cast di - newDi <- mapper di' - return (SomeDocItem newDi) +instance ContainsUpdateableDoc (Instr inp out) where + modifyDocEntirely mapper = dfsModifyInstr def $ \case + Ext ext -> Ext $ + case ext of + DOC_ITEM sdi -> DOC_ITEM (mapper sdi) + i -> i + i -> i -instance ContainsDoc (Instr inp out) where - buildDocUnfinalized = buildInstrDoc +instance ContainsDoc (ContractCode inp out) where + buildDocUnfinalized = buildDocUnfinalized . unContractCode -instance ContainsUpdateableDoc (Instr inp out) where - modifyDocEntirely = modifyInstrAllDoc +instance ContainsUpdateableDoc (ContractCode inp out) where + modifyDocEntirely how (ContractCode x) = ContractCode $ modifyDocEntirely how x instance ContainsDoc (Contract cp st) where buildDocUnfinalized = buildDocUnfinalized . cCode instance ContainsUpdateableDoc (Contract cp st) where modifyDocEntirely how contract = - contract{ cCode = modifyInstrAllDoc how (cCode contract) } + contract{ cCode = modifyDocEntirely how (cCode contract) } -- | Leave only instructions related to documentation. -- diff --git a/src/Morley/Michelson/Typed/Entrypoints.hs b/src/Morley/Michelson/Typed/Entrypoints.hs --- a/src/Morley/Michelson/Typed/Entrypoints.hs +++ b/src/Morley/Michelson/Typed/Entrypoints.hs @@ -59,7 +59,7 @@ import Morley.Michelson.Untyped.Annotation import Morley.Michelson.Untyped.Entrypoints import Morley.Tezos.Address -import Morley.Tezos.Crypto (keyHashLengthBytes) +import Morley.Tezos.Crypto (hashLengthBytes) import Morley.Util.TH import Morley.Util.TypeLits import Morley.Util.Typeable @@ -157,7 +157,7 @@ -- parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress parseEpAddressRaw raw = do - let (bytes, eps) = BS.splitAt (keyHashLengthBytes + 2) raw + let (bytes, eps) = BS.splitAt (hashLengthBytes + 2) raw eaAddress <- first ParseEpAddressRawBadAddress $ parseAddressRaw bytes decodedEntrypoint <- first (ParseEpAddressBadEntryopint raw) $ decodeUtf8' eps decodedAnnotation <- first ParseEpAddressBadRefAnn $ mkAnnotation decodedEntrypoint diff --git a/src/Morley/Michelson/Typed/Extract.hs b/src/Morley/Michelson/Typed/Extract.hs --- a/src/Morley/Michelson/Typed/Extract.hs +++ b/src/Morley/Michelson/Typed/Extract.hs @@ -93,6 +93,9 @@ Un.TNever -> cont (NTNever tn) + Un.TTxRollupL2Address -> + cont (NTTxRollupL2Address tn) + Un.TSaplingState n -> (\(SomeSing s) -> withSingI s $ cont (NTSaplingState tn s) diff --git a/src/Morley/Michelson/Typed/Haskell/Doc.hs b/src/Morley/Michelson/Typed/Haskell/Doc.hs --- a/src/Morley/Michelson/Typed/Haskell/Doc.hs +++ b/src/Morley/Michelson/Typed/Haskell/Doc.hs @@ -735,6 +735,12 @@ typeDocMdDescription = "KeyHash primitive." typeDocDependencies _ = [] typeDocHaskellRep _ _ = Nothing + typeDocMichelsonRep _ = (Nothing, TKeyHash) + typeDocMdReference tp _ = + customTypeDocMdReference + (typeDocName tp, DType tp) + [] + (WithinParens False) instance TypeHasDoc Timestamp where typeDocName _ = "Timestamp" diff --git a/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs b/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs --- a/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs +++ b/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs @@ -102,7 +102,7 @@ LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p) LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p) LNMergeFound name ('Just _) ('Just _) = TypeError - ('Text "Ambigous reference to datatype field: " ':<>: 'ShowType name) + ('Text "Ambiguous reference to datatype field: " ':<>: 'ShowType name) -- | Get type of field by datatype it is contained in and field name. type GetFieldType dt name = LnrFieldType (GetNamed name dt) diff --git a/src/Morley/Michelson/Typed/Haskell/Value.hs b/src/Morley/Michelson/Typed/Haskell/Value.hs --- a/src/Morley/Michelson/Typed/Haskell/Value.hs +++ b/src/Morley/Michelson/Typed/Haskell/Value.hs @@ -56,7 +56,7 @@ import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T import Morley.Michelson.Typed.Value -import Morley.Tezos.Address (Address) +import Morley.Tezos.Address (Address, TxRollupL2Address) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, Chest, ChestKey, KeyHash, PublicKey, Signature) @@ -243,6 +243,11 @@ type ToT ChestKey = 'TChestKey toVal = VChestKey fromVal (VChestKey x) = x + +instance IsoValue TxRollupL2Address where + type ToT TxRollupL2Address = 'TTxRollupL2Address + toVal = VTxRollupL2Address + fromVal (VTxRollupL2Address x) = x deriving newtype instance IsoValue a => IsoValue (Identity a) deriving newtype instance IsoValue a => IsoValue (NamedF Identity a name) diff --git a/src/Morley/Michelson/Typed/Instr.hs b/src/Morley/Michelson/Typed/Instr.hs --- a/src/Morley/Michelson/Typed/Instr.hs +++ b/src/Morley/Michelson/Typed/Instr.hs @@ -5,7 +5,100 @@ -- | Module, containing data types for Michelson value. module Morley.Michelson.Typed.Instr - ( Instr (..) + ( Instr (.. + , CAR + , CDR + , DUP + , DUPN + , PUSH + , SOME + , NONE + , UNIT + , PAIR + , UNPAIR + , PAIRN + , LEFT + , RIGHT + , NIL + , CONS + , SIZE + , EMPTY_SET + , EMPTY_MAP + , EMPTY_BIG_MAP + , MAP + , MEM + , GET + , GETN + , UPDATE + , UPDATEN + , GET_AND_UPDATE + , LAMBDA + , EXEC + , APPLY + , CAST + , RENAME + , PACK + , UNPACK + , CONCAT + , CONCAT' + , SLICE + , ISNAT + , ADD + , SUB + , SUB_MUTEZ + , MUL + , EDIV + , ABS + , NEG + , LSL + , LSR + , OR + , AND + , XOR + , NOT + , COMPARE + , EQ + , NEQ + , LT + , GT + , LE + , GE + , INT + , VIEW + , SELF + , CONTRACT + , TRANSFER_TOKENS + , SET_DELEGATE + , CREATE_CONTRACT + , IMPLICIT_ACCOUNT + , NOW + , AMOUNT + , BALANCE + , VOTING_POWER + , TOTAL_VOTING_POWER + , CHECK_SIGNATURE + , SHA256 + , SHA512 + , BLAKE2B + , SHA3 + , KECCAK + , HASH_KEY + , PAIRING_CHECK + , SOURCE + , SENDER + , ADDRESS + , CHAIN_ID + , LEVEL + , SELF_ADDRESS + , TICKET + , READ_TICKET + , SPLIT_TICKET + , JOIN_TICKETS + , OPEN_CHEST + , SAPLING_EMPTY_STATE + , SAPLING_VERIFY_UPDATE + , MIN_BLOCK_TIME + ) , castInstr , pattern (:#) , ExtInstr (..) @@ -15,12 +108,7 @@ , PrintComment (..) , TestAssert (..) , SomeMeta (..) - , pattern CAR - , pattern CDR - , pattern LEFT - , pattern PAIR - , pattern RIGHT - , pattern UNPAIR + , pattern ConcreteMeta , ConstraintDUPN , ConstraintDUPN' , ConstraintDIPN @@ -40,16 +128,21 @@ , UpdateN ) where +import Prelude hiding (EQ, GT, LT) + +import Data.Default (def) +import Data.List (stripPrefix) import Data.Singletons (Sing) import Data.Type.Equality ((:~:)(..)) -import Data.Vinyl (RMap, Rec(..), RecordToList, ReifyConstraint(..)) +import Data.Typeable (cast) import Fmt (Buildable(..), (+|), (|+)) import GHC.TypeNats (Nat, type (+)) +import Language.Haskell.TH import Text.Show qualified as T import Morley.Michelson.Doc import Morley.Michelson.ErrorPos -import Morley.Michelson.Typed.Annotation (Notes(..)) +import Morley.Michelson.Typed.Annotation (AnnVar, Anns, Notes(..)) import Morley.Michelson.Typed.Arith import Morley.Michelson.Typed.Contract import Morley.Michelson.Typed.Entrypoints @@ -61,8 +154,7 @@ CombedPairNodeIndexIsValid, IsPair) import Morley.Michelson.Typed.Value (Value'(..)) import Morley.Michelson.Typed.View -import Morley.Michelson.Untyped - (Annotation(..), FieldAnn, StackFn, StackTypePattern, TypeAnn, VarAnn, VarAnns) +import Morley.Michelson.Untyped (AnyAnn, FieldAnn, StackTypePattern, TypeAnn, VarAnn) import Morley.Util.Peano import Morley.Util.PeanoNatural import Morley.Util.Sing (eqI) @@ -70,109 +162,7 @@ import Morley.Util.Type (If, KnownList, type (++)) import Morley.Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)), TypeErrorUnless) -{- -Note [Annotations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When typechecking a sequence of instructions: - -1. We'll typecheck an "untyped instruction" like `EMPTY_SET :ta @va unit`, producing: - * a "typed instruction" `EMPTY_SET :: Instr s (TSet TUnit : s)`, and - * an output stack with a `@va set :ta int` at the top. -2. In `Morley.Michelson.TypeCheck.Helpers.wrapWithNotes`: - * if the original instruction had a var annotation (e.g. `SOME_INSTR @some_ann`), - then we wrap the "typed instruction" in `InstrWithVarNotes`. - * if the element at the top of the output stack has a var annotation, - we wrap it in `InstrWithVarAnns`. - * if the element at the top of the output stack has field/type anns, - we wrap it in `InstrWithNotes` - ``` - InstrWithNotes Proxy (NTSet "ta" (NTUnit "")) $ - InstrWithVarNotes (one "va") $ - InstrWithVarAnns (OneVarAnn "va") $ - EMPTY_SET - ``` - -These "meta-instruction" wrappers are later used in the interpreter/serializer. - -The interpreter ('Morley.Michelson.Interpret'): - * Looks at the typed instruction (e.g. `EMPTY_SET`), and simply adds/removes/moves elements - in the stack, without caring about annotations. - * Looks at the `InstrWithNotes` and `InstrWithVarAnns` meta-instructions, and blindly - applies a series of annotations to the output stack, without caring about the underlying - instruction. - -The serializer ('Morley.Michelson.Interpret.Pack'): - * Looks at the `InstrWithNotes` and `InstrWithVarNotes` meta-instructions, and infers - that the original `EMPTY_SET` instruction must have had two explicit `:ta` and `@va` annotations. - -Notice that the interpreter does not care about the `InstrWithVarNotes` meta-instruction, and -the serializer does not care about the `InstrWithVarAnns` meta-instruction. - - - -Note [Annotations - Exceptional scenarios] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For the most part, this works without a hitch. -However, `wrapWithNotes` makes the assumption that we can infer an instruction's -original annotations by simply looking at the output stack, e.g.: - -> If after running an `EMPTY_SET` instruction we end up with a `@va set :ta int` -> at the top of output stack, then we can infer that the `EMPTY_SET` instruction -> had two `@va` and `:ta` annotations. - -Unfortunately, that assumption doesn't always hold. -Here are some counter examples: - -* Special annotations. - These 3 `CAR` instructions will all put a `@p.a nat` at the top of the stack: - - > PUSH @p (pair (nat %a) nat) (Pair 1 2); - > CAR @%%; - - > PUSH (pair (nat %p.a) nat) (Pair 1 2); - > CAR @%; - - > PUSH (pair (nat %p.a) nat) (Pair 1 2); - > CAR @p.a; - - Therefore, it's impossible for `wrapWithNotes` to figure out what - CAR's original var annotation was. - - This scenario affects all instructions that can take special annotations: - - PAIR, LEFT, RIGHT: accept special field anns - - UNPAIR, CAR, CDR: accept special var anns - -* Annotations that do not affect the output stack whatsoever. - For example, CAR may take a field annotation, but it's only used by the typechecker - to verify that the pair in the input stack has a matching field ann. - - The following instructions will generate the exact same output stack, - with an un-annotated `nat` at the top. - - > PUSH (pair (nat %a) nat) (Pair 1 2); - > CAR %a; - - > PUSH (pair (nat %a) nat) (Pair 1 2); - > CAR; - - Therefore, it's impossible for `wrapWithNotes` to figure out whether - CAR had a field annotation. - - This scenario affects: UNPAIR, CAR, CDR. - - -In situations like the above, where the instruction's annotations cannot be inferred from -looking at the output stack, we have to save and store the instruction's annotations inside -the typed instruction's constructor, instead of using meta-instructions. -E.g.: - -> AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s) - -TODO [#580]: address the assumptions mentioned above. - --} +{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-} -- This next comment is needed to run the doctest examples throughout this module. @@ -336,49 +326,40 @@ -- -- Type parameter @out@ states for output stack type or type -- of stack that will be left after instruction's execution. +-- +-- Each constructor here corresponding to an instruction that can have +-- annotations is represented as @AnnX@, where @X@ is the name of +-- the instruction. These constructors accept a typed heterogenous list of +-- annotations as the first argument. Pattern synonyms without the @Ann@ +-- prefix are provided, those ignore annotations entirely. +-- +-- We need this @AnnX@ constructors to carry annotations for @PACK@. +-- +-- When typechecking a sequence of instructions, we'll attach annotations from the +-- "untyped" instruction to the typed one. Note that if an instruction has a type argument, +-- e.g. `PUSH (int :t) 2` we'll attach typed 'Notes' for this type instead; other +-- annotations are used as-is. +-- +-- The interpreter mostly ignores annotations, with the exception of those used for +-- entrypoint resolution. +-- +-- The serializer ("Morley.Michelson.Interpret.Pack") can restore the original "untyped" +-- instruction from annotations on the "typed" one. +-- +-- 'AnnSELF' and 'AnnCONTRACT' are a special case: field annotations on these +-- instructions carry semantic meaning (specify the entrypoint), hence those +-- are stored separately from other annotations, to simplify checking for +-- invariants in "typed" contracts. data Instr (inp :: [T]) (out :: [T]) where -- | A wrapper carrying original source location of the instruction. -- -- TODO [#283]: replace this wrapper with something more clever and abstract. - WithLoc :: InstrCallStack -> Instr a b -> Instr a b + WithLoc :: ErrorSrcPos -> Instr a b -> Instr a b -- | A wrapper allowing arbitrary user metadata to be stored by some instruction. -- TODO [#689]: Use this instead of `DOC_ITEM`. Meta :: SomeMeta -> Instr a b -> Instr a b - -- | A wrapper for instructions that, when interpreted, will - -- place field/type annotations on one or more of the elements at - -- the top of the stack. - -- - -- This can wrap only instructions with at least one non-failing execution - -- branch. - -- - -- See: Note [Annotations] - InstrWithNotes - :: forall a (topElems :: [T]) (s :: [T]). - ( RMap topElems - , RecordToList topElems - , ReifyConstraint Show Notes topElems - , ReifyConstraint NFData Notes topElems - , Each '[ SingI ] topElems - ) - => Proxy s -> Rec Notes topElems - -> Instr a (topElems ++ s) -> Instr a (topElems ++ s) - - -- | A wrapper for instructions that have var annotations, e.g. `SOME_INSTR @ann1`. - -- - -- This information is necessary for serializing the instruction back to json/binary. - -- - -- See: Note [Annotations] - InstrWithVarNotes :: NonEmpty VarAnn -> Instr a b -> Instr a b - - -- | A wrapper for instructions that, when interpreted, will - -- place var annotations on one or more of the elements at - -- the top of the stack. - -- - -- See: Note [Annotations] - InstrWithVarAnns :: VarAnns -> Instr a b -> Instr a b - -- | Execute given instruction on truncated stack. -- -- This can wrap only instructions with at least one non-failing execution @@ -414,16 +395,9 @@ -- This is not part of 'ExtInstr' because it does not behave like 'Nop'; -- instead, it inherits the behaviour of the instruction put within it. DocGroup :: DocGrouping -> Instr inp out -> Instr inp out - -- | Represents a typed stack function. - -- This is not part of 'ExtInstr' because it does not behave like 'Nop'; - -- instead, it inherits the behaviour of the instruction put within it. - Fn :: Text -> StackFn -> Instr inp out -> Instr inp out - -- | CAR and CDR's original annotations must be retained inside - -- the instruction's constructor. - -- See: Note [Annotations - Exceptional scenarios]. - AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s) - AnnCDR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (b ': s) + AnnCAR :: Anns '[VarAnn, FieldAnn] -> Instr ('TPair a b ': s) (a ': s) + AnnCDR :: Anns '[VarAnn, FieldAnn] -> Instr ('TPair a b ': s) (b ': s) -- Note that we can not merge DROP and DROPN into one instruction -- because they are packed differently. @@ -432,10 +406,10 @@ :: forall (n :: Peano) s. (RequireLongerOrSameLength s n) => PeanoNatural n -> Instr s (Drop n s) - DUP :: DupableScope a => Instr (a ': s) (a ': a ': s) - DUPN + AnnDUP :: DupableScope a => AnnVar -> Instr (a ': s) (a ': a ': s) + AnnDUPN :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, DupableScope a) - => PeanoNatural n -> Instr inp out + => AnnVar -> PeanoNatural n -> Instr inp out SWAP :: Instr (a ': b ': s) (b ': a ': s) DIG :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a) @@ -443,24 +417,18 @@ DUG :: forall (n :: Peano) inp out a. (ConstraintDUG n inp out a) => PeanoNatural n -> Instr inp out - PUSH + AnnPUSH :: forall t s . ConstantScope t - => Value' Instr t -> Instr s (t ': s) - SOME :: Instr (a ': s) ('TOption a ': s) - NONE :: forall a s . SingI a => Instr s ('TOption a ': s) - UNIT :: Instr s ('TUnit ': s) + => Anns '[VarAnn, Notes t] -> Value' Instr t -> Instr s (t ': s) + AnnSOME :: Anns '[TypeAnn, VarAnn] -> Instr (a ': s) ('TOption a ': s) + AnnNONE :: forall a s . SingI a => Anns '[TypeAnn, VarAnn, Notes a] -> Instr s ('TOption a ': s) + AnnUNIT :: Anns '[TypeAnn, VarAnn] -> Instr s ('TUnit ': s) IF_NONE :: Instr s s' -> Instr (a ': s) s' -> Instr ('TOption a ': s) s' - -- | PAIR's original annotations must be retained inside - -- the instruction's constructor. - -- See: Note [Annotations - Exceptional scenarios]. - AnnPAIR :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': b ': s) ('TPair a b ': s) - -- | UNPAIR's original annotations must be retained inside - -- the instruction's constructor. - -- See: Note [Annotations - Exceptional scenarios]. - AnnUNPAIR :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': b ': s) + AnnPAIR :: Anns '[TypeAnn, VarAnn, FieldAnn, FieldAnn] -> Instr (a ': b ': s) ('TPair a b ': s) + AnnUNPAIR :: Anns '[VarAnn, VarAnn, FieldAnn, FieldAnn] -> Instr ('TPair a b ': s) (a ': b ': s) -- | -- >>> :t PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TUnit, 'TString ] _ -- ... @@ -479,9 +447,9 @@ -- ... Expected stack with length >= 3 -- ... Current stack has size of only 2: -- ... - PAIRN + AnnPAIRN :: forall n inp. ConstraintPairN n inp - => PeanoNatural n -> Instr inp (PairN n inp) + => AnnVar -> PeanoNatural n -> Instr inp (PairN n inp) -- | -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit 'TString) ] _ -- ... @@ -516,33 +484,31 @@ => PeanoNatural n -> Instr (pair : s) (UnpairN n pair ++ s) - -- | LEFT and RIGHT's original annotations must be retained inside - -- the instruction's constructor. - -- See: Note [Annotations - Exceptional scenarios]. - AnnLEFT :: SingI b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': s) ('TOr a b ': s) - AnnRIGHT :: SingI a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b ': s) ('TOr a b ': s) + AnnLEFT :: SingI b => Anns '[TypeAnn, VarAnn, FieldAnn, FieldAnn, Notes b] -> Instr (a ': s) ('TOr a b ': s) + AnnRIGHT :: SingI a => Anns '[TypeAnn, VarAnn, FieldAnn, FieldAnn, Notes a] -> Instr (b ': s) ('TOr a b ': s) IF_LEFT :: Instr (a ': s) s' -> Instr (b ': s) s' -> Instr ('TOr a b ': s) s' - NIL :: SingI p => Instr s ('TList p ': s) - CONS :: Instr (a ': 'TList a ': s) ('TList a ': s) + AnnNIL :: SingI p => Anns '[TypeAnn, VarAnn, Notes p] -> Instr s ('TList p ': s) + AnnCONS :: AnnVar -> Instr (a ': 'TList a ': s) ('TList a ': s) IF_CONS :: Instr (a ': 'TList a ': s) s' -> Instr s s' -> Instr ('TList a ': s) s' - SIZE :: SizeOp c => Instr (c ': s) ('TNat ': s) - EMPTY_SET :: (SingI e, Comparable e) => Instr s ('TSet e ': s) - EMPTY_MAP :: (SingI a, SingI b, Comparable a) => Instr s ('TMap a b ': s) - EMPTY_BIG_MAP :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Instr s ('TBigMap a b ': s) - MAP :: (MapOp c, SingI b) - => Instr (MapOpInp c ': s) (b ': s) + AnnSIZE :: SizeOp c => AnnVar -> Instr (c ': s) ('TNat ': s) + AnnEMPTY_SET :: (SingI e, Comparable e) => Anns '[TypeAnn, VarAnn, Notes e] -> Instr s ('TSet e ': s) + AnnEMPTY_MAP :: (SingI a, SingI b, Comparable a) => Anns '[TypeAnn, VarAnn, Notes a, Notes b] -> Instr s ('TMap a b ': s) + AnnEMPTY_BIG_MAP :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Anns '[TypeAnn, VarAnn, Notes a, Notes b] -> Instr s ('TBigMap a b ': s) + AnnMAP :: (MapOp c, SingI b) + => AnnVar + -> Instr (MapOpInp c ': s) (b ': s) -> Instr (c ': s) (MapOpRes c b ': s) ITER :: IterOp c => Instr (IterOpEl c ': s) s -> Instr (c ': s) s - MEM :: MemOp c => Instr (MemOpKey c ': c ': s) ('TBool ': s) - GET + AnnMEM :: MemOp c => AnnVar -> Instr (MemOpKey c ': c ': s) ('TBool ': s) + AnnGET :: (GetOp c, SingI (GetOpVal c)) - => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s) + => AnnVar -> Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s) -- | Get the node at index @ix@ of a right-combed pair. -- Nodes are 0-indexed, and are numbered in a breadth-first, -- left-to-right fashion. @@ -584,14 +550,16 @@ -- >>> :t GETN (toPeanoNatural' @0) :: Instr '[ 'TInt ] _ -- ... -- ...:: Instr '[ 'TInt] '[ 'TInt] - GETN + AnnGETN :: forall (ix :: Peano) (pair :: T) (s :: [T]). ConstraintGetN ix pair - => PeanoNatural ix + => AnnVar + -> PeanoNatural ix -> Instr (pair : s) (GetN ix pair ': s) - UPDATE + AnnUPDATE :: UpdOp c - => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s) + => AnnVar + -> Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s) -- | Update the node at index @ix@ of a right-combed pair. -- -- >>> :t UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit] _ @@ -615,16 +583,18 @@ -- >>> :t UPDATEN (toPeanoNatural' @0) :: Instr '[ 'TInt, 'TString ] _ -- ... -- ...:: Instr '[ 'TInt, 'TString] '[ 'TInt] - UPDATEN + AnnUPDATEN :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]). ConstraintUpdateN ix pair - => PeanoNatural ix + => AnnVar + -> PeanoNatural ix -> Instr (val : pair : s) (UpdateN ix val pair ': s) - GET_AND_UPDATE + AnnGET_AND_UPDATE :: ( GetOp c, UpdOp c, SingI (GetOpVal c) , UpdOpKey c ~ GetOpKey c ) - => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) ('TOption (GetOpVal c) : c ': s) + => AnnVar + -> Instr (UpdOpKey c ': UpdOpParams c ': c ': s) ('TOption (GetOpVal c) : c ': s) IF :: Instr s s' -> Instr s s' -> Instr ('TBool ': s) s' @@ -633,12 +603,13 @@ LOOP_LEFT :: Instr (a ': s) ('TOr a b ': s) -> Instr ('TOr a b ': s) (b ': s) - LAMBDA :: forall i o s . (SingI i, SingI o) - => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s) - EXEC :: Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s) - APPLY + AnnLAMBDA :: forall i o s . (SingI i, SingI o) + => Anns '[VarAnn, Notes i, Notes o] + -> Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s) + AnnEXEC :: AnnVar -> Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s) + AnnAPPLY :: forall a b c s . (ConstantScope a, SingI b) - => Instr (a ': 'TLambda ('TPair a b) c ': s) ('TLambda b c ': s) + => AnnVar -> 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') @@ -647,157 +618,198 @@ -- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint. -- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information. FAILWITH :: (SingI a, ConstantScope a) => Instr (a ': s) t - CAST :: forall a s . SingI a => Instr (a ': s) (a ': s) - RENAME :: Instr (a ': s) (a ': s) - PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s) - UNPACK :: (UnpackedValScope a, SingI a) => Instr ('TBytes ': s) ('TOption a ': s) - CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s) - CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s) - SLICE + AnnCAST :: forall a s . SingI a => Anns '[VarAnn, Notes a] -> Instr (a ': s) (a ': s) + AnnRENAME :: AnnVar -> Instr (a ': s) (a ': s) + AnnPACK :: PackedValScope a => AnnVar -> Instr (a ': s) ('TBytes ': s) + AnnUNPACK + :: (UnpackedValScope a, SingI a) + => Anns '[TypeAnn, VarAnn, Notes a] + -> Instr ('TBytes ': s) ('TOption a ': s) + AnnCONCAT :: ConcatOp c => AnnVar -> Instr (c ': c ': s) (c ': s) + AnnCONCAT' :: ConcatOp c => AnnVar -> Instr ('TList c ': s) (c ': s) + AnnSLICE :: (SliceOp c, SingI c) - => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s) - ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s) - ADD + => AnnVar + -> Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s) + AnnISNAT :: AnnVar -> Instr ('TInt ': s) ('TOption ('TNat) ': s) + AnnADD :: ArithOp Add n m - => Instr (n ': m ': s) (ArithRes Add n m ': s) - SUB + => AnnVar + -> Instr (n ': m ': s) (ArithRes Add n m ': s) + AnnSUB :: ArithOp Sub n m - => Instr (n ': m ': s) (ArithRes Sub n m ': s) - SUB_MUTEZ :: Instr ('TMutez ': 'TMutez ': s) ('TOption 'TMutez ': s) - MUL + => AnnVar + -> Instr (n ': m ': s) (ArithRes Sub n m ': s) + AnnSUB_MUTEZ :: AnnVar -> Instr ('TMutez ': 'TMutez ': s) ('TOption 'TMutez ': s) + AnnMUL :: ArithOp Mul n m - => Instr (n ': m ': s) (ArithRes Mul n m ': s) - EDIV + => AnnVar + -> Instr (n ': m ': s) (ArithRes Mul n m ': s) + AnnEDIV :: ArithOp EDiv n m - => Instr (n ': m ': s) (ArithRes EDiv n m ': s) - ABS + => AnnVar + -> Instr (n ': m ': s) (ArithRes EDiv n m ': s) + AnnABS :: UnaryArithOp Abs n - => Instr (n ': s) (UnaryArithRes Abs n ': s) - NEG + => AnnVar + -> Instr (n ': s) (UnaryArithRes Abs n ': s) + AnnNEG :: UnaryArithOp Neg n - => Instr (n ': s) (UnaryArithRes Neg n ': s) - LSL + => AnnVar + -> Instr (n ': s) (UnaryArithRes Neg n ': s) + AnnLSL :: ArithOp Lsl n m - => Instr (n ': m ': s) (ArithRes Lsl n m ': s) - LSR + => AnnVar + -> Instr (n ': m ': s) (ArithRes Lsl n m ': s) + AnnLSR :: ArithOp Lsr n m - => Instr (n ': m ': s) (ArithRes Lsr n m ': s) - OR + => AnnVar + -> Instr (n ': m ': s) (ArithRes Lsr n m ': s) + AnnOR :: ArithOp Or n m - => Instr (n ': m ': s) (ArithRes Or n m ': s) - AND + => AnnVar + -> Instr (n ': m ': s) (ArithRes Or n m ': s) + AnnAND :: ArithOp And n m - => Instr (n ': m ': s) (ArithRes And n m ': s) - XOR + => AnnVar + -> Instr (n ': m ': s) (ArithRes And n m ': s) + AnnXOR :: ArithOp Xor n m - => Instr (n ': m ': s) (ArithRes Xor n m ': s) - NOT + => AnnVar + -> Instr (n ': m ': s) (ArithRes Xor n m ': s) + AnnNOT :: UnaryArithOp Not n - => Instr (n ': s) (UnaryArithRes Not n ': s) - COMPARE + => AnnVar + -> Instr (n ': s) (UnaryArithRes Not n ': s) + AnnCOMPARE :: (Comparable n, SingI n) - => Instr (n ': n ': s) ('TInt ': s) - EQ + => AnnVar + -> Instr (n ': n ': s) ('TInt ': s) + AnnEQ :: UnaryArithOp Eq' n - => Instr (n ': s) (UnaryArithRes Eq' n ': s) - NEQ + => AnnVar + -> Instr (n ': s) (UnaryArithRes Eq' n ': s) + AnnNEQ :: UnaryArithOp Neq n - => Instr (n ': s) (UnaryArithRes Neq n ': s) - LT + => AnnVar + -> Instr (n ': s) (UnaryArithRes Neq n ': s) + AnnLT :: UnaryArithOp Lt n - => Instr (n ': s) (UnaryArithRes Lt n ': s) - GT + => AnnVar + -> Instr (n ': s) (UnaryArithRes Lt n ': s) + AnnGT :: UnaryArithOp Gt n - => Instr (n ': s) (UnaryArithRes Gt n ': s) - LE + => AnnVar + -> Instr (n ': s) (UnaryArithRes Gt n ': s) + AnnLE :: UnaryArithOp Le n - => Instr (n ': s) (UnaryArithRes Le n ': s) - GE + => AnnVar + -> Instr (n ': s) (UnaryArithRes Le n ': s) + AnnGE :: UnaryArithOp Ge n - => Instr (n ': s) (UnaryArithRes Ge n ': s) - INT + => AnnVar + -> Instr (n ': s) (UnaryArithRes Ge n ': s) + AnnINT :: ToIntArithOp n - => Instr (n ': s) ('TInt ': s) - VIEW - -- Here really only the return type is constrainted + => AnnVar + -> Instr (n ': s) ('TInt ': s) + AnnVIEW + -- Here really only the return type is constrained -- because it is given explicitly :: (SingI arg, ViewableScope ret) - => ViewName - -> Notes ret + => Anns '[VarAnn, Notes ret] + -> ViewName -> Instr (arg ': 'TAddress ': s) ('TOption ret ': s) - SELF + -- | Note that the field annotation on @SELF@ is stored as the second + -- parameter to 'AnnSELF', because it's not as much an annotation + -- as an entrypoint specification. + AnnSELF :: forall (arg :: T) s . - (ParameterScope arg) - => SomeEntrypointCallT arg + (ParameterScope arg, IsNotInView) + => AnnVar + -> SomeEntrypointCallT arg -> Instr s ('TContract arg ': s) - CONTRACT + -- | Note that the field annotation on @CONTRACT@ is stored as the second + -- parameter to 'AnnCONTRACT', because it's not as much an annotation + -- as an entrypoint specification. + AnnCONTRACT :: (ParameterScope p) - => Notes p -- Store Notes to be able to verify CONTRACT in typechecker + => Anns '[VarAnn, Notes p] -> EpName -> Instr ('TAddress ': s) ('TOption ('TContract p) ': s) - TRANSFER_TOKENS - :: (ParameterScope p) => - Instr (p ': 'TMutez ': 'TContract p ': s) - ('TOperation ': s) - SET_DELEGATE - :: Instr ('TOption 'TKeyHash ': s) ('TOperation ': s) + AnnTRANSFER_TOKENS + :: (ParameterScope p, IsNotInView) + => AnnVar + -> Instr (p ': 'TMutez ': 'TContract p ': s) ('TOperation ': s) + AnnSET_DELEGATE + :: IsNotInView + => AnnVar + -> Instr ('TOption 'TKeyHash ': s) ('TOperation ': s) - CREATE_CONTRACT - :: (ParameterScope p, StorageScope g) - => Contract' Instr p g + AnnCREATE_CONTRACT + :: (ParameterScope p, StorageScope g, IsNotInView) + => Anns '[VarAnn, VarAnn] + -> Contract' Instr p g -> Instr ('TOption 'TKeyHash ': 'TMutez ': g ': s) ('TOperation ': 'TAddress ': s) - IMPLICIT_ACCOUNT - :: Instr ('TKeyHash ': s) ('TContract 'TUnit ': s) - NOW :: Instr s ('TTimestamp ': s) - AMOUNT :: Instr s ('TMutez ': s) - BALANCE :: Instr s ('TMutez ': s) - VOTING_POWER :: Instr ('TKeyHash ': s) ('TNat ': s) - TOTAL_VOTING_POWER :: Instr s ('TNat ': s) - CHECK_SIGNATURE - :: Instr ('TKey ': 'TSignature ': 'TBytes ': s) - ('TBool ': s) - SHA256 :: Instr ('TBytes ': s) ('TBytes ': s) - SHA512 :: Instr ('TBytes ': s) ('TBytes ': s) - BLAKE2B :: Instr ('TBytes ': s) ('TBytes ': s) - SHA3 :: Instr ('TBytes ': s) ('TBytes ': s) - KECCAK :: Instr ('TBytes ': s) ('TBytes ': s) - HASH_KEY :: Instr ('TKey ': s) ('TKeyHash ': s) - PAIRING_CHECK - :: Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) ': s) ('TBool ': s) - SOURCE :: Instr s ('TAddress ': s) - SENDER :: Instr s ('TAddress ': s) - ADDRESS :: Instr ('TContract a ': s) ('TAddress ': s) - CHAIN_ID :: Instr s ('TChainId ': s) - LEVEL :: Instr s ('TNat ': s) - SELF_ADDRESS :: Instr s ('TAddress ': s) + AnnIMPLICIT_ACCOUNT + :: AnnVar + -> Instr ('TKeyHash ': s) ('TContract 'TUnit ': s) + AnnNOW :: AnnVar -> Instr s ('TTimestamp ': s) + AnnAMOUNT :: AnnVar -> Instr s ('TMutez ': s) + AnnBALANCE :: AnnVar -> Instr s ('TMutez ': s) + AnnVOTING_POWER :: AnnVar -> Instr ('TKeyHash ': s) ('TNat ': s) + AnnTOTAL_VOTING_POWER :: AnnVar -> Instr s ('TNat ': s) + AnnCHECK_SIGNATURE + :: AnnVar + -> Instr ('TKey ': 'TSignature ': 'TBytes ': s) ('TBool ': s) + AnnSHA256 :: AnnVar -> Instr ('TBytes ': s) ('TBytes ': s) + AnnSHA512 :: AnnVar -> Instr ('TBytes ': s) ('TBytes ': s) + AnnBLAKE2B :: AnnVar -> Instr ('TBytes ': s) ('TBytes ': s) + AnnSHA3 :: AnnVar -> Instr ('TBytes ': s) ('TBytes ': s) + AnnKECCAK :: AnnVar -> Instr ('TBytes ': s) ('TBytes ': s) + AnnHASH_KEY :: AnnVar -> Instr ('TKey ': s) ('TKeyHash ': s) + AnnPAIRING_CHECK + :: AnnVar + -> Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) ': s) ('TBool ': s) + AnnSOURCE :: AnnVar -> Instr s ('TAddress ': s) + AnnSENDER :: AnnVar -> Instr s ('TAddress ': s) + AnnADDRESS :: AnnVar -> Instr ('TContract a ': s) ('TAddress ': s) + AnnCHAIN_ID :: AnnVar -> Instr s ('TChainId ': s) + AnnLEVEL :: AnnVar -> Instr s ('TNat ': s) + AnnSELF_ADDRESS :: AnnVar -> Instr s ('TAddress ': s) NEVER :: Instr ('TNever ': s) t - TICKET + AnnTICKET :: (Comparable a) - => Instr (a ': 'TNat ': s) ('TTicket a ': s) - READ_TICKET - :: Instr ('TTicket a ': s) - (RightComb ['TAddress, a, 'TNat] ': 'TTicket a ': s) - SPLIT_TICKET - :: Instr ('TTicket a ': 'TPair 'TNat 'TNat ': s) + => AnnVar + -> Instr (a ': 'TNat ': s) ('TTicket a ': s) + AnnREAD_TICKET + :: AnnVar + -> Instr ('TTicket a ': s) (RightComb ['TAddress, a, 'TNat] ': 'TTicket a ': s) + AnnSPLIT_TICKET + :: AnnVar + -> Instr ('TTicket a ': 'TPair 'TNat 'TNat ': s) ('TOption ('TPair ('TTicket a) ('TTicket a)) ': s) - JOIN_TICKETS - :: Instr ('TPair ('TTicket a) ('TTicket a) ': s) + AnnJOIN_TICKETS + :: AnnVar + -> Instr ('TPair ('TTicket a) ('TTicket a) ': s) ('TOption ('TTicket a) ': s) - OPEN_CHEST - :: Instr ('TChestKey ': 'TChest ': 'TNat ': s) + AnnOPEN_CHEST + :: AnnVar + -> Instr ('TChestKey ': 'TChest ': 'TNat ': s) ('TOr 'TBytes 'TBool ': s) - SAPLING_EMPTY_STATE - :: Sing n + AnnSAPLING_EMPTY_STATE + :: AnnVar + -> Sing n -> Instr s ('TSaplingState n ': s) - SAPLING_VERIFY_UPDATE - :: Instr ('TSaplingTransaction n : 'TSaplingState n ': s) - ('TOption ('TPair 'TInt ('TSaplingState n)) ': s) - -{-# DEPRECATED Fn "Morley let macros are deprecated" #-} + AnnSAPLING_VERIFY_UPDATE + :: AnnVar + -> Instr ('TSaplingTransaction n : 'TSaplingState n ': s) + ('TOption ('TPair 'TBytes ('TPair 'TInt ('TSaplingState n))) ': s) + AnnMIN_BLOCK_TIME :: [AnyAnn] -> Instr s ('TNat ': s) castInstr :: forall inp1 out1 inp2 out2. @@ -827,32 +839,6 @@ instance Monoid (Instr s s) where mempty = Nop --- 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 (UnsafeAnnotation "") (UnsafeAnnotation "") - -pattern CDR :: () => (i ~ ('TPair a b : s), o ~ (b : s)) => Instr i o -pattern CDR = AnnCDR (UnsafeAnnotation "") (UnsafeAnnotation "") - -pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : b : s)) => Instr i o -pattern UNPAIR = AnnUNPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") - -pattern PAIR :: () => (i ~ (a ': b ': s), o ~ ('TPair a b ': s)) => Instr i o -pattern PAIR = AnnPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") - -pattern LEFT :: () => (SingI b, i ~ (a ': s), o ~ ('TOr a b ': s)) => Instr i o -pattern LEFT = AnnLEFT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") - -pattern RIGHT :: () => (SingI a, i ~ (b ': s), o ~ ('TOr a b ': s)) => Instr i o -pattern RIGHT = AnnRIGHT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") - data TestAssert (s :: [T]) where TestAssert :: Text @@ -861,8 +847,6 @@ -> 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 @@ -928,8 +912,6 @@ | STACKTYPE StackTypePattern deriving stock (Show, Generic) -instance NFData (ExtInstr s) - data SomeMeta where SomeMeta :: forall meta @@ -942,4 +924,61 @@ deriving stock instance Show SomeMeta -$(deriveGADTNFData ''Instr) +-- | A convenience pattern synonym for v'Meta', +-- matching on a concrete given type wrapped by @SomeMeta@, e.g. +-- +-- > \case { ContreteMeta (x :: Word) -> ... } +pattern ConcreteMeta :: Typeable meta => meta -> Instr i o -> Instr i o +pattern ConcreteMeta meta instr <- Meta (SomeMeta (cast -> Just meta)) instr + +deriveGADTNFData ''Instr + +instance NFData (ExtInstr s) + +instance NFData (TestAssert s) where + rnf (TestAssert a b c) = rnf (a, b, c) + +$( + -- This TH splice generates pattern synonyms for @AnnX@ data constructors + -- without the @Ann@ prefix, ignoring annotations. Matching simply ignores + -- the first argument (containing the list of annotations), and construction + -- uses @def@. + do + TyConI (DataD _ _ _ _ cons _) <- reify ''Instr + let go forallSig = \case + ForallC varbndrs cxt'' con -> go (Just (varbndrs, cxt'')) con + GadtC nms btys (AppT (AppT _ inpT) outT) -> concatForM nms \nm -> do + case "Ann" `stripPrefix` nameBase nm of + Just base -> do + let btys' = drop 1 btys + args <- forM btys' \_ -> newName "arg" + inpV <- newName "inp" + outV <- newName "out" + let pat = PatSynD baseName (PrefixPatSyn args) (ExplBidir [cl]) + (ConP nm $ WildP:(VarP <$> args)) + baseName = mkName base + cl = Clause (VarP <$> args) (NormalB body) [] + body = foldl' AppE (ConE nm) $ (VarE $ mkName "def"):(VarE <$> args) + inpout = [PlainTV inpV InferredSpec, PlainTV outV InferredSpec] + eqT x y = AppT (AppT EqualityT x) y + forallc + | Just (vars, cxt') <- forallSig + = ForallT inpout [] . ForallT vars (eqT (VarT inpV) inpT : eqT (VarT outV) outT : cxt') + | otherwise = id + patsig = forallc $ + foldr (AppT . AppT ArrowT . snd) (AppT (AppT (ConT ''Instr) (VarT inpV)) (VarT outV)) btys' + pure [PatSynSigD baseName patsig, pat] + Nothing -> pure [] + _ -> pure [] + conName = \case + ForallC _ _ con -> conName con + GadtC nms _ _ -> nameBase <$> nms + NormalC nm _ -> [nameBase nm] + RecC nm _ -> [nameBase nm] + InfixC _ nm _ -> [nameBase nm] + RecGadtC nms _ _ -> nameBase <$> nms + stripAnn x = fromMaybe x $ "Ann" `stripPrefix` x + + pats <- concat <$> traverse (go Nothing) cons + pure $ (PragmaD $ CompleteP (mkName . stripAnn <$> concatMap conName cons) Nothing) : pats + ) diff --git a/src/Morley/Michelson/Typed/OpSize.hs b/src/Morley/Michelson/Typed/OpSize.hs deleted file mode 100644 --- a/src/Morley/Michelson/Typed/OpSize.hs +++ /dev/null @@ -1,33 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Measuring operation size of typed stuff. -module Morley.Michelson.Typed.OpSize - ( OpSize (..) - , U.opSizeHardLimit - , U.smallTransferOpSize - - , instrOpSize - , contractOpSize - , valueOpSize - ) where - -import Morley.Michelson.Typed.Aliases -import Morley.Michelson.Typed.Contract -import Morley.Michelson.Typed.Convert -import Morley.Michelson.Typed.Instr -import Morley.Michelson.Typed.Scope -import Morley.Michelson.Untyped (OpSize) -import Morley.Michelson.Untyped qualified as U - --- | Estimate instruction operation size. -instrOpSize :: Instr inp out -> OpSize -instrOpSize = U.expandedInstrsOpSize . instrToOps - --- | Estimate contract code operation size. -contractOpSize :: Contract cp st -> OpSize -contractOpSize = instrOpSize . cCode - --- | Estimate value operation size. -valueOpSize :: (UntypedValScope t) => Value t -> OpSize -valueOpSize = U.valueOpSize . untypeValue diff --git a/src/Morley/Michelson/Typed/Operation.hs b/src/Morley/Michelson/Typed/Operation.hs --- a/src/Morley/Michelson/Typed/Operation.hs +++ b/src/Morley/Michelson/Typed/Operation.hs @@ -17,15 +17,16 @@ import Morley.Michelson.Interpret.Pack (toBinary, toBinary') import Morley.Michelson.Runtime.TxData (TxData(..)) -import Morley.Michelson.Typed (EpName) +import Morley.Michelson.Typed (EpName, unContractCode) import Morley.Michelson.Typed.Aliases (Contract, Value) import Morley.Michelson.Typed.Contract (cCode) import Morley.Michelson.Typed.Entrypoints (EpAddress(..)) import Morley.Michelson.Typed.Haskell.Value (IsoValue(..)) import Morley.Michelson.Typed.Scope (ParameterScope, StorageScope) -import Morley.Tezos.Address (Address(ContractAddress), ContractHash(..), GlobalCounter(..)) +import Morley.Tezos.Address (Address(ContractAddress), GlobalCounter(..)) +import Morley.Tezos.Address.Alias (Alias) import Morley.Tezos.Core (Mutez(..)) -import Morley.Tezos.Crypto (KeyHash, blake2b, blake2b160) +import Morley.Tezos.Crypto (Hash(..), HashTag(..), KeyHash, blake2b, blake2b160) newtype OperationHash = OperationHash { unOperationHash :: ByteString @@ -63,6 +64,8 @@ -- ^ The value of the global counter at the time the operation was created. -- We store it here so that the resulting addresses of @CREATE_CONTRACT@ and -- performing of origination operation are the same. + , ooAlias :: Maybe Alias + -- ^ An alias to be associated with the originated contract's address. -- In Tezos each operation also has a special field called @counter@, see here: -- https://gitlab.com/tezos/tezos/-/blob/397dd233a10cc6df0df959e2a624c7947997dd0c/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120 @@ -86,7 +89,7 @@ packedOperation = BSL.toStrict (runPut $ putWord64be $ fromIntegral @Word63 @Word64 $ unMutez ooBalance) <> packMaybe (toBinary' . toVal) ooDelegate - <> toBinary' (cCode ooContract) + <> toBinary' (unContractCode $ cCode ooContract) <> toBinary' ooStorage -- | Compute address of a contract from its origination operation and global counter. @@ -112,7 +115,7 @@ -> Address mkContractAddress (OperationHash opHash) (GlobalCounter counter) = ContractAddress - $ ContractHash + $ Hash HashContract $ blake2b160 $ opHash <> BSL.toStrict (runPut $ putWord64be counter) diff --git a/src/Morley/Michelson/Typed/Polymorphic.hs b/src/Morley/Michelson/Typed/Polymorphic.hs --- a/src/Morley/Michelson/Typed/Polymorphic.hs +++ b/src/Morley/Michelson/Typed/Polymorphic.hs @@ -192,14 +192,6 @@ type EDivOpRes n m :: T type EModOpRes n m :: T - -- | Converge the notes of given operands. - convergeEDiv - :: Notes n - -> Notes m - -> Either AnnConvergeError - (Notes ('TOption ('TPair (EDivOpRes n m) - (EModOpRes n m)))) - evalEDivOp :: Value' instr n -> Value' instr m @@ -209,9 +201,6 @@ instance EDivOp 'TInt 'TInt where type EDivOpRes 'TInt 'TInt = 'TInt type EModOpRes 'TInt 'TInt = 'TNat - convergeEDiv n1 n2 = - (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a $ NTNat noAnn) - <$> converge n1 n2 evalEDivOp (VInt i) (VInt j) = if j == 0 then VOption $ Nothing @@ -221,8 +210,6 @@ instance EDivOp 'TInt 'TNat where type EDivOpRes 'TInt 'TNat = 'TInt type EModOpRes 'TInt 'TNat = 'TNat - convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1 - $ NTNat noAnn evalEDivOp (VInt i) (VNat j) = if j == 0 then VOption $ Nothing @@ -232,8 +219,6 @@ instance EDivOp 'TNat 'TInt where type EDivOpRes 'TNat 'TInt = 'TInt type EModOpRes 'TNat 'TInt = 'TNat - convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn - (NTInt noAnn) n1 evalEDivOp (VNat i) (VInt j) = if j == 0 then VOption $ Nothing @@ -243,8 +228,6 @@ instance EDivOp 'TNat 'TNat where type EDivOpRes 'TNat 'TNat = 'TNat type EModOpRes 'TNat 'TNat = 'TNat - convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a a) - <$> converge n1 n2 evalEDivOp (VNat i) (VNat j) = if j == 0 then VOption $ Nothing @@ -254,8 +237,6 @@ instance EDivOp 'TMutez 'TMutez where type EDivOpRes 'TMutez 'TMutez = 'TNat type EModOpRes 'TMutez 'TMutez = 'TMutez - convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn (NTNat noAnn) a) - <$> converge n1 n2 evalEDivOp (VMutez i) (VMutez j) = VOption $ i `divModMutez` j <&> \case @@ -265,7 +246,6 @@ instance EDivOp 'TMutez 'TNat where type EDivOpRes 'TMutez 'TNat = 'TMutez type EModOpRes 'TMutez 'TNat = 'TMutez - convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1 n1 evalEDivOp (VMutez i) (VNat j) = VOption $ i `divModMutezInt` j <&> \case diff --git a/src/Morley/Michelson/Typed/Scope.hs b/src/Morley/Michelson/Typed/Scope.hs --- a/src/Morley/Michelson/Typed/Scope.hs +++ b/src/Morley/Michelson/Typed/Scope.hs @@ -550,6 +550,7 @@ STAddress -> OpAbsent STChest -> OpAbsent STChestKey -> OpAbsent + STTxRollupL2Address -> OpAbsent STNever -> OpAbsent STSaplingState _ -> OpAbsent STSaplingTransaction _ -> OpAbsent @@ -600,6 +601,7 @@ STAddress -> ContractAbsent STChest -> ContractAbsent STChestKey -> ContractAbsent + STTxRollupL2Address -> ContractAbsent STNever -> ContractAbsent STSaplingState _ -> ContractAbsent STSaplingTransaction _ -> ContractAbsent @@ -650,6 +652,7 @@ STAddress -> TicketAbsent STChest -> TicketAbsent STChestKey -> TicketAbsent + STTxRollupL2Address -> TicketAbsent STNever -> TicketAbsent STSaplingState _ -> TicketAbsent STSaplingTransaction _ -> TicketAbsent @@ -700,6 +703,7 @@ STAddress -> BigMapAbsent STChest -> BigMapAbsent STChestKey -> BigMapAbsent + STTxRollupL2Address -> BigMapAbsent STNever -> BigMapAbsent STSaplingState _ -> BigMapAbsent STSaplingTransaction _ -> BigMapAbsent @@ -751,6 +755,7 @@ STAddress -> NestedBigMapsAbsent STChest -> NestedBigMapsAbsent STChestKey -> NestedBigMapsAbsent + STTxRollupL2Address -> NestedBigMapsAbsent STNever -> NestedBigMapsAbsent STSaplingState _ -> NestedBigMapsAbsent STSaplingTransaction _ -> NestedBigMapsAbsent @@ -802,6 +807,7 @@ STAddress -> SaplingStateAbsent STChest -> SaplingStateAbsent STChestKey -> SaplingStateAbsent + STTxRollupL2Address -> SaplingStateAbsent STNever -> SaplingStateAbsent STSaplingState _ -> SaplingStatePresent STSaplingTransaction _ -> SaplingStateAbsent @@ -1027,59 +1033,55 @@ -- or in our case: @pair@ does not contain @x@ -> @a@ and @b@ don't contain @x@. -- -- GHC is however not able to prove this, so we need to use another (impossible) --- 'error' to forcefully "prove" one of the two scopes. --- Funnily enough however GHC is able to prove that if one holds then the other --- does too, so we don't actually have to prove both, see 'mkWithDeMorgan'. +-- 'error' to forcefully "prove" the two scopes. class WithDeMorganScope (c :: T -> Constraint) t a b where withDeMorganScope :: c (t a b) => ((c a, c b) => ret) -> ret --- | Helper to builds a 'WithDeMorganScope' by using a 'CheckScope' that we know +-- | Helper to build a 'WithDeMorganScope' by using a 'CheckScope' that we know -- cannot fail. --- --- This can be used to make instances that also prove the other side of a --- negative @or-like@ scope constraint, see 'WithDeMorganScope'. mkWithDeMorgan - :: forall scope a ret. CheckScope (scope a) - => (scope a => ret) -> ret + :: forall scope a b ret. (CheckScope (scope a), CheckScope (scope b)) + => ((scope a, scope b) => ret) -> ret mkWithDeMorgan f = fromRight (error "impossible") $ do Dict <- checkScope @(scope a) + Dict <- checkScope @(scope b) pure f -instance SingI a => WithDeMorganScope HasNoOp 'TPair a b where - withDeMorganScope = mkWithDeMorgan @HasNoOp @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoOp 'TPair a b where + withDeMorganScope = mkWithDeMorgan @HasNoOp @a @b -instance SingI a => WithDeMorganScope HasNoContract 'TPair a b where - withDeMorganScope = mkWithDeMorgan @HasNoContract @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoContract 'TPair a b where + withDeMorganScope = mkWithDeMorgan @HasNoContract @a @b -instance SingI a => WithDeMorganScope HasNoTicket 'TPair a b where - withDeMorganScope = mkWithDeMorgan @HasNoTicket @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoTicket 'TPair a b where + withDeMorganScope = mkWithDeMorgan @HasNoTicket @a @b -instance SingI a => WithDeMorganScope HasNoBigMap 'TPair a b where - withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoBigMap 'TPair a b where + withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a @b -instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TPair a b where - withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoNestedBigMaps 'TPair a b where + withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a @b -instance SingI a => WithDeMorganScope HasNoOp 'TOr a b where - withDeMorganScope = mkWithDeMorgan @HasNoOp @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoOp 'TOr a b where + withDeMorganScope = mkWithDeMorgan @HasNoOp @a @b -instance SingI a => WithDeMorganScope HasNoContract 'TOr a b where - withDeMorganScope = mkWithDeMorgan @HasNoContract @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoContract 'TOr a b where + withDeMorganScope = mkWithDeMorgan @HasNoContract @a @b -instance SingI a => WithDeMorganScope HasNoTicket 'TOr a b where - withDeMorganScope = mkWithDeMorgan @HasNoTicket @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoTicket 'TOr a b where + withDeMorganScope = mkWithDeMorgan @HasNoTicket @a @b -instance SingI a => WithDeMorganScope HasNoBigMap 'TOr a b where - withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoBigMap 'TOr a b where + withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a @b -instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TOr a b where - withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a +instance (SingI a, SingI b) => WithDeMorganScope HasNoNestedBigMaps 'TOr a b where + withDeMorganScope = mkWithDeMorgan @HasNoNestedBigMaps @a @b -instance SingI k => WithDeMorganScope HasNoOp 'TMap k v where - withDeMorganScope = mkWithDeMorgan @HasNoOp @k +instance (SingI k, SingI v) => WithDeMorganScope HasNoOp 'TMap k v where + withDeMorganScope = mkWithDeMorgan @HasNoOp @k @v -instance SingI k => WithDeMorganScope HasNoOp 'TBigMap k v where - withDeMorganScope = mkWithDeMorgan @HasNoOp @k +instance (SingI k, SingI v) => WithDeMorganScope HasNoOp 'TBigMap k v where + withDeMorganScope = mkWithDeMorgan @HasNoOp @k @v instance ( WithDeMorganScope HasNoOp t a b @@ -1248,6 +1250,7 @@ instance Comparable 'TKeyHash instance Comparable 'TTimestamp instance Comparable 'TAddress +instance Comparable 'TTxRollupL2Address instance Comparable 'TNever instance Comparable 'TChainId instance Comparable 'TSignature @@ -1270,8 +1273,9 @@ instance WellTyped 'TNever instance WellTyped 'TSignature instance WellTyped 'TChainId -instance WellTyped 'TChest where -instance WellTyped 'TChestKey where +instance WellTyped 'TChest +instance WellTyped 'TChestKey +instance WellTyped 'TTxRollupL2Address instance WellTypedSuperC ('TOption t) => WellTyped ('TOption t) where type WellTypedSuperC ('TOption t) = WellTyped t @@ -1408,6 +1412,7 @@ STAddress -> Right Dict STChest -> Right Dict STChestKey -> Right Dict + STTxRollupL2Address -> Right Dict STNever -> Right Dict STSaplingState s -> withSingI s $ Right Dict STSaplingTransaction s -> withSingI s $ Right Dict @@ -1464,5 +1469,6 @@ STChainId -> CanBeCompared STChest -> CannotBeCompared STChestKey -> CannotBeCompared + STTxRollupL2Address -> CanBeCompared STSaplingState _ -> CannotBeCompared STSaplingTransaction _ -> CannotBeCompared diff --git a/src/Morley/Michelson/Typed/Sing.hs b/src/Morley/Michelson/Typed/Sing.hs --- a/src/Morley/Michelson/Typed/Sing.hs +++ b/src/Morley/Michelson/Typed/Sing.hs @@ -18,13 +18,15 @@ , requireEq ) where -import Data.Singletons (SingI(..), demote) +import Data.Singletons (SingI(..), demote, fromSing) import Data.Type.Equality ((:~:)(..)) import Fmt ((+|), (|+)) +import Morley.Michelson.Printer.Util (RenderDoc(..)) import Morley.Michelson.Typed.T (T(..)) import Morley.Util.MismatchError import Morley.Util.Sing (SingI1(..), castSing, eqI, genSingletonsType) +import Morley.Util.TH (deriveGADTNFData) -- | 'SingI' and 'Data.Singletons.TH.SDecide' instances for the 'T' kind. $(genSingletonsType ''T) @@ -87,3 +89,11 @@ -- | Version of 'eqI' that uses 'Proxy' eqP :: forall (a :: T) (b :: T). (SingI a, SingI b) => Proxy a -> Proxy b -> Maybe (a :~: b) eqP _ _ = eqI @a @b + +deriving stock instance Show (SingT x) +deriving stock instance Eq (SingT x) + +deriveGADTNFData ''SingT + +instance RenderDoc (SingT t) where + renderDoc pn s = renderDoc pn $ fromSing s diff --git a/src/Morley/Michelson/Typed/T.hs b/src/Morley/Michelson/Typed/T.hs --- a/src/Morley/Michelson/Typed/T.hs +++ b/src/Morley/Michelson/Typed/T.hs @@ -50,6 +50,7 @@ | TChestKey | TSaplingState Peano.Peano | TSaplingTransaction Peano.Peano + | TTxRollupL2Address | TNever deriving stock (Eq, Show, Generic) @@ -78,6 +79,7 @@ convert TChainId = Un.TChainId convert TChest = Un.TChest convert TChestKey = Un.TChestKey + convert TTxRollupL2Address = Un.TTxRollupL2Address convert TNever = Un.TNever convert (TSaplingState n) = Un.TSaplingState (Peano.toNatural n) convert (TSaplingTransaction n) = Un.TSaplingTransaction (Peano.toNatural n) diff --git a/src/Morley/Michelson/Typed/Util.hs b/src/Morley/Michelson/Typed/Util.hs --- a/src/Morley/Michelson/Typed/Util.hs +++ b/src/Morley/Michelson/Typed/Util.hs @@ -1,18 +1,13 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | General-purpose utility functions for typed types. module Morley.Michelson.Typed.Util ( -- * Instruction analysis DfsSettings (..) , CtorEffectsApp (..) - , ceaBottomToTop , dfsTraverseInstr - , dfsInstr , dfsFoldInstr , dfsModifyInstr @@ -37,6 +32,10 @@ -- * Working with 'RemFail' , analyzeInstrFailure + + -- * Annotations + , SomeAnns(..) + , instrAnns ) where import Debug qualified (show) @@ -49,16 +48,17 @@ import Data.Set qualified as S import Data.Text.Internal.Builder (fromText) import Fmt (Buildable(..)) -import GHC.Exts (fromList) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed.Aliases +import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Contract import Morley.Michelson.Typed.Instr import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T qualified as T import Morley.Michelson.Typed.Value import Morley.Michelson.Typed.View +import Morley.Michelson.Untyped (AnyAnn) -- $setup -- >>> :m + Morley.Michelson.Typed.Instr @@ -71,6 +71,8 @@ -- (which can be passed to @CREATE_CONTRACT@). , dsCtorEffectsApp :: CtorEffectsApp m -- ^ How do we handle intermediate nodes in instruction tree. + , dsInstrStep :: (forall i o. Instr i o -> m (Instr i o)) + , dsValueStep :: (forall t'. Value t' -> m (Value t')) } -- | Describes how intermediate nodes in instruction tree are accounted. @@ -91,48 +93,40 @@ instance Buildable (CtorEffectsApp x) where build CtorEffectsApp{..} = fromText ceaName --- | Gather effects first for children nodes, then for their parents. -{-# DEPRECATED ceaBottomToTop "\"Bottom to top\" is the only available behaviour now." #-} -ceaBottomToTop :: CtorEffectsApp x -ceaBottomToTop = CtorEffectsApp - { ceaName = "Do nothing" - , ceaPostStep = const id - } - -instance Default (DfsSettings x) where +instance (Applicative x) => Default (DfsSettings x) where def = DfsSettings { dsGoToValues = False - , dsCtorEffectsApp = ceaBottomToTop + , dsCtorEffectsApp = CtorEffectsApp + { ceaName = "Do nothing" + , ceaPostStep = const id + } + , dsInstrStep = pure + , dsValueStep = pure } -- | Traverse a typed instruction in depth-first order. -- --- The step action will be applied in bottom-to-top order, i.e. +-- The 'dsInstrStep' and 'dsValueStep' actions will be applied in bottom-to-top order, i.e. -- first to the children of a node, then to the node itself. dfsTraverseInstr :: forall m inp out. (Monad m) => DfsSettings m - -> (forall i o. Instr i o -> m (Instr i o)) -> Instr inp out -> m (Instr inp out) -dfsTraverseInstr settings@DfsSettings{..} step i = +dfsTraverseInstr settings@DfsSettings{..} i = case i of Seq i1 i2 -> recursion2 Seq i1 i2 WithLoc loc i1 -> recursion1 (WithLoc loc) i1 Meta meta i1 -> recursion1 (Meta meta) i1 - InstrWithNotes p notes i1 -> recursion1 (InstrWithNotes p notes) i1 - InstrWithVarNotes varNotes i1 -> recursion1 (InstrWithVarNotes varNotes) i1 - InstrWithVarAnns varAnns i1 -> recursion1 (InstrWithVarAnns varAnns) i1 FrameInstr p i1 -> recursion1 (FrameInstr p) i1 Nested i1 -> recursion1 Nested i1 DocGroup dg i1 -> recursion1 (DocGroup dg) i1 - Fn t sfn i1 -> recursion1 (Fn t sfn) i1 IF_NONE i1 i2 -> recursion2 IF_NONE i1 i2 IF_LEFT i1 i2 -> recursion2 IF_LEFT i1 i2 IF_CONS i1 i2 -> recursion2 IF_CONS i1 i2 IF i1 i2 -> recursion2 IF i1 i2 - MAP i1 -> recursion1 MAP i1 + AnnMAP ann i1 -> recursion1 (AnnMAP ann) i1 ITER i1 -> recursion1 ITER i1 LOOP i1 -> recursion1 LOOP i1 LOOP_LEFT i1 -> recursion1 LOOP_LEFT i1 @@ -142,35 +136,29 @@ -- This case is more complex so we duplicate @recursion1@ a bit. -- We have to traverse the pushed value because a lambda can be -- somewhere inside of it (e. g. one item of a pair). - PUSH v + AnnPUSH ann v | dsGoToValues -> ceaPostStep dsCtorEffectsApp i do - let - valueStep :: forall t . Value t -> m (Value t) - valueStep = \case - -- Using 'analyzeInstrFailure' here (and in case below) is cheap - -- (O(n) in total) because we never make it run over the same code twice - VLam lambda -> fmap (VLam . analyzeInstrFailure) $ - dfsTraverseInstr settings step (rfAnyInstr lambda) - otherV -> pure otherV - innerV <- dfsTraverseValue valueStep v - step $ PUSH innerV + innerV <- dfsTraverseValue settings v + dsInstrStep $ AnnPUSH ann innerV | otherwise -> recursion0 i - LAMBDA (VLam i1) + AnnLAMBDA ann (VLam i1) | dsGoToValues -> - recursion1 (LAMBDA . VLam . analyzeInstrFailure) (rfAnyInstr i1) + recursion1 (AnnLAMBDA ann . VLam . analyzeInstrFailure) (rfAnyInstr i1) | otherwise -> recursion0 i - CREATE_CONTRACT contract + AnnCREATE_CONTRACT ann contract | dsGoToValues -> - ceaPostStep dsCtorEffectsApp i do - codeI <- dfsTraverseInstr settings step (cCode contract) - viewsI <- forM (toList $ cViews contract) \(SomeView v) -> do - code <- dfsTraverseInstr settings step $ vCode v - return $ SomeView v{ vCode = code } - step $ CREATE_CONTRACT $ contract - { cCode = codeI - , cViews = UnsafeViewsSet $ fromList viewsI - } + ceaPostStep dsCtorEffectsApp i + case cCode contract of + ContractCode c -> do + codeI <- dfsTraverseInstr settings c + viewsI <- forM (toList $ cViews contract) \(SomeView v) -> do + code <- dfsTraverseInstr settings $ vCode v + return $ SomeView v{ vCode = code } + dsInstrStep $ AnnCREATE_CONTRACT ann $ contract + { cCode = ContractCode codeI + , cViews = UnsafeViewsSet $ fromList viewsI + } | otherwise -> recursion0 i Nop{} -> recursion0 i @@ -181,110 +169,111 @@ AnnCDR{} -> recursion0 i DROP{} -> recursion0 i DROPN{} -> recursion0 i - DUP{} -> recursion0 i - DUPN{} -> recursion0 i + AnnDUP{} -> recursion0 i + AnnDUPN{} -> recursion0 i SWAP{} -> recursion0 i DIG{} -> recursion0 i DUG{} -> recursion0 i - SOME{} -> recursion0 i - NONE{} -> recursion0 i - UNIT{} -> recursion0 i + AnnSOME{} -> recursion0 i + AnnNONE{} -> recursion0 i + AnnUNIT{} -> recursion0 i AnnPAIR{} -> recursion0 i AnnUNPAIR{} -> recursion0 i - PAIRN{} -> recursion0 i + AnnPAIRN{} -> recursion0 i UNPAIRN{} -> recursion0 i AnnLEFT{} -> recursion0 i AnnRIGHT{} -> recursion0 i - NIL{} -> recursion0 i - CONS{} -> recursion0 i - SIZE{} -> recursion0 i - EMPTY_SET{} -> recursion0 i - EMPTY_MAP{} -> recursion0 i - EMPTY_BIG_MAP{} -> recursion0 i - MEM{} -> recursion0 i - GET{} -> recursion0 i - GETN{} -> recursion0 i - UPDATE{} -> recursion0 i - UPDATEN{} -> recursion0 i - GET_AND_UPDATE{} -> recursion0 i - EXEC{} -> recursion0 i - APPLY{} -> recursion0 i + AnnNIL{} -> recursion0 i + AnnCONS{} -> recursion0 i + AnnSIZE{} -> recursion0 i + AnnEMPTY_SET{} -> recursion0 i + AnnEMPTY_MAP{} -> recursion0 i + AnnEMPTY_BIG_MAP{} -> recursion0 i + AnnMEM{} -> recursion0 i + AnnGET{} -> recursion0 i + AnnGETN{} -> recursion0 i + AnnUPDATE{} -> recursion0 i + AnnUPDATEN{} -> recursion0 i + AnnGET_AND_UPDATE{} -> recursion0 i + AnnEXEC{} -> recursion0 i + AnnAPPLY{} -> recursion0 i FAILWITH{} -> recursion0 i - CAST{} -> recursion0 i - RENAME{} -> recursion0 i - PACK{} -> recursion0 i - UNPACK{} -> recursion0 i - CONCAT{} -> recursion0 i - CONCAT'{} -> recursion0 i - SLICE{} -> recursion0 i - ISNAT{} -> recursion0 i - ADD{} -> recursion0 i - SUB{} -> recursion0 i - SUB_MUTEZ{} -> recursion0 i - MUL{} -> recursion0 i - EDIV{} -> recursion0 i - ABS{} -> recursion0 i - NEG{} -> recursion0 i - LSL{} -> recursion0 i - LSR{} -> recursion0 i - OR{} -> recursion0 i - AND{} -> recursion0 i - XOR{} -> recursion0 i - NOT{} -> recursion0 i - COMPARE{} -> recursion0 i - EQ{} -> recursion0 i - NEQ{} -> recursion0 i - LT{} -> recursion0 i - GT{} -> recursion0 i - LE{} -> recursion0 i - GE{} -> recursion0 i - INT{} -> recursion0 i - VIEW{} -> recursion0 i - SELF{} -> recursion0 i - CONTRACT{} -> recursion0 i - TRANSFER_TOKENS{} -> recursion0 i - SET_DELEGATE{} -> recursion0 i - IMPLICIT_ACCOUNT{} -> recursion0 i - NOW{} -> recursion0 i - AMOUNT{} -> recursion0 i - BALANCE{} -> recursion0 i - VOTING_POWER{} -> recursion0 i - TOTAL_VOTING_POWER{} -> recursion0 i - CHECK_SIGNATURE{} -> recursion0 i - SHA256{} -> recursion0 i - SHA512{} -> recursion0 i - BLAKE2B{} -> recursion0 i - SHA3{} -> recursion0 i - KECCAK{} -> recursion0 i - HASH_KEY{} -> recursion0 i - PAIRING_CHECK{} -> recursion0 i - SOURCE{} -> recursion0 i - SENDER{} -> recursion0 i - ADDRESS{} -> recursion0 i - CHAIN_ID{} -> recursion0 i - LEVEL{} -> recursion0 i - SELF_ADDRESS{} -> recursion0 i + AnnCAST{} -> recursion0 i + AnnRENAME{} -> recursion0 i + AnnPACK{} -> recursion0 i + AnnUNPACK{} -> recursion0 i + AnnCONCAT{} -> recursion0 i + AnnCONCAT'{} -> recursion0 i + AnnSLICE{} -> recursion0 i + AnnISNAT{} -> recursion0 i + AnnADD{} -> recursion0 i + AnnSUB{} -> recursion0 i + AnnSUB_MUTEZ{} -> recursion0 i + AnnMUL{} -> recursion0 i + AnnEDIV{} -> recursion0 i + AnnABS{} -> recursion0 i + AnnNEG{} -> recursion0 i + AnnLSL{} -> recursion0 i + AnnLSR{} -> recursion0 i + AnnOR{} -> recursion0 i + AnnAND{} -> recursion0 i + AnnXOR{} -> recursion0 i + AnnNOT{} -> recursion0 i + AnnCOMPARE{} -> recursion0 i + AnnEQ{} -> recursion0 i + AnnNEQ{} -> recursion0 i + AnnLT{} -> recursion0 i + AnnGT{} -> recursion0 i + AnnLE{} -> recursion0 i + AnnGE{} -> recursion0 i + AnnINT{} -> recursion0 i + AnnVIEW{} -> recursion0 i + AnnSELF{} -> recursion0 i + AnnCONTRACT{} -> recursion0 i + AnnTRANSFER_TOKENS{} -> recursion0 i + AnnSET_DELEGATE{} -> recursion0 i + AnnIMPLICIT_ACCOUNT{} -> recursion0 i + AnnNOW{} -> recursion0 i + AnnAMOUNT{} -> recursion0 i + AnnBALANCE{} -> recursion0 i + AnnVOTING_POWER{} -> recursion0 i + AnnTOTAL_VOTING_POWER{} -> recursion0 i + AnnCHECK_SIGNATURE{} -> recursion0 i + AnnSHA256{} -> recursion0 i + AnnSHA512{} -> recursion0 i + AnnBLAKE2B{} -> recursion0 i + AnnSHA3{} -> recursion0 i + AnnKECCAK{} -> recursion0 i + AnnHASH_KEY{} -> recursion0 i + AnnPAIRING_CHECK{} -> recursion0 i + AnnSOURCE{} -> recursion0 i + AnnSENDER{} -> recursion0 i + AnnADDRESS{} -> recursion0 i + AnnCHAIN_ID{} -> recursion0 i + AnnLEVEL{} -> recursion0 i + AnnSELF_ADDRESS{} -> recursion0 i NEVER{} -> recursion0 i - TICKET{} -> recursion0 i - READ_TICKET{} -> recursion0 i - SPLIT_TICKET{} -> recursion0 i - JOIN_TICKETS{} -> recursion0 i - OPEN_CHEST{} -> recursion0 i - SAPLING_EMPTY_STATE{} -> recursion0 i - SAPLING_VERIFY_UPDATE{} -> recursion0 i + AnnTICKET{} -> recursion0 i + AnnREAD_TICKET{} -> recursion0 i + AnnSPLIT_TICKET{} -> recursion0 i + AnnJOIN_TICKETS{} -> recursion0 i + AnnOPEN_CHEST{} -> recursion0 i + AnnSAPLING_EMPTY_STATE{} -> recursion0 i + AnnSAPLING_VERIFY_UPDATE{} -> recursion0 i + AnnMIN_BLOCK_TIME{} -> recursion0 i where recursion0 :: forall a b. Instr a b -> m (Instr a b) recursion0 i0 = ceaPostStep dsCtorEffectsApp i0 $ - step i0 + dsInstrStep i0 recursion1 :: forall a b c d. (Instr a b -> Instr c d) -> Instr a b -> m (Instr c d) recursion1 constructor i0 = ceaPostStep dsCtorEffectsApp (constructor i0) do - innerI <- dfsTraverseInstr settings step i0 - step $ constructor innerI + innerI <- dfsTraverseInstr settings i0 + dsInstrStep $ constructor innerI recursion2 :: forall i o i1 o1 i2 o2. @@ -292,24 +281,9 @@ Instr i1 o1 -> Instr i2 o2 -> m (Instr i o) recursion2 constructor i1 i2 = ceaPostStep dsCtorEffectsApp (constructor i1 i2) do - i1' <- dfsTraverseInstr settings step i1 - i2' <- dfsTraverseInstr settings step i2 - step $ constructor i1' i2' - --- | Traverse a typed instruction in depth-first order. --- '<>' is used to concatenate intermediate results. --- Each instructions can be changed using the supplied @step@ function. --- It does not consider extra instructions (not present in Michelson). -{-# DEPRECATED dfsInstr "Use `dfsModifyInstr`, `dfsFoldInstr` or `dfsTraverseInstr` instead." #-} -dfsInstr :: - forall x inp out. - (Monoid x) - => DfsSettings (Writer x) - -> (forall i o. Instr i o -> (Instr i o, x)) - -> Instr inp out - -> (Instr inp out, x) -dfsInstr settings step i = - runWriter $ dfsTraverseInstr settings (writer . step) i + i1' <- dfsTraverseInstr settings i1 + i2' <- dfsTraverseInstr settings i2 + dsInstrStep $ constructor i1' i2' -- | Specialization of 'dfsTraverseInstr' for case when changing the instruction is -- not required. @@ -320,8 +294,8 @@ -> (forall i o. Instr i o -> x) -> Instr inp out -> x -dfsFoldInstr settings step instr = - snd $ dfsInstr settings (\i -> (i, step i)) instr +dfsFoldInstr settings step = + snd . runWriter . dfsTraverseInstr settings{dsInstrStep = writer . (id &&& step)} -- | Specialization of 'dfsTraverseInstr' which only modifies given instruction. dfsModifyInstr @@ -329,8 +303,8 @@ -> (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr inp out -dfsModifyInstr settings step instr = - runIdentity $ dfsTraverseInstr settings (pure . step) instr +dfsModifyInstr settings step = + runIdentity . dfsTraverseInstr settings{dsInstrStep = (pure . step)} -- | Check whether instruction fails at each execution path or have at least one -- non-failing path. @@ -358,21 +332,6 @@ RfNormal i0 -> RfNormal (Meta meta i0) r -> r - InstrWithNotes p pn i -> case go i of - RfNormal i0 -> - RfNormal (InstrWithNotes p pn i0) - RfAlwaysFails i0 -> - error $ "InstrWithNotes wraps always-failing instruction: " <> Debug.show i0 - InstrWithVarNotes vn i -> case go i of - RfNormal i0 -> - RfNormal (InstrWithVarNotes vn i0) - RfAlwaysFails i0 -> - error $ "InstrWithVarNotes wraps always-failing instruction: " <> Debug.show i0 - InstrWithVarAnns vn i -> case go i of - RfNormal i0 -> - RfNormal (InstrWithVarAnns vn i0) - RfAlwaysFails i0 -> - error $ "InstrWithVarAnns wraps always-failing instruction: " <> Debug.show i0 FrameInstr s i -> case go i of RfNormal i0 -> RfNormal (FrameInstr s i0) @@ -383,18 +342,17 @@ Ext e -> RfNormal (Ext e) Nested i -> Nested `rfMapAnyInstr` go i DocGroup g i -> DocGroup g `rfMapAnyInstr` go i - Fn t sfn i -> Fn t sfn `rfMapAnyInstr` go i IF_NONE l r -> rfMerge IF_NONE (go l) (go r) IF_LEFT l r -> rfMerge IF_LEFT (go l) (go r) IF_CONS l r -> rfMerge IF_CONS (go l) (go r) IF l r -> rfMerge IF (go l) (go r) - i@MAP{} -> RfNormal i + i@AnnMAP{} -> RfNormal i i@ITER{} -> RfNormal i i@LOOP{} -> RfNormal i i@LOOP_LEFT{} -> RfNormal i - i@LAMBDA{} -> RfNormal i + i@AnnLAMBDA{} -> RfNormal i i@DIP{} -> RfNormal i i@DIPN{} -> RfNormal i @@ -402,99 +360,100 @@ i@AnnCDR{} -> RfNormal i i@DROP{} -> RfNormal i i@DROPN{} -> RfNormal i - i@DUP{} -> RfNormal i - i@DUPN{} -> RfNormal i + i@AnnDUP{} -> RfNormal i + i@AnnDUPN{} -> RfNormal i i@SWAP{} -> RfNormal i i@DIG{} -> RfNormal i i@DUG{} -> RfNormal i - i@PUSH{} -> RfNormal i - i@SOME{} -> RfNormal i - i@NONE{} -> RfNormal i - i@UNIT{} -> RfNormal i + i@AnnPUSH{} -> RfNormal i + i@AnnSOME{} -> RfNormal i + i@AnnNONE{} -> RfNormal i + i@AnnUNIT{} -> RfNormal i i@AnnPAIR{} -> RfNormal i i@AnnUNPAIR{} -> RfNormal i - i@PAIRN{} -> RfNormal i + i@AnnPAIRN{} -> RfNormal i i@UNPAIRN{} -> RfNormal i i@AnnLEFT{} -> RfNormal i i@AnnRIGHT{} -> RfNormal i - i@NIL{} -> RfNormal i - i@CONS{} -> RfNormal i - i@SIZE{} -> RfNormal i - i@EMPTY_SET{} -> RfNormal i - i@EMPTY_MAP{} -> RfNormal i - i@EMPTY_BIG_MAP{} -> RfNormal i - i@MEM{} -> RfNormal i - i@GET{} -> RfNormal i - i@GETN{} -> RfNormal i - i@UPDATE{} -> RfNormal i - i@UPDATEN{} -> RfNormal i - i@GET_AND_UPDATE{} -> RfNormal i - i@EXEC{} -> RfNormal i - i@APPLY{} -> RfNormal i + i@AnnNIL{} -> RfNormal i + i@AnnCONS{} -> RfNormal i + i@AnnSIZE{} -> RfNormal i + i@AnnEMPTY_SET{} -> RfNormal i + i@AnnEMPTY_MAP{} -> RfNormal i + i@AnnEMPTY_BIG_MAP{} -> RfNormal i + i@AnnMEM{} -> RfNormal i + i@AnnGET{} -> RfNormal i + i@AnnGETN{} -> RfNormal i + i@AnnUPDATE{} -> RfNormal i + i@AnnUPDATEN{} -> RfNormal i + i@AnnGET_AND_UPDATE{} -> RfNormal i + i@AnnEXEC{} -> RfNormal i + i@AnnAPPLY{} -> RfNormal i FAILWITH -> RfAlwaysFails FAILWITH - i@CAST -> RfNormal i - i@RENAME -> RfNormal i - i@PACK -> RfNormal i - i@UNPACK -> RfNormal i - i@CONCAT -> RfNormal i - i@CONCAT' -> RfNormal i - i@SLICE -> RfNormal i - i@ISNAT -> RfNormal i - i@ADD -> RfNormal i - i@SUB -> RfNormal i - i@SUB_MUTEZ -> RfNormal i - i@MUL -> RfNormal i - i@EDIV -> RfNormal i - i@ABS -> RfNormal i - i@NEG -> RfNormal i - i@LSL -> RfNormal i - i@LSR -> RfNormal i - i@OR -> RfNormal i - i@AND -> RfNormal i - i@XOR -> RfNormal i - i@NOT -> RfNormal i - i@COMPARE -> RfNormal i - i@EQ -> RfNormal i - i@NEQ -> RfNormal i - i@LT -> RfNormal i - i@GT -> RfNormal i - i@LE -> RfNormal i - i@GE -> RfNormal i - i@INT -> RfNormal i - i@VIEW{} -> RfNormal i - i@SELF{} -> RfNormal i - i@CONTRACT{} -> RfNormal i - i@TRANSFER_TOKENS -> RfNormal i - i@SET_DELEGATE -> RfNormal i - i@CREATE_CONTRACT{} -> RfNormal i - i@IMPLICIT_ACCOUNT -> RfNormal i - i@NOW -> RfNormal i - i@AMOUNT -> RfNormal i - i@BALANCE -> RfNormal i - i@VOTING_POWER -> RfNormal i - i@TOTAL_VOTING_POWER -> RfNormal i - i@CHECK_SIGNATURE -> RfNormal i - i@SHA256 -> RfNormal i - i@SHA512 -> RfNormal i - i@BLAKE2B -> RfNormal i - i@SHA3 -> RfNormal i - i@KECCAK -> RfNormal i - i@HASH_KEY -> RfNormal i - i@PAIRING_CHECK -> RfNormal i - i@SOURCE -> RfNormal i - i@SENDER -> RfNormal i - i@ADDRESS -> RfNormal i - i@CHAIN_ID -> RfNormal i - i@LEVEL -> RfNormal i - i@SELF_ADDRESS -> RfNormal i + i@AnnCAST{} -> RfNormal i + i@AnnRENAME{} -> RfNormal i + i@AnnPACK{} -> RfNormal i + i@AnnUNPACK{} -> RfNormal i + i@AnnCONCAT{} -> RfNormal i + i@AnnCONCAT'{} -> RfNormal i + i@AnnSLICE{} -> RfNormal i + i@AnnISNAT{} -> RfNormal i + i@AnnADD{} -> RfNormal i + i@AnnSUB{} -> RfNormal i + i@AnnSUB_MUTEZ{} -> RfNormal i + i@AnnMUL{} -> RfNormal i + i@AnnEDIV{} -> RfNormal i + i@AnnABS{} -> RfNormal i + i@AnnNEG{} -> RfNormal i + i@AnnLSL{} -> RfNormal i + i@AnnLSR{} -> RfNormal i + i@AnnOR{} -> RfNormal i + i@AnnAND{} -> RfNormal i + i@AnnXOR{} -> RfNormal i + i@AnnNOT{} -> RfNormal i + i@AnnCOMPARE{} -> RfNormal i + i@AnnEQ{} -> RfNormal i + i@AnnNEQ{} -> RfNormal i + i@AnnLT{} -> RfNormal i + i@AnnGT{} -> RfNormal i + i@AnnLE{} -> RfNormal i + i@AnnGE{} -> RfNormal i + i@AnnINT{} -> RfNormal i + i@AnnVIEW{} -> RfNormal i + i@AnnSELF{} -> RfNormal i + i@AnnCONTRACT{} -> RfNormal i + i@AnnTRANSFER_TOKENS{} -> RfNormal i + i@AnnSET_DELEGATE{} -> RfNormal i + i@AnnCREATE_CONTRACT{} -> RfNormal i + i@AnnIMPLICIT_ACCOUNT{} -> RfNormal i + i@AnnNOW{} -> RfNormal i + i@AnnAMOUNT{} -> RfNormal i + i@AnnBALANCE{} -> RfNormal i + i@AnnVOTING_POWER{} -> RfNormal i + i@AnnTOTAL_VOTING_POWER{} -> RfNormal i + i@AnnCHECK_SIGNATURE{} -> RfNormal i + i@AnnSHA256{} -> RfNormal i + i@AnnSHA512{} -> RfNormal i + i@AnnBLAKE2B{} -> RfNormal i + i@AnnSHA3{} -> RfNormal i + i@AnnKECCAK{} -> RfNormal i + i@AnnHASH_KEY{} -> RfNormal i + i@AnnPAIRING_CHECK{} -> RfNormal i + i@AnnSOURCE{} -> RfNormal i + i@AnnSENDER{} -> RfNormal i + i@AnnADDRESS{} -> RfNormal i + i@AnnCHAIN_ID{} -> RfNormal i + i@AnnLEVEL{} -> RfNormal i + i@AnnSELF_ADDRESS{} -> RfNormal i NEVER -> RfAlwaysFails NEVER - i@TICKET -> RfNormal i - i@READ_TICKET -> RfNormal i - i@SPLIT_TICKET -> RfNormal i - i@JOIN_TICKETS -> RfNormal i - i@OPEN_CHEST -> RfNormal i - i@SAPLING_EMPTY_STATE{} -> RfNormal i - i@SAPLING_VERIFY_UPDATE{} -> RfNormal i + i@AnnTICKET{} -> RfNormal i + i@AnnREAD_TICKET{} -> RfNormal i + i@AnnSPLIT_TICKET{} -> RfNormal i + i@AnnJOIN_TICKETS{} -> RfNormal i + i@AnnOPEN_CHEST{} -> RfNormal i + i@AnnSAPLING_EMPTY_STATE{} -> RfNormal i + i@AnnSAPLING_VERIFY_UPDATE{} -> RfNormal i + i@AnnMIN_BLOCK_TIME{} -> RfNormal i -- | There are many ways to represent a sequence of more than 2 instructions. -- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@. @@ -538,57 +497,60 @@ -- | Traverse a value in depth-first order. dfsMapValue :: forall t. - (forall t'. Value t' -> Value t') + DfsSettings Identity -> Value t -> Value t -dfsMapValue step v = runIdentity $ dfsTraverseValue (pure . step) v +dfsMapValue settings v = runIdentity $ dfsTraverseValue settings v -- | Traverse a value in depth-first order. dfsTraverseValue :: forall t m. (Monad m) - => (forall t'. Value t' -> m (Value t')) + => DfsSettings m -> Value t -> m (Value t) -dfsTraverseValue step i = case i of +dfsTraverseValue settings@DfsSettings{..} i = case i of -- Atomic - VKey{} -> step i - VUnit -> step i - VSignature{} -> step i - VChainId{} -> step i - VOp{} -> step i - VContract{} -> step i - VTicket{} -> step i -- cannot appear as constant in a contract - VLam{} -> step i - VInt{} -> step i - VNat{} -> step i - VString{} -> step i - VBytes{} -> step i - VMutez{} -> step i - VBool{} -> step i - VKeyHash{} -> step i - VBls12381Fr{} -> step i - VBls12381G1{} -> step i - VBls12381G2{} -> step i - VTimestamp{} -> step i - VAddress{} -> step i - VChestKey{} -> step i - VChest{} -> step i + VKey{} -> dsValueStep i + VUnit -> dsValueStep i + VSignature{} -> dsValueStep i + VChainId{} -> dsValueStep i + VOp{} -> dsValueStep i + VContract{} -> dsValueStep i + VTicket{} -> dsValueStep i -- cannot appear as constant in a contract + VLam lambda -> do + v <- fmap (VLam . analyzeInstrFailure) $ dfsTraverseInstr settings (rfAnyInstr lambda) + dsValueStep v + VInt{} -> dsValueStep i + VNat{} -> dsValueStep i + VString{} -> dsValueStep i + VBytes{} -> dsValueStep i + VMutez{} -> dsValueStep i + VBool{} -> dsValueStep i + VKeyHash{} -> dsValueStep i + VBls12381Fr{} -> dsValueStep i + VBls12381G1{} -> dsValueStep i + VBls12381G2{} -> dsValueStep i + VTimestamp{} -> dsValueStep i + VAddress{} -> dsValueStep i + VChestKey{} -> dsValueStep i + VChest{} -> dsValueStep i + VTxRollupL2Address{} -> dsValueStep i -- Non-atomic VOption mVal -> case mVal of - Nothing -> step i + Nothing -> dsValueStep i Just val -> recursion1 (VOption . Just) val VList vals -> do - vs <- traverse (dfsTraverseValue step) vals - step $ VList vs + vs <- traverse (dfsTraverseValue settings) vals + dsValueStep $ VList vs VSet vals -> do - cs <- S.fromList <$> traverse (dfsTraverseValue step) (S.toList vals) - step (VSet cs) + cs <- S.fromList <$> traverse (dfsTraverseValue settings) (S.toList vals) + dsValueStep (VSet cs) VPair (v1, v2) -> do - v1' <- dfsTraverseValue step v1 - v2' <- dfsTraverseValue step v2 - step $ VPair (v1', v2') + v1' <- dfsTraverseValue settings v1 + v2' <- dfsTraverseValue settings v2 + dsValueStep $ VPair (v1', v2') VOr vEither -> case vEither of Left v -> recursion1 (VOr . Left) v Right v -> recursion1 (VOr . Right) v @@ -601,8 +563,8 @@ -> Value t' -> m (Value t) recursion1 constructor v = do - v' <- dfsTraverseValue step v - step $ constructor v' + v' <- dfsTraverseValue settings v + dsValueStep $ constructor v' mapRecursion :: forall k v. Comparable k @@ -612,16 +574,16 @@ mapRecursion constructor vmap = do vmap' <- M.fromList <$> forM (M.toList vmap) \(k, v) -> do - k' <- dfsTraverseValue step k - v' <- dfsTraverseValue step v + k' <- dfsTraverseValue settings k + v' <- dfsTraverseValue settings v pure (k', v') - step $ constructor vmap' + dsValueStep $ constructor vmap' -- | Specialization of 'dfsMapValue' for case when changing the value is -- not required. -dfsFoldMapValue :: - Monoid x => - (forall t'. Value t' -> x) +dfsFoldMapValue + :: Monoid x + => (forall t'. Value t' -> x) -> Value t -> x dfsFoldMapValue step v = @@ -637,12 +599,13 @@ dfsFoldMapValueM step v = do execWriterT $ dfsTraverseValue - (\val -> do - x <- lift $ step val - tell x - pure val - ) - v + (def{ dsValueStep = + (\val -> do + x <- lift $ step val + tell x + pure val + ) + }) v -- | If value is a string, return the stored string. isStringValue :: Value t -> Maybe MText @@ -724,7 +687,7 @@ VUnit -> ConstantStorage v VSignature{} -> ConstantStorage v VChainId{} -> ConstantStorage v - VLam{} -> ConstantStorage v + VLam{} -> ConstantStorage v VInt{} -> ConstantStorage v VNat{} -> ConstantStorage v VString{} -> ConstantStorage v @@ -739,12 +702,13 @@ VAddress{} -> ConstantStorage v VChest{} -> ConstantStorage v VChestKey{} -> ConstantStorage v + VTxRollupL2Address{} -> ConstantStorage v VTicket{} -> PartlyPushableStorage v Nop -- Non-atomic VOption (Nothing :: Maybe (Value tm)) -> case checkScope @(ConstantScope tm) of Right Dict -> ConstantStorage $ VOption Nothing - Left _ -> PushableValueStorage $ NONE + Left _ -> PushableValueStorage NONE VOption (Just jVal :: Maybe (Value tm)) -> case splitPushableStorage jVal of ConstantStorage _ -> ConstantStorage . VOption $ Just jVal PushableValueStorage instr -> PushableValueStorage $ instr `Seq` SOME @@ -859,121 +823,249 @@ isMichelsonInstr = \case WithLoc{} -> False Meta{} -> False - InstrWithNotes{} -> False - InstrWithVarNotes{} -> False - InstrWithVarAnns{} -> False FrameInstr{} -> False Seq{} -> True Nop -> False Ext{} -> False Nested{} -> True DocGroup{} -> False - Fn{} -> False AnnCAR{} -> True AnnCDR{} -> True DROP{} -> True DROPN{} -> True - DUP{} -> True - DUPN{} -> True + AnnDUP{} -> True + AnnDUPN{} -> True SWAP{} -> True DIG{} -> True DUG{} -> True - PUSH{} -> True - SOME{} -> True - NONE{} -> True - UNIT{} -> True + AnnPUSH{} -> True + AnnSOME{} -> True + AnnNONE{} -> True + AnnUNIT{} -> True IF_NONE{} -> True AnnPAIR{} -> True AnnUNPAIR{} -> True - PAIRN{} -> True + AnnPAIRN{} -> True UNPAIRN{} -> True AnnLEFT{} -> True AnnRIGHT{} -> True IF_LEFT{} -> True - NIL{} -> True - CONS{} -> True + AnnNIL{} -> True + AnnCONS{} -> True IF_CONS{} -> True - SIZE{} -> True - EMPTY_SET{} -> True - EMPTY_MAP{} -> True - EMPTY_BIG_MAP{} -> True - MAP{} -> True + AnnSIZE{} -> True + AnnEMPTY_SET{} -> True + AnnEMPTY_MAP{} -> True + AnnEMPTY_BIG_MAP{} -> True + AnnMAP{} -> True ITER{} -> True - MEM{} -> True - GET{} -> True - GETN{} -> True - UPDATE{} -> True - UPDATEN{} -> True - GET_AND_UPDATE{} -> True + AnnMEM{} -> True + AnnGET{} -> True + AnnGETN{} -> True + AnnUPDATE{} -> True + AnnUPDATEN{} -> True + AnnGET_AND_UPDATE{} -> True IF{} -> True LOOP{} -> True LOOP_LEFT{} -> True - LAMBDA{} -> True - EXEC{} -> True - APPLY{} -> True + AnnLAMBDA{} -> True + AnnEXEC{} -> True + AnnAPPLY{} -> True DIP{} -> True DIPN{} -> True FAILWITH{} -> True - CAST{} -> True - RENAME{} -> True - PACK{} -> True - UNPACK{} -> True - CONCAT{} -> True - CONCAT'{} -> True - SLICE{} -> True - ISNAT{} -> True - ADD{} -> True - SUB{} -> True - SUB_MUTEZ{} -> True - MUL{} -> True - EDIV{} -> True - ABS{} -> True - NEG{} -> True - LSL{} -> True - LSR{} -> True - OR{} -> True - AND{} -> True - XOR{} -> True - NOT{} -> True - COMPARE{} -> True - EQ{} -> True - NEQ{} -> True - LT{} -> True - GT{} -> True - LE{} -> True - GE{} -> True - INT{} -> True - VIEW{} -> True - SELF{} -> True - CONTRACT{} -> True - TRANSFER_TOKENS{} -> True - SET_DELEGATE{} -> True - CREATE_CONTRACT{} -> True - IMPLICIT_ACCOUNT{} -> True - NOW{} -> True - AMOUNT{} -> True - BALANCE{} -> True - VOTING_POWER{} -> True - TOTAL_VOTING_POWER{} -> True - CHECK_SIGNATURE{} -> True - SHA256{} -> True - SHA512{} -> True - BLAKE2B{} -> True - SHA3{} -> True - KECCAK{} -> True - HASH_KEY{} -> True - PAIRING_CHECK{} -> True - SOURCE{} -> True - SENDER{} -> True - ADDRESS{} -> True - CHAIN_ID{} -> True - LEVEL{} -> True - SELF_ADDRESS{} -> True + AnnCAST{} -> True + AnnRENAME{} -> True + AnnPACK{} -> True + AnnUNPACK{} -> True + AnnCONCAT{} -> True + AnnCONCAT'{} -> True + AnnSLICE{} -> True + AnnISNAT{} -> True + AnnADD{} -> True + AnnSUB{} -> True + AnnSUB_MUTEZ{} -> True + AnnMUL{} -> True + AnnEDIV{} -> True + AnnABS{} -> True + AnnNEG{} -> True + AnnLSL{} -> True + AnnLSR{} -> True + AnnOR{} -> True + AnnAND{} -> True + AnnXOR{} -> True + AnnNOT{} -> True + AnnCOMPARE{} -> True + AnnEQ{} -> True + AnnNEQ{} -> True + AnnLT{} -> True + AnnGT{} -> True + AnnLE{} -> True + AnnGE{} -> True + AnnINT{} -> True + AnnVIEW{} -> True + AnnSELF{} -> True + AnnCONTRACT{} -> True + AnnTRANSFER_TOKENS{} -> True + AnnSET_DELEGATE{} -> True + AnnCREATE_CONTRACT{} -> True + AnnIMPLICIT_ACCOUNT{} -> True + AnnNOW{} -> True + AnnAMOUNT{} -> True + AnnBALANCE{} -> True + AnnVOTING_POWER{} -> True + AnnTOTAL_VOTING_POWER{} -> True + AnnCHECK_SIGNATURE{} -> True + AnnSHA256{} -> True + AnnSHA512{} -> True + AnnBLAKE2B{} -> True + AnnSHA3{} -> True + AnnKECCAK{} -> True + AnnHASH_KEY{} -> True + AnnPAIRING_CHECK{} -> True + AnnSOURCE{} -> True + AnnSENDER{} -> True + AnnADDRESS{} -> True + AnnCHAIN_ID{} -> True + AnnLEVEL{} -> True + AnnSELF_ADDRESS{} -> True NEVER{} -> True - TICKET{} -> True - READ_TICKET{} -> True - SPLIT_TICKET{} -> True - JOIN_TICKETS{} -> True - OPEN_CHEST{} -> True - SAPLING_EMPTY_STATE{} -> True - SAPLING_VERIFY_UPDATE{} -> True + AnnTICKET{} -> True + AnnREAD_TICKET{} -> True + AnnSPLIT_TICKET{} -> True + AnnJOIN_TICKETS{} -> True + AnnOPEN_CHEST{} -> True + AnnSAPLING_EMPTY_STATE{} -> True + AnnSAPLING_VERIFY_UPDATE{} -> True + AnnMIN_BLOCK_TIME{} -> True + +-- | A wrapper around either typechecked 'Anns' or unchecked 'NonEmpty' of +-- 'AnyAnn'. Annotations on some instructions aren't typechecked, hence these +-- two constructors. +-- +-- Helper for 'instrAnns'. +data SomeAnns where + SomeAnns :: Anns xs -> SomeAnns + SomeUncheckedAnns :: NonEmpty AnyAnn -> SomeAnns + +-- | Get annotations from a typed 'Instr'. This doesn't recurse, use with +-- 'dfsFoldInstr' to collect all annotations in a tree/sequence. +instrAnns :: Instr i o -> Maybe SomeAnns +instrAnns = \case + WithLoc{} -> mzero + Meta{} -> mzero + FrameInstr{} -> mzero + Seq{} -> mzero + Nop -> mzero + Ext{} -> mzero + Nested{} -> mzero + DocGroup{} -> mzero + AnnCAR anns -> pure $ SomeAnns anns + AnnCDR anns -> pure $ SomeAnns anns + DROP -> mzero + DROPN _ -> mzero + AnnDUP anns -> pure $ SomeAnns anns + AnnDUPN anns _ -> pure $ SomeAnns anns + SWAP -> mzero + DIG _ -> mzero + DUG _ -> mzero + AnnPUSH anns _ -> pure $ SomeAnns anns + AnnSOME anns -> pure $ SomeAnns anns + AnnNONE anns -> pure $ SomeAnns anns + AnnUNIT anns -> pure $ SomeAnns anns + IF_NONE _ _ -> mzero + AnnPAIR anns -> pure $ SomeAnns anns + AnnUNPAIR anns -> pure $ SomeAnns anns + AnnPAIRN anns _ -> pure $ SomeAnns anns + UNPAIRN _ -> mzero + AnnLEFT anns -> pure $ SomeAnns anns + AnnRIGHT anns -> pure $ SomeAnns anns + IF_LEFT _ _ -> mzero + AnnNIL anns -> pure $ SomeAnns anns + AnnCONS anns -> pure $ SomeAnns anns + IF_CONS _ _ -> mzero + AnnSIZE anns -> pure $ SomeAnns anns + AnnEMPTY_SET anns -> pure $ SomeAnns anns + AnnEMPTY_MAP anns -> pure $ SomeAnns anns + AnnEMPTY_BIG_MAP anns -> pure $ SomeAnns anns + AnnMAP anns _ -> pure $ SomeAnns anns + ITER _ -> mzero + AnnMEM anns -> pure $ SomeAnns anns + AnnGET anns -> pure $ SomeAnns anns + AnnGETN anns _ -> pure $ SomeAnns anns + AnnUPDATE anns -> pure $ SomeAnns anns + AnnUPDATEN anns _ -> pure $ SomeAnns anns + AnnGET_AND_UPDATE anns -> pure $ SomeAnns anns + IF _ _ -> mzero + LOOP _ -> mzero + LOOP_LEFT _ -> mzero + AnnLAMBDA anns _ -> pure $ SomeAnns anns + AnnEXEC anns -> pure $ SomeAnns anns + AnnAPPLY anns -> pure $ SomeAnns anns + DIP _ -> mzero + DIPN _ _ -> mzero + FAILWITH -> mzero + AnnCAST anns -> pure $ SomeAnns anns + AnnRENAME anns -> pure $ SomeAnns anns + AnnPACK anns -> pure $ SomeAnns anns + AnnUNPACK anns -> pure $ SomeAnns anns + AnnCONCAT anns -> pure $ SomeAnns anns + AnnCONCAT' anns -> pure $ SomeAnns anns + AnnSLICE anns -> pure $ SomeAnns anns + AnnISNAT anns -> pure $ SomeAnns anns + AnnADD anns -> pure $ SomeAnns anns + AnnSUB anns -> pure $ SomeAnns anns + AnnSUB_MUTEZ anns -> pure $ SomeAnns anns + AnnMUL anns -> pure $ SomeAnns anns + AnnEDIV anns -> pure $ SomeAnns anns + AnnABS anns -> pure $ SomeAnns anns + AnnNEG anns -> pure $ SomeAnns anns + AnnLSL anns -> pure $ SomeAnns anns + AnnLSR anns -> pure $ SomeAnns anns + AnnOR anns -> pure $ SomeAnns anns + AnnAND anns -> pure $ SomeAnns anns + AnnXOR anns -> pure $ SomeAnns anns + AnnNOT anns -> pure $ SomeAnns anns + AnnCOMPARE anns -> pure $ SomeAnns anns + AnnEQ anns -> pure $ SomeAnns anns + AnnNEQ anns -> pure $ SomeAnns anns + AnnLT anns -> pure $ SomeAnns anns + AnnGT anns -> pure $ SomeAnns anns + AnnLE anns -> pure $ SomeAnns anns + AnnGE anns -> pure $ SomeAnns anns + AnnINT anns -> pure $ SomeAnns anns + AnnVIEW anns _ -> pure $ SomeAnns anns + AnnSELF anns _ -> pure $ SomeAnns anns + AnnCONTRACT anns _ -> pure $ SomeAnns anns + AnnTRANSFER_TOKENS anns -> pure $ SomeAnns anns + AnnSET_DELEGATE anns -> pure $ SomeAnns anns + AnnCREATE_CONTRACT anns _ -> pure $ SomeAnns anns + AnnIMPLICIT_ACCOUNT anns -> pure $ SomeAnns anns + AnnNOW anns -> pure $ SomeAnns anns + AnnAMOUNT anns -> pure $ SomeAnns anns + AnnBALANCE anns -> pure $ SomeAnns anns + AnnVOTING_POWER anns -> pure $ SomeAnns anns + AnnTOTAL_VOTING_POWER anns -> pure $ SomeAnns anns + AnnCHECK_SIGNATURE anns -> pure $ SomeAnns anns + AnnSHA256 anns -> pure $ SomeAnns anns + AnnSHA512 anns -> pure $ SomeAnns anns + AnnBLAKE2B anns -> pure $ SomeAnns anns + AnnSHA3 anns -> pure $ SomeAnns anns + AnnKECCAK anns -> pure $ SomeAnns anns + AnnHASH_KEY anns -> pure $ SomeAnns anns + AnnPAIRING_CHECK anns -> pure $ SomeAnns anns + AnnSOURCE anns -> pure $ SomeAnns anns + AnnSENDER anns -> pure $ SomeAnns anns + AnnADDRESS anns -> pure $ SomeAnns anns + AnnCHAIN_ID anns -> pure $ SomeAnns anns + AnnLEVEL anns -> pure $ SomeAnns anns + AnnSELF_ADDRESS anns -> pure $ SomeAnns anns + NEVER -> mzero + AnnTICKET anns -> pure $ SomeAnns anns + AnnREAD_TICKET anns -> pure $ SomeAnns anns + AnnSPLIT_TICKET anns -> pure $ SomeAnns anns + AnnJOIN_TICKETS anns -> pure $ SomeAnns anns + AnnOPEN_CHEST anns -> pure $ SomeAnns anns + AnnSAPLING_EMPTY_STATE anns _ -> pure $ SomeAnns anns + AnnSAPLING_VERIFY_UPDATE anns -> pure $ SomeAnns anns + AnnMIN_BLOCK_TIME anns -> SomeUncheckedAnns <$> nonEmpty anns diff --git a/src/Morley/Michelson/Typed/Value.hs b/src/Morley/Michelson/Typed/Value.hs --- a/src/Morley/Michelson/Typed/Value.hs +++ b/src/Morley/Michelson/Typed/Value.hs @@ -11,6 +11,7 @@ , TransferTokens (..) , Value' (..) , RemFail (..) + , mkVLam , rfMerge , rfAnyInstr , rfMapAnyInstr @@ -34,7 +35,7 @@ import Morley.Michelson.Typed.Entrypoints import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T (T(..)) -import Morley.Tezos.Address (Address, GlobalCounter(..)) +import Morley.Tezos.Address (Address, GlobalCounter(..), TxRollupL2Address) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, Chest, ChestKey, KeyHash, PublicKey, Signature) @@ -83,8 +84,6 @@ , ttCounter :: GlobalCounter } deriving stock (Show, Eq, Generic) -instance NFData (TransferTokens instr p) - instance Buildable (TransferTokens instr p) where build TransferTokens {..} = "Transfer " +| ttAmount |+ " tokens to " +| buildVContract ttContract |+ "" @@ -113,11 +112,6 @@ , ccCounter :: GlobalCounter } -instance - ( forall i o. NFData (instr i o) - ) => NFData (CreateContract instr cp st) where - rnf (CreateContract a b c d e f) = rnf (a, b, c, d, e, f) - instance Buildable (CreateContract instr cp st) where build CreateContract {..} = "Create a new contract with" <> @@ -187,6 +181,7 @@ tcompare (VChainId a) (VChainId b) = compare a b tcompare (VSignature a) (VSignature b) = compare a b tcompare (VKey a) (VKey b) = compare a b +tcompare (VTxRollupL2Address a) (VTxRollupL2Address b) = compare a b instance (Comparable t) => Ord (Value' instr t) where compare = tcompare @t @@ -231,13 +226,14 @@ (SingI l, SingI r) => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r) VLam - :: forall inp out instr. + :: forall inp out instr. ( SingI inp, SingI out , forall i o. Show (instr i o) , forall i o. Eq (instr i o) , forall i o. NFData (instr i o) ) - => RemFail instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out) + => RemFail instr (inp ': '[]) (out ': '[]) + -> Value' instr ('TLambda inp out) VMap :: forall k v instr. (SingI k, SingI v, Comparable k) @@ -262,6 +258,7 @@ VBls12381G2 :: Bls12381G2 -> Value' instr 'TBls12381G2 VChest :: Chest -> Value' instr 'TChest VChestKey :: ChestKey -> Value' instr 'TChestKey + VTxRollupL2Address :: TxRollupL2Address -> Value' instr 'TTxRollupL2Address deriving stock instance Show (Value' instr t) deriving stock instance Eq (Value' instr t) @@ -337,7 +334,15 @@ VAddress{} -> Dict VChest{} -> Dict VChestKey{} -> Dict + VTxRollupL2Address{} -> Dict +mkVLam :: (t ~ 'TLambda inp out, SingI inp, SingI out, + forall i o. Show (instr i o), + forall i o. Eq (instr i o), + forall i o. NFData (instr i o)) => + (IsNotInView => RemFail instr '[inp] '[out]) -> Value' instr t +mkVLam rf = VLam $ giveNotInView rf + -- | Provide a witness of that value's type is known. withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a withValueTypeSanity v a = case valueTypeSanity v of Dict -> a @@ -350,8 +355,17 @@ \\ valueTypeSanity v1 \\ valueTypeSanity v2 -$(deriveGADTNFData ''Operation') -$(deriveGADTNFData ''Value') +mconcat [[d| + instance + ( forall i o. NFData (instr i o) + ) => NFData (CreateContract instr cp st) where + rnf (CreateContract a b c d e f) = rnf (a, b, c, d, e, f) + |] + , deriveGADTNFData ''Operation' + , deriveGADTNFData ''Value' + ] + +instance NFData (TransferTokens instr p) type instance Index (Value' _ ('TList _)) = Int type instance IxValue (Value' instr ('TList elem)) = Value' instr elem diff --git a/src/Morley/Michelson/Typed/View.hs b/src/Morley/Michelson/Typed/View.hs --- a/src/Morley/Michelson/Typed/View.hs +++ b/src/Morley/Michelson/Typed/View.hs @@ -30,7 +30,6 @@ import Data.Default (Default(..)) import Data.Sequence qualified as Seq import Fmt (Buildable(..), (+|), (|+)) -import GHC.Exts (fromList) import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Scope diff --git a/src/Morley/Michelson/Untyped.hs b/src/Morley/Michelson/Untyped.hs --- a/src/Morley/Michelson/Untyped.hs +++ b/src/Morley/Michelson/Untyped.hs @@ -11,7 +11,6 @@ import Morley.Michelson.Untyped.Entrypoints as Exports import Morley.Michelson.Untyped.Ext as Exports import Morley.Michelson.Untyped.Instr as Exports -import Morley.Michelson.Untyped.OpSize as Exports import Morley.Michelson.Untyped.Type as Exports import Morley.Michelson.Untyped.Value as Exports import Morley.Michelson.Untyped.View as Exports diff --git a/src/Morley/Michelson/Untyped/Annotation.hs b/src/Morley/Michelson/Untyped/Annotation.hs --- a/src/Morley/Michelson/Untyped/Annotation.hs +++ b/src/Morley/Michelson/Untyped/Annotation.hs @@ -9,7 +9,6 @@ ( Annotation (..) , VarAnns (..) , pattern Annotation - , pattern WithAnn -- * Annotation Set , AnnotationSet(..) @@ -29,11 +28,11 @@ , TypeAnn , FieldAnn , VarAnn - , SomeAnn , RootAnn , TypeTag , FieldTag , VarTag + , AnyAnn(..) -- * Creation and conversions , noAnn @@ -46,12 +45,7 @@ , specialFieldAnn , isValidAnnStart , isValidAnnBodyChar - , orAnn - , unifyAnn - , unifyPairFieldAnn - , convergeVarAnns - , ifAnnUnified - , convAnn + , renderAnyAnns ) where import Data.Aeson.TH (deriveJSON) @@ -230,8 +224,6 @@ data FieldTag -- | Type-level tag for variable annotations data VarTag --- | Type-level tag for "some" annotations, i.e. those that are unknown at compile-time -data SomeTag -- | A convenience synonym for type t'Annotation' type TypeAnn = Annotation TypeTag @@ -239,8 +231,6 @@ type FieldAnn = Annotation FieldTag -- | A convenience synonym for variable t'Annotation' type VarAnn = Annotation VarTag --- | A convenience synonym for "some" t'Annotation', i.e. its type is unknown at compile-time -type SomeAnn = Annotation SomeTag -- | Field annotation for the entire parameter. type RootAnn = Annotation FieldTag @@ -252,9 +242,17 @@ instance KnownAnnTag TypeTag where annPrefix = ":" +-- | Datatype representing arbitrary annotation. +data AnyAnn = AnyAnnType TypeAnn | AnyAnnField FieldAnn | AnyAnnVar VarAnn + deriving stock (Eq, Show, Data, Generic) + deriving anyclass NFData + instance KnownAnnTag tag => RenderDoc (Annotation tag) where renderDoc _ = renderAnn +instance RenderDoc AnyAnn where + renderDoc _ = renderAnyAnn + instance KnownAnnTag tag => Buildable (Annotation tag) where build = buildRenderDoc @@ -272,6 +270,15 @@ renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc renderAnn (Annotation text) = textStrict $ annPrefix @tag <> text +renderAnyAnn :: AnyAnn -> Doc +renderAnyAnn = \case + AnyAnnType x -> renderAnn x + AnyAnnField x -> renderAnn x + AnyAnnVar x -> renderAnn x + +renderAnyAnns :: [AnyAnn] -> Doc +renderAnyAnns = hsep . map renderAnyAnn + -- | Renders a list of t'Annotation's, omitting unnecessary empty ones/'noAnn'. -- This is used (3 times) to render an 'AnnotationSet'. renderAnnGroup :: KnownAnnTag tag => [Annotation tag] -> Doc @@ -302,10 +309,10 @@ -- | -- >>> :t [annQ||] --- ... :: forall k (tag :: k). Annotation tag +-- ... :: forall {k} {tag :: k}. Annotation tag -- -- >>> :t [annQ|abc|] --- ... :: forall k (tag :: k). Annotation tag +-- ... :: forall {k} {tag :: k}. Annotation tag annQ :: TH.QuasiQuoter annQ = annQImpl Nothing @@ -392,60 +399,5 @@ instance Monoid VarAnn where mempty = noAnn --- | Returns the first annotation if it's not empty, or the second one otherwise. --- --- > "a" `orAnn` "b" == "a" --- > "a" `orAnn` "" == "a" --- > "" `orAnn` "b" == "b" --- > "" `orAnn` "" == "" -orAnn :: Annotation t -> Annotation t -> Annotation t -orAnn a b = bool a b (a == def) - --- | Given two type or field annotations, attempt to converge them by joining --- these annotations with the following rule: --- 1. If either annotation is empty, an empty annotation is returned; --- 2. If both annotations are equal, return this annotation; --- 3. Otherwise, returns 'Nothing'. --- --- This function is used primarily for type-checking and attempts to imitate the --- reference implementation's observed behavior with annotations. -unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag) -unifyAnn a@(Annotation ann1) (Annotation ann2) - | ann1 == "" || ann2 == "" = Just noAnn - | ann1 == ann2 = Just $ a - | otherwise = Nothing - --- | Given two field annotations where one of them is used in CAR or CDR, --- attempt to converge them by joining these annotations with the following rule: --- 1. If either annotation is empty, return the non-empty one (or empty if both are empty); --- 2. If both annotations are equal, return this annotation; --- 3. Otherwise, returns 'Nothing'. --- --- This function is used primarily for type-checking and attempts to imitate the --- reference implementation's observed behavior with field annotations when CAR --- and CDR are used with pairs. -unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn -unifyPairFieldAnn a1@(Annotation ann1) a2@(Annotation ann2) - | ann1 == "" || ann2 == "" = Just $ a1 `orAnn` a2 - | ann1 == ann2 = Just a1 - | otherwise = Nothing - --- | Keeps an annotation if and only if the two of them are equal and returns an --- empty annotation otherwise. -convergeVarAnns :: VarAnn -> VarAnn -> VarAnn -convergeVarAnns ann1 ann2 - | ann1 == ann2 = ann1 - | otherwise = noAnn - -ifAnnUnified :: Annotation tag -> Annotation tag -> Bool -ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2 - --- | Convert annotation from one type to another -convAnn :: Annotation tag1 -> Annotation tag2 -convAnn (Annotation a) = UnsafeAnnotation a - --- | Unidirectional pattern synonym matching only non-empty annotations -pattern WithAnn :: Annotation tag -> Annotation tag -pattern WithAnn ann <- ann@(Annotation (toString -> _:_)) - deriveJSON morleyAesonOptions ''Annotation +deriveJSON morleyAesonOptions ''AnyAnn diff --git a/src/Morley/Michelson/Untyped/Ext.hs b/src/Morley/Michelson/Untyped/Ext.hs --- a/src/Morley/Michelson/Untyped/Ext.hs +++ b/src/Morley/Michelson/Untyped/Ext.hs @@ -10,7 +10,6 @@ , Var (..) , TyVar (..) , StackTypePattern (..) - , StackFn (..) , varSet , stackTypePatternToList ) where @@ -22,7 +21,7 @@ import Fmt (Buildable(build), Builder, GenericBuildable(..), listF) import Text.PrettyPrint.Leijen.Text (textStrict) -import Morley.Michelson.Printer.Util (RenderDoc(..), renderOpsList) +import Morley.Michelson.Printer.Util (RenderDoc(..)) import Morley.Michelson.Untyped.Type import Morley.Util.Aeson @@ -38,27 +37,22 @@ -- (specifically @FN@ and @FN_END@). data ExtInstrAbstract op = STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern - | FN T.Text StackFn [op] -- ^ A typed stack function (push and pop a @TcExtFrame@) | UTEST_ASSERT (TestAssert op) -- ^ Copy the current stack and run an inline assertion on it | UPRINT PrintComment -- ^ Print a comment with optional embedded @StackRef@s | UCOMMENT Text -- ^ A comment in Michelson code deriving stock (Eq, Show, Data, Generic, Functor) -{-# DEPRECATED FN "Morley let macros are deprecated" #-} - deriving via GenericBuildable (ExtInstrAbstract op) instance Buildable op => Buildable (ExtInstrAbstract op) instance NFData op => NFData (ExtInstrAbstract op) -instance RenderDoc op => RenderDoc (ExtInstrAbstract op) where +instance RenderDoc (ExtInstrAbstract op) where renderDoc _ = \case - FN _ _ ops -> renderOpsList False ops UCOMMENT t -> textStrict ("/* " <> t <> " */") _ -> mempty isRenderable = \case - FN {} -> True UCOMMENT{} -> True _ -> False @@ -113,17 +107,6 @@ | fixed = map build types | otherwise = map build types ++ ["..."] --- | A stack function that expresses the type signature of a @LetMacro@ -data StackFn = StackFn - { sfnQuantifiedVars :: Maybe (Set Var) - , sfnInPattern :: StackTypePattern - , sfnOutPattern :: StackTypePattern - } - deriving stock (Eq, Show, Data, Generic) - deriving Buildable via GenericBuildable StackFn - -instance NFData StackFn - -- | Get the set of variables in a stack pattern varSet :: StackTypePattern -> Set Var varSet = \case @@ -158,11 +141,10 @@ -- Aeson instances ------------------------------------- -deriveJSON morleyAesonOptions ''ExtInstrAbstract -deriveJSON morleyAesonOptions ''PrintComment -deriveJSON morleyAesonOptions ''StackTypePattern deriveJSON morleyAesonOptions ''StackRef -deriveJSON morleyAesonOptions ''StackFn +deriveJSON morleyAesonOptions ''PrintComment +deriveJSON morleyAesonOptions ''TestAssert deriveJSON morleyAesonOptions ''Var deriveJSON morleyAesonOptions ''TyVar -deriveJSON morleyAesonOptions ''TestAssert +deriveJSON morleyAesonOptions ''StackTypePattern +deriveJSON morleyAesonOptions ''ExtInstrAbstract diff --git a/src/Morley/Michelson/Untyped/Instr.hs b/src/Morley/Michelson/Untyped/Instr.hs --- a/src/Morley/Michelson/Untyped/Instr.hs +++ b/src/Morley/Michelson/Untyped/Instr.hs @@ -19,11 +19,12 @@ import Text.PrettyPrint.Leijen.Text (Doc, align, braces, enclose, indent, integer, line, nest, space, text, (<$$>), (<+>)) -import Morley.Michelson.ErrorPos (InstrCallStack) +import Morley.Michelson.ErrorPos (ErrorSrcPos) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, renderOpsList, spaces) import Morley.Michelson.Untyped.Annotation - (Annotation, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, singleAnnSet) + (Annotation, AnyAnn, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, renderAnyAnns, + singleAnnSet) import Morley.Michelson.Untyped.Contract (Contract'(..)) import Morley.Michelson.Untyped.Ext (ExtInstrAbstract) import Morley.Michelson.Untyped.Type (Ty) @@ -40,7 +41,7 @@ data ExpandedOp = PrimEx ExpandedInstr | SeqEx [ExpandedOp] - | WithSrcEx InstrCallStack ExpandedOp + | WithSrcEx ErrorSrcPos ExpandedOp deriving stock (Show, Eq, Data, Generic) instance NFData ExpandedOp @@ -210,6 +211,7 @@ | OPEN_CHEST VarAnn | SAPLING_EMPTY_STATE VarAnn Natural | SAPLING_VERIFY_UPDATE VarAnn + | MIN_BLOCK_TIME [AnyAnn] deriving stock (Eq, Functor, Data, Generic, Show) instance NFData op => NFData (InstrAbstract op) @@ -340,6 +342,7 @@ OPEN_CHEST va -> "OPEN_CHEST" <+> renderAnnot va SAPLING_EMPTY_STATE va n -> "SAPLING_EMPTY_STATE" <+> renderAnnot va <+> (integer $ toInteger n) SAPLING_VERIFY_UPDATE va -> "SAPLING_VERIFY_UPDATE" <+> renderAnnot va + MIN_BLOCK_TIME anns -> "MIN_BLOCK_TIME" <+> renderAnyAnns anns where renderTy = renderDoc @Ty needsParens renderComp = renderDoc @Ty needsParens @@ -364,5 +367,5 @@ -- JSON serialization ---------------------------------------------------------------------------- -deriveJSON morleyAesonOptions ''ExpandedOp deriveJSON morleyAesonOptions ''InstrAbstract +deriveJSON morleyAesonOptions ''ExpandedOp diff --git a/src/Morley/Michelson/Untyped/OpSize.hs b/src/Morley/Michelson/Untyped/OpSize.hs deleted file mode 100644 --- a/src/Morley/Michelson/Untyped/OpSize.hs +++ /dev/null @@ -1,306 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Measuring operation size. --- --- When originating a contract or making a transfer, tezos node forms operation --- which is submitted over network. Size of this operation depends on content --- of originated contract or transfer parameter resp., and tezos has a hard --- limit on operation size thus it has to be accounted. --- --- Functions declared in this module allow assessing size of origination or --- transfer operation with up to constant precision because it yet accounts only --- for Michelson primitives participating in the operation. --- Other stuff which affects op size include parameters which user passes to --- origination or transfer themselves, for instance, amount of mutez carried --- to the contract. ATM we don't have necessary primitives in Haskell to be --- able to handle those parameters here, probably waiting for [TM-89]. --- Currently, we can assess overall transfer size only approximately, like --- in 'smallTransferOpSize'. -module Morley.Michelson.Untyped.OpSize - ( OpSize (..) - , opSizeHardLimit - , smallTransferOpSize - - , instrOpSize - , expandedInstrsOpSize - , valueOpSize - ) where - -import Fmt (Buildable(..)) -import Prelude hiding (Ordering(..)) -import Unsafe qualified (fromIntegral) - -import Morley.Michelson.Interpret.Utils -import Morley.Michelson.Untyped.Aliases -import Morley.Michelson.Untyped.Annotation -import Morley.Michelson.Untyped.Contract -import Morley.Michelson.Untyped.Instr -import Morley.Michelson.Untyped.Type -import Morley.Michelson.Untyped.Value -import Morley.Michelson.Untyped.View - --- | Operation size in bytes. --- --- We use newtype wrapper because there are different units of measure --- (another one is gas, and we don't want to confuse them). -newtype OpSize = OpSize { unOpSize :: Word } - deriving stock (Show, Eq, Ord) - -instance Buildable OpSize where - build = build . unOpSize - -instance Semigroup OpSize where - OpSize a <> OpSize b = OpSize (a + b) -instance Monoid OpSize where - mempty = OpSize 0 - --- | Maximal operation size allowed by Tezos production nodes. -opSizeHardLimit :: OpSize -opSizeHardLimit = OpSize 16384 - --- | Base cost of any transfer of 0 mutez with no extra parameters. --- (Add @valueOpSize \@ to it to get assessment of actual transfer op size) -smallTransferOpSize :: OpSize -smallTransferOpSize = OpSize 162 - -instrOpSize :: InstrAbstract ExpandedOp -> OpSize -instrOpSize = (OpSize 2 <>) . \case - EXT{} -> mempty - DROPN n -> stackDepthOpSize n - DROP -> mempty - DUP va -> annsOpSize va - DUPN va n -> annsOpSize va <> stackDepthOpSize n - SWAP -> mempty - DIG n -> stackDepthOpSize n - DUG n -> stackDepthOpSize n - PUSH va t v -> annsOpSize va <> typeOpSize t <> valueOpSize v - SOME ta va -> annsOpSize ta va - NONE ta va t -> annsOpSize ta va <> typeOpSize t - UNIT ta va -> annsOpSize ta va - IF_NONE l r -> ifOpSize l r - PAIR ta va fal far -> annsOpSize ta va fal far - UNPAIR va1 va2 fal far -> annsOpSize va1 va2 fal far - PAIRN va n -> annsOpSize va <> stackDepthOpSize n - UNPAIRN n -> stackDepthOpSize n - CAR va fa -> annsOpSize va fa - CDR va fa -> annsOpSize va fa - LEFT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t - RIGHT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t - IF_LEFT l r -> ifOpSize l r - NIL ta va t -> annsOpSize ta va <> typeOpSize t - CONS va -> annsOpSize va - IF_CONS l r -> ifOpSize l r - SIZE va -> annsOpSize va - EMPTY_SET ta va ct -> annsOpSize ta va <> innerOpSize ct - EMPTY_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t - EMPTY_BIG_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t - MAP va is -> annsOpSize va <> subcodeOpSize is - ITER is -> subcodeOpSize is - MEM va -> annsOpSize va - GET va -> annsOpSize va - GETN va n -> annsOpSize va <> stackDepthOpSize n - UPDATE va -> annsOpSize va - UPDATEN va n -> annsOpSize va <> stackDepthOpSize n - GET_AND_UPDATE va -> annsOpSize va - IF l r -> ifOpSize l r - LOOP is -> expandedInstrsOpSize is - LOOP_LEFT is -> expandedInstrsOpSize is - LAMBDA va ti to is -> - annsOpSize va <> typeOpSize ti <> typeOpSize to <> expandedInstrsOpSize is - EXEC va -> annsOpSize va - APPLY va -> annsOpSize va - DIP is -> subcodeOpSize is - DIPN n is -> stackDepthOpSize n <> subcodeOpSize is - FAILWITH -> mempty - CAST va t -> annsOpSize va <> typeOpSize t - RENAME va -> annsOpSize va - PACK va -> annsOpSize va - UNPACK ta va t -> annsOpSize ta va <> typeOpSize t - CONCAT va -> annsOpSize va - SLICE va -> annsOpSize va - ISNAT va -> annsOpSize va - ADD va -> annsOpSize va - SUB va -> annsOpSize va - SUB_MUTEZ va -> annsOpSize va - MUL va -> annsOpSize va - EDIV va -> annsOpSize va - ABS va -> annsOpSize va - NEG va -> annsOpSize va - LSL va -> annsOpSize va - LSR va -> annsOpSize va - OR va -> annsOpSize va - AND va -> annsOpSize va - XOR va -> annsOpSize va - NOT va -> annsOpSize va - COMPARE va -> annsOpSize va - EQ va -> annsOpSize va - NEQ va -> annsOpSize va - LT va -> annsOpSize va - LE va -> annsOpSize va - GT va -> annsOpSize va - GE va -> annsOpSize va - INT va -> annsOpSize va - VIEW va n t -> annsOpSize va <> viewNameSize n <> typeOpSize t - SELF va fa -> annsOpSize va fa - CONTRACT va fa t -> annsOpSize va fa <> typeOpSize t - TRANSFER_TOKENS va -> annsOpSize va - SET_DELEGATE va -> annsOpSize va - CREATE_CONTRACT va1 va2 c -> annsOpSize va1 va2 <> contractOpSize c - IMPLICIT_ACCOUNT va -> annsOpSize va - NOW va -> annsOpSize va - AMOUNT va -> annsOpSize va - BALANCE va -> annsOpSize va - VOTING_POWER va -> annsOpSize va - TOTAL_VOTING_POWER va -> annsOpSize va - CHECK_SIGNATURE va -> annsOpSize va - SHA256 va -> annsOpSize va - SHA512 va -> annsOpSize va - BLAKE2B va -> annsOpSize va - SHA3 va -> annsOpSize va - KECCAK va -> annsOpSize va - HASH_KEY va -> annsOpSize va - PAIRING_CHECK va -> annsOpSize va - SOURCE va -> annsOpSize va - SENDER va -> annsOpSize va - ADDRESS va -> annsOpSize va - CHAIN_ID va -> annsOpSize va - LEVEL va -> annsOpSize va - SELF_ADDRESS va -> annsOpSize va - NEVER -> mempty - TICKET va -> annsOpSize va - READ_TICKET va -> annsOpSize va - SPLIT_TICKET va -> annsOpSize va - JOIN_TICKETS va -> annsOpSize va - OPEN_CHEST va -> annsOpSize va - SAPLING_EMPTY_STATE va n -> annsOpSize va <> numOpSize n - SAPLING_VERIFY_UPDATE va -> annsOpSize va - where - subcodeOpSize is = expandedInstrOpSize (SeqEx is) - ifOpSize l r = expandedInstrOpSize (SeqEx l) <> expandedInstrOpSize (SeqEx r) - stackDepthOpSize n = OpSize 1 <> numOpSize n - -expandedInstrOpSize :: ExpandedOp -> OpSize -expandedInstrOpSize = \case - PrimEx i -> instrOpSize i - SeqEx is -> OpSize 5 <> expandedInstrsOpSize is - WithSrcEx _ i -> expandedInstrOpSize i - -expandedInstrsOpSize :: [ExpandedOp] -> OpSize -expandedInstrsOpSize = foldMap expandedInstrOpSize - -viewNameSize :: ViewName -> OpSize -viewNameSize = OpSize . Unsafe.fromIntegral @Int @Word . length . unViewName - -viewOpSize :: View -> OpSize -viewOpSize (View name param ret code) = mconcat - [ OpSize 2 - , viewNameSize name - , typeOpSize param - , typeOpSize ret - , expandedInstrsOpSize code - ] - -contractOpSize :: Contract -> OpSize -contractOpSize (Contract (ParameterType cp rootAnn) st is _ view_) = - OpSize 16 <> typeOpSize' [rootAnn] cp <> typeOpSize st <> expandedInstrsOpSize is - <> foldMap viewOpSize view_ - -numOpSize :: Integral i => i -> OpSize -numOpSize = OpSize . Unsafe.fromIntegral @Int @Word . length . encodeZarithNumber . fromIntegral - -valueOpSize :: Value -> OpSize -valueOpSize = (OpSize 1 <>) . \case - ValueInt i -> numOpSize i - ValueString s -> (seqOpSize <>) . OpSize . Unsafe.fromIntegral @Int @Word $ length s - ValueBytes (InternalByteString b) -> (seqOpSize <>) . OpSize . Unsafe.fromIntegral @Int @Word $ length b - ValueUnit -> baseOpSize - ValueTrue -> baseOpSize - ValueFalse -> baseOpSize - ValuePair l r -> baseOpSize <> valueOpSize l <> valueOpSize r - ValueLeft x -> baseOpSize <> valueOpSize x - ValueRight x -> baseOpSize <> valueOpSize x - ValueSome x -> baseOpSize <> valueOpSize x - ValueNone -> baseOpSize - ValueNil -> seqOpSize - ValueSeq l -> seqOpSize <> foldMap valueOpSize l - ValueMap m -> seqOpSize <> foldMap eltOpSize m - ValueLambda m -> seqOpSize <> foldMap expandedInstrOpSize m - where - baseOpSize = OpSize 1 - seqOpSize = OpSize 4 - eltOpSize (Elt k v) = OpSize 2 <> valueOpSize k <> valueOpSize v - -typeOpSize :: Ty -> OpSize -typeOpSize = typeOpSize' [] - -typeOpSize' :: [FieldAnn] -> Ty -> OpSize -typeOpSize' anns (Ty t ta) = - tOpSize t <> annsOpSize ta anns - -tOpSize :: T -> OpSize -tOpSize t = - OpSize 2 <> case t of - TKey -> mempty - TUnit -> mempty - TSignature -> mempty - TChainId -> mempty - TOption a -> typeOpSize a - TList a -> typeOpSize a - TSet a -> innerOpSize a - TOperation -> mempty - TTicket a -> typeOpSize a - TContract a -> typeOpSize a - -- Nested variable annotations don't use any extra operation size. - TPair al ar _ _ l r -> typeOpSize' [al] l <> typeOpSize' [ar] r - TOr al ar l r -> typeOpSize' [al] l <> typeOpSize' [ar] r - TLambda i o -> typeOpSize i <> typeOpSize o - TMap k v -> innerOpSize k <> typeOpSize v - TBigMap k v -> innerOpSize k <> typeOpSize v - TInt -> mempty - TNat -> mempty - TString -> mempty - TBytes -> mempty - TMutez -> mempty - TBool -> mempty - TKeyHash -> mempty - TBls12381Fr -> mempty - TBls12381G1 -> mempty - TBls12381G2 -> mempty - TTimestamp -> mempty - TAddress -> mempty - TChest -> mempty - TChestKey -> mempty - TNever -> mempty - TSaplingState _ -> mempty - TSaplingTransaction _ -> mempty - -innerOpSize :: Ty -> OpSize -innerOpSize (Ty _ a) = - (OpSize 2) <> annsOpSize a - --- | 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 and to be --- specified in order. See 'AnnotationSet' for details. -annsOpSize :: AnnsOpSizeVararg x => x -annsOpSize = annsOpSizeVararg emptyAnnSet - -class AnnsOpSizeVararg x where - annsOpSizeVararg :: AnnotationSet -> x - -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 :: AnnotationSet -> OpSize -annsOpSizeImpl annSet - | isNoAnnSet annSet = mempty - | otherwise = OpSize . Unsafe.fromIntegral @Int @Word $ 3 * (minAnnSetSize annSet + 1) diff --git a/src/Morley/Michelson/Untyped/Type.hs b/src/Morley/Michelson/Untyped/Type.hs --- a/src/Morley/Michelson/Untyped/Type.hs +++ b/src/Morley/Michelson/Untyped/Type.hs @@ -149,6 +149,7 @@ TNever -> wrapInParens pn $ "never" :| [annDoc] TSaplingState n -> addParens pn $ "sapling_state" <+> annDoc <+> (integer $ toInteger n) TSaplingTransaction n -> addParens pn $ "sapling_transaction" <+> annDoc <+> (integer $ toInteger n) + TTxRollupL2Address -> wrapInParens pn $ "tx_rollup_l2_address" :| [annDoc] TOption (Ty t1 ta1) -> addParens pn $ @@ -261,6 +262,7 @@ | TChestKey | TSaplingState Natural | TSaplingTransaction Natural + | TTxRollupL2Address | TNever deriving stock (Eq, Show, Data, Generic, Lift) @@ -399,6 +401,10 @@ -- TH derivations ---------------------------------------------------------------------------- -deriveJSON morleyAesonOptions ''Ty -deriveJSON morleyAesonOptions ''T +-- T and Ty are mutually recursive, so their derivation quotes need to be aware of each other +$(mconcat + [ deriveJSON morleyAesonOptions ''Ty + , deriveJSON morleyAesonOptions ''T + ]) + deriveJSON morleyAesonOptions ''ParameterType diff --git a/src/Morley/Michelson/Untyped/Value.hs b/src/Morley/Michelson/Untyped/Value.hs --- a/src/Morley/Michelson/Untyped/Value.hs +++ b/src/Morley/Michelson/Untyped/Value.hs @@ -153,5 +153,7 @@ Nothing -> fail "Invalid hex encoding" Just res -> pure (InternalByteString res) -deriveJSON morleyAesonOptions ''Value' -deriveJSON morleyAesonOptions ''Elt +$(mconcat + [ deriveJSON morleyAesonOptions ''Value' + , deriveJSON morleyAesonOptions ''Elt + ]) diff --git a/src/Morley/Tezos/Address.hs b/src/Morley/Tezos/Address.hs --- a/src/Morley/Tezos/Address.hs +++ b/src/Morley/Tezos/Address.hs @@ -6,8 +6,9 @@ {-# LANGUAGE DeriveLift #-} module Morley.Tezos.Address - ( ContractHash (..) + ( ContractHash , Address (..) + , TxRollupL2Address (..) , mkKeyAddress , detGenKeyAddress , isKeyAddress @@ -18,11 +19,9 @@ -- * Formatting , ParseAddressError (..) , ParseAddressRawError (..) - , ParseContractAddressError (..) , formatAddress , mformatAddress , parseAddressRaw - , parseContractHash , parseAddress , ta ) where @@ -38,7 +37,7 @@ import Language.Haskell.TH.Quote qualified as TH import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax qualified as TH -import Text.PrettyPrint.Leijen.Text (backslash, dquotes, int, parens, (<+>)) +import Text.PrettyPrint.Leijen.Text (backslash, dquotes, int, (<+>)) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable) import Morley.Michelson.Text @@ -46,34 +45,30 @@ import Morley.Util.CLI import Morley.Util.TypeLits --- | Hash of origination command for some contract. -newtype ContractHash = ContractHash ByteString - deriving stock (Show, Eq, Ord, Generic, Lift) - -instance NFData ContractHash - --- We know that the length must be 20. --- Currently it's hardcoded here, later we'll probably have a `Hash` type. --- | Length of contract hash in bytes (only hash itself, no tags, checksums --- or anything). -contractHashLengthBytes :: Integral n => n -contractHashLengthBytes = 20 - -- | Data type corresponding to address structure in Tezos. data Address = KeyAddress KeyHash - -- ^ @tz@ address which is a hash of a public key. + -- ^ @tz1@, @tz2@ or @tz3@ address which is a hash of a public key. | ContractAddress ContractHash -- ^ @KT@ address which corresponds to a callable contract. + | TransactionRollupAddress TxRollupHash + -- ^ @txr1@ address which corresponds to a transaction rollup. deriving stock (Show, Eq, Ord, Generic, Lift) instance NFData Address +-- | @tz4@ level-2 public key hash address, used with transaction rollups, corresponds +-- to @tx_rollup_l2_address@ Michelson type. +newtype TxRollupL2Address = TxRollupL2Address KeyHashL2 + deriving stock (Show, Eq, Ord, Generic, Lift) + deriving newtype NFData + -- | Returns @True@ if given address is implicit. isKeyAddress :: Address -> Bool isKeyAddress = \case KeyAddress _ -> True ContractAddress _ -> False + TransactionRollupAddress _ -> False -- | Smart constructor for 'KeyAddress'. mkKeyAddress :: PublicKey -> Address @@ -109,26 +104,18 @@ -- -- Use in tests **only**. mkContractHashHack :: ByteString -> ContractHash -mkContractHashHack = ContractHash . blake2b160 +mkContractHashHack = Hash HashContract . blake2b160 ---------------------------------------------------------------------------- -- Formatting/parsing ---------------------------------------------------------------------------- --- It's a magic constant used by Tezos to encode a contract address. --- It was deduced empirically. -contractAddressPrefix :: ByteString -contractAddressPrefix = "\2\90\121" - -formatContractHash :: ContractHash -> Text -formatContractHash (ContractHash bs) = - encodeBase58Check (contractAddressPrefix <> bs) - formatAddress :: Address -> Text formatAddress = \case - KeyAddress h -> formatKeyHash h - ContractAddress h -> formatContractHash h + KeyAddress h -> formatHash h + ContractAddress h -> formatHash h + TransactionRollupAddress h -> formatHash h mformatAddress :: Address -> MText mformatAddress = unsafe . mkMText . formatAddress @@ -136,14 +123,22 @@ instance Buildable Address where build = build . formatAddress +instance Buildable TxRollupL2Address where + build (TxRollupL2Address kh) = build $ formatHash kh + -- | Errors that can happen during address parsing. data ParseAddressError = ParseAddressWrongBase58Check -- ^ Address is not in Base58Check format. - | ParseAddressBothFailed CryptoParseError ParseContractAddressError - -- ^ Both address parsers failed with some error. + | ParseAddressAllFailed (NonEmpty CryptoParseError) + -- ^ All address parsers failed with some error. deriving stock (Show, Eq, Generic) +instance Semigroup ParseAddressError where + ParseAddressWrongBase58Check <> _ = ParseAddressWrongBase58Check + _ <> ParseAddressWrongBase58Check = ParseAddressWrongBase58Check + ParseAddressAllFailed xs <> ParseAddressAllFailed ys = ParseAddressAllFailed $ xs <> ys + instance NFData ParseAddressError instance Buildable ParseAddressError where @@ -153,24 +148,32 @@ renderDoc context = \case ParseAddressWrongBase58Check -> "Wrong base58check format" - ParseAddressBothFailed pkErr contractErr -> - mconcat - [ "Address is neither `KeyAddress` " - , parens $ renderDoc context pkErr - , ", nor `ContractAddress` " - , parens $ renderDoc context contractErr - ] + ParseAddressAllFailed pkErr -> + mconcat $ "Address failed to parse: " : intersperse ", " + (toList $ renderDoc context <$> pkErr) -- | Parse an address from its human-readable textual representation -- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or -- fail if it's invalid. parseAddress :: Text -> Either ParseAddressError Address parseAddress addressText = - case parseKeyHash addressText of - Left CryptoParseWrongBase58Check -> Left ParseAddressWrongBase58Check - Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $ - ContractAddress <$> parseContractHash addressText - Right keyHash -> Right (KeyAddress keyHash) + let implicit = tryParse KeyAddress parseHash handleCrypto + contract = tryParse ContractAddress parseHash handleCrypto + txr = tryParse TransactionRollupAddress parseHash handleCrypto + in implicit `merge` contract `merge` txr + where + handleCrypto = \case + CryptoParseWrongBase58Check -> ParseAddressWrongBase58Check + x -> ParseAddressAllFailed $ pure x + merge :: Semigroup a => Either a b -> Either a b -> Either a b + merge (Left xs) (Left ys) = Left $ xs <> ys + merge r@Right{} _ = r + merge _ r@Right{} = r + tryParse :: (t -> b) -> (Text -> Either t1 t) -> (t1 -> a) -> Either a b + tryParse ctor parser handler = + case parser addressText of + Left err -> Left $ handler err + Right res -> Right $ ctor res data ParseAddressRawError = ParseAddressRawWrongSize ByteString @@ -200,63 +203,30 @@ -- (e.g "01521139f84791537d54575df0c74a8084cc68861c00")) . Or fail otherwise -- if it's invalid. parseAddressRaw :: ByteString -> Either ParseAddressRawError Address -parseAddressRaw (BS.splitAt 2 -> (prefix, address)) = - case BS.take 1 prefix of - "\00" -> parseKeyAddressRaw (BS.tail prefix) address - "\01" -> parseContractAddressRaw prefix address - _ -> Left $ ParseAddressRawInvalidPrefix prefix +parseAddressRaw bytes = + case BS.splitAt 1 bytes of + -- key hash address + ("\00", rest) -> checkHashLength (BS.drop 1 rest) >> case BS.splitAt 1 rest of + ("\00", addr) -> pure $ KeyAddress $ Hash HashEd25519 addr + ("\01", addr) -> pure $ KeyAddress $ Hash HashSecp256k1 addr + ("\02", addr) -> pure $ KeyAddress $ Hash HashP256 addr + (x, _) -> Left $ ParseAddressRawInvalidPrefix x + (pfx, rest) -> do + (address, sep) <- maybe (Left $ ParseAddressRawWrongSize rest) pure $ BS.unsnoc rest + checkHashLength address + unless (sep == 0x00) $ + Left $ ParseAddressRawMalformedSeparator rest + case pfx of + -- contract address + "\01" -> pure $ ContractAddress $ Hash HashContract address + -- transaction rollup address + "\02" -> pure $ TransactionRollupAddress $ Hash HashTXR address + x -> Left $ ParseAddressRawInvalidPrefix x where - parseKeyAddressRaw keyPrefix keyAddress - | length keyAddress /= keyHashLengthBytes - = Left $ ParseAddressRawWrongSize keyAddress - | otherwise = do - matchedPrefix <- case keyPrefix of - "\00" -> Right KeyHashEd25519 - "\01" -> Right KeyHashSecp256k1 - "\02" -> Right KeyHashP256 - _ -> Left $ ParseAddressRawInvalidPrefix keyPrefix - pure $ KeyAddress (KeyHash matchedPrefix keyAddress) - - parseContractAddressRaw contractPrefix contractAddress - | length contractAddress /= contractHashLengthBytes - = Left $ ParseAddressRawWrongSize contractAddress - | BS.last contractAddress /= 0x00 - = Left $ ParseAddressRawMalformedSeparator contractAddress - | otherwise = do - let contractAddress' = BS.drop 1 contractPrefix <> BS.init contractAddress -- drop last "\00" of contract address - pure $ ContractAddress (ContractHash contractAddress') - -data ParseContractAddressError - = ParseContractAddressWrongBase58Check - | ParseContractAddressWrongSize ByteString - | ParseContractAddressWrongPrefix ByteString - deriving stock (Show, Eq, Generic) - -instance NFData ParseContractAddressError - -instance Buildable ParseContractAddressError where - build = buildRenderDoc - -instance RenderDoc ParseContractAddressError where - renderDoc _ = - \case - ParseContractAddressWrongBase58Check -> - "Wrong base58check format" - ParseContractAddressWrongSize bs -> - "Wrong size for a contract address:" <+> (renderAnyBuildable $ hexF bs) <+> - (parens $ int (length bs)) - ParseContractAddressWrongPrefix prefix -> - "Invalid prefix" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided" - -parseContractHash :: Text -> Either ParseContractAddressError ContractHash -parseContractHash text = - case decodeBase58CheckWithPrefix contractAddressPrefix text of - Left (B58CheckWithPrefixWrongPrefix prefix) -> - Left (ParseContractAddressWrongPrefix prefix) - Left B58CheckWithPrefixWrongEncoding -> - Left ParseContractAddressWrongBase58Check - Right bs | length bs == contractHashLengthBytes -> Right (ContractHash bs) - | otherwise -> Left $ ParseContractAddressWrongSize bs + checkHashLength addr + | length addr /= hashLengthBytes + = Left $ ParseAddressRawWrongSize addr + | otherwise = pass -- | QuasyQuoter for constructing Tezos addresses. -- diff --git a/src/Morley/Tezos/Address/Alias.hs b/src/Morley/Tezos/Address/Alias.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Tezos/Address/Alias.hs @@ -0,0 +1,46 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module Morley.Tezos.Address.Alias + ( AddressOrAlias(..) + , Alias(..) + ) + where + +import Data.Aeson (FromJSON, ToJSON) +import Fmt (Buildable(..)) +import Options.Applicative qualified as Opt + +import Morley.Tezos.Address (Address, parseAddress) +import Morley.Util.CLI (HasCLReader(..)) + +-- | @tezos-client@ can associate addresses with textual aliases. +-- This type denotes such an alias. +newtype Alias = Alias + { unAlias :: Text + -- ^ Extract 'Text' from 'Alias'. + } + deriving stock (Show, Eq, Ord) + deriving newtype (Buildable, ToJSON, FromJSON) + +-- | Representation of an address that @tezos-client@ uses. It can be +-- an address itself or a textual alias. +data AddressOrAlias + = AddressResolved Address + -- ^ Address itself, can be used as is. + | AddressAlias Alias + -- ^ Address alias, should be resolved by @tezos-client@. + deriving stock (Show, Eq, Ord) + +instance HasCLReader AddressOrAlias where + getReader = + Opt.str <&> \addrOrAlias -> + case parseAddress addrOrAlias of + Right addr -> AddressResolved addr + Left _ -> AddressAlias (Alias addrOrAlias) + getMetavar = "ADDRESS OR ALIAS" + +instance Buildable AddressOrAlias where + build = \case + AddressResolved addr -> build addr + AddressAlias alias -> build alias diff --git a/src/Morley/Tezos/Crypto.hs b/src/Morley/Tezos/Crypto.hs --- a/src/Morley/Tezos/Crypto.hs +++ b/src/Morley/Tezos/Crypto.hs @@ -11,16 +11,21 @@ -- If you need to sign something in production, use something else -- (e. g. `tezos-client`). -- --- Tezos supports 3 cryptographic curves that are denoted by the --- number after tz in the public key hash: tz1, tz2 or tz3. +-- Tezos supports multiple cryptographic curves that are denoted by the +-- number after tz in the public key hash: -- • tz1 — ed25519 -- • tz2 — secp256k1 -- • tz3 — P256 +-- • tz4 — BLS12381 -- We have Morley.Tezos.Crypto.Curve module for each of these curves. -- They expose very similar functionality and their main purpose is to hide -- implementation details for each curve as well as some other specifics (e. g. -- prefixes that are used for human-readable representation). -- +-- Additionally, Tezos uses b2b hashes to represent addresses of contracts +-- (using @KT1@ prefix) and transaction rollups (using @txr1@ prefix) -- these +-- hashes are also implemented here. +-- -- This module serves two purposes: -- 1. It is an umbrella module that re-exports some stuff from other modules. -- 2. Michelson types such as @key@ and @signature@ may store primitive of any @@ -38,8 +43,14 @@ PublicKey (..) , SecretKey (..) -- Currently we need to differentiate secret keys in morley-client , Signature (..) - , KeyHashTag (..) - , KeyHash (..) + , HashTag (..) + , KeyHashTag + , Hash (..) + , HashKind (..) + , KeyHash + , KeyHashL2 + , ContractHash + , TxRollupHash , BLS12381.Bls12381Fr , BLS12381.Bls12381G1 , BLS12381.Bls12381G2 @@ -65,11 +76,12 @@ , formatSignature , mformatSignature , parseSignature - , formatKeyHash - , mformatKeyHash - , parseKeyHash + , formatHash + , mformatHash + , parseHash , parseKeyHashRaw - , keyHashLengthBytes + , parseKeyHashL2Raw + , hashLengthBytes , formatSecretKey , parseSecretKey @@ -98,6 +110,7 @@ , decodeBase58CheckWithPrefix , keyDecoders , keyHashDecoders + , allHashTags ) where import Crypto.Random (MonadRandom) @@ -125,11 +138,40 @@ import Morley.Tezos.Crypto.Util import Morley.Util.Binary import Morley.Util.CLI +import Morley.Util.TH (deriveGADTNFData) ---------------------------------------------------------------------------- -- Types, instances, conversions ---------------------------------------------------------------------------- +-- | A kind of a hash: it may be a public key hash for @tz1@, @tz2@ and @tz3@ +-- addresses, it may be a level-2 public key hash for @tz4@ addresses, it may be +-- a contract hash for contract addresses, or it may be a transaction rollup +-- hash for @txr1@ addresses. +data HashKind + = HashKindPublicKey + | HashKindL2PublicKey + | HashKindContract + | HashKindTxRollup + +-- | What specific type of hash is used for the 'Hash'. +data HashTag (kind :: HashKind) where + HashEd25519 :: HashTag 'HashKindPublicKey + HashSecp256k1 :: HashTag 'HashKindPublicKey + HashP256 :: HashTag 'HashKindPublicKey + HashContract :: HashTag 'HashKindContract + HashBLS :: HashTag 'HashKindL2PublicKey + HashTXR :: HashTag 'HashKindTxRollup + +deriving stock instance Show (HashTag kind) +deriving stock instance Eq (HashTag kind) +deriving stock instance Ord (HashTag kind) +deriving stock instance Lift (HashTag kind) + +-- NB: these definitions are here and not below because TH scoping rules are annoying + +deriveGADTNFData ''HashTag + -- | Public cryptographic key used by Tezos. -- There are three cryptographic curves each represented by its own constructor. data PublicKey @@ -420,102 +462,147 @@ Aeson.withText "Signature" $ either (fail . pretty) pure . parseSignature -instance ToJSON KeyHash where - toJSON = Aeson.String . formatKeyHash - toEncoding = Aeson.text . formatKeyHash +instance ToJSON (Hash kind) where + toJSON = Aeson.String . formatHash + toEncoding = Aeson.text . formatHash -instance ToJSONKey KeyHash where - toJSONKey = AesonTypes.toJSONKeyText formatKeyHash +instance ToJSONKey (Hash kind) where + toJSONKey = AesonTypes.toJSONKeyText formatHash -instance FromJSON KeyHash where +instance AllTags kind => FromJSON (Hash kind) where parseJSON = - Aeson.withText "KeyHash" $ - either (fail . pretty) pure . parseKeyHash + Aeson.withText "Hash" $ + either (fail . pretty) pure . parseHash -instance FromJSONKey KeyHash where +instance AllTags kind => FromJSONKey (Hash kind) where fromJSONKey = AesonTypes.FromJSONKeyTextParser $ - either (fail . pretty) pure . parseKeyHash + either (fail . pretty) pure . parseHash ---------------------------------------------------------------------------- --- KeyHash +-- Hash ---------------------------------------------------------------------------- --- | Which curve was used for the hashed public key inside 'KeyHash'. -data KeyHashTag - = KeyHashEd25519 - | KeyHashSecp256k1 - | KeyHashP256 - deriving stock (Show, Eq, Ord, Bounded, Enum, Generic, Lift) +-- | A compatibility synonym for a public key hash tag. +type KeyHashTag = HashTag 'HashKindPublicKey -instance NFData KeyHashTag +-- | List all 'HashTag's for a given 'HashKind'. +class AllTags kind where + allHashTags :: NonEmpty (HashTag kind) --- | Blake2b_160 hash of a public key. -data KeyHash = KeyHash - { khTag :: KeyHashTag - -- ^ We store which curve was used because it affects formatting. - , khBytes :: ByteString +instance AllTags 'HashKindPublicKey where + allHashTags = HashEd25519 :| [HashSecp256k1, HashP256] + +instance AllTags 'HashKindContract where + allHashTags = pure HashContract + +instance AllTags 'HashKindL2PublicKey where + allHashTags = pure HashBLS + +instance AllTags 'HashKindTxRollup where + allHashTags = pure HashTXR + +-- | Blake2b_160 hash of something. +data Hash (kind :: HashKind) = Hash + { hTag :: HashTag kind + -- ^ Which kind of hash. + , hBytes :: ByteString -- ^ Hash itself. } deriving stock (Show, Eq, Ord, Generic, Lift) -instance NFData KeyHash +instance NFData (Hash kind) --- | Length of key hash in bytes (only hash itself, no tags, checksums +-- | Convenience synonym for an on-chain public key hash. +type KeyHash = Hash 'HashKindPublicKey + +-- | Convenience synonym for a level-2 public key hash. +type KeyHashL2 = Hash 'HashKindL2PublicKey + +-- | Convenience synonym for a contract hash. +type ContractHash = Hash 'HashKindContract + +-- | Convenience synonym for a transaction rollup hash. +type TxRollupHash = Hash 'HashKindTxRollup + +-- | Length of a hash in bytes (only the hash itself, no tags, checksums -- or anything). -keyHashLengthBytes :: Integral n => n -keyHashLengthBytes = 20 +hashLengthBytes :: Integral n => n +hashLengthBytes = 20 -- | Compute the b58check of a public key hash. hashKey :: PublicKey -> KeyHash hashKey = \case PublicKeyEd25519 pk -> - KeyHash KeyHashEd25519 (blake2b160 $ Ed25519.publicKeyToBytes pk) + Hash HashEd25519 (blake2b160 $ Ed25519.publicKeyToBytes pk) PublicKeySecp256k1 pk -> - KeyHash KeyHashSecp256k1 (blake2b160 $ Secp256k1.publicKeyToBytes pk) + Hash HashSecp256k1 (blake2b160 $ Secp256k1.publicKeyToBytes pk) PublicKeyP256 pk -> - KeyHash KeyHashP256 (blake2b160 $ P256.publicKeyToBytes pk) + Hash HashP256 (blake2b160 $ P256.publicKeyToBytes pk) -formatKeyHash :: KeyHash -> Text -formatKeyHash (KeyHash tag bytes) = formatImpl (keyHashTagBytes tag) bytes +formatHash :: (Hash kind) -> Text +formatHash (Hash tag bytes) = formatImpl (hashTagBytes tag) bytes -mformatKeyHash :: KeyHash -> MText -mformatKeyHash = unsafe . mkMText . formatKeyHash +mformatHash :: (Hash kind) -> MText +mformatHash = unsafe . mkMText . formatHash -instance Buildable KeyHash where - build = build . formatKeyHash +instance Buildable (Hash kind) where + build = build . formatHash -parseKeyHash :: Text -> Either CryptoParseError KeyHash -parseKeyHash txt = +parseHash + :: AllTags kind + => Text + -> Either CryptoParseError (Hash kind) +parseHash txt = let mkKeyHash tag bs = - KeyHash tag bs <$ - unless (length bs == keyHashLengthBytes) + Hash tag bs <$ + unless (length bs == hashLengthBytes) (Left $ CryptoParseUnexpectedLength "KeyHash" (length bs)) - parse :: KeyHashTag -> Either CryptoParseError KeyHash - parse tag = mkKeyHash tag =<< parseImpl (keyHashTagBytes tag) pure txt + parse :: HashTag kind -> Either CryptoParseError (Hash kind) + parse tag = mkKeyHash tag =<< parseImpl (hashTagBytes tag) pure txt - in firstRight $ map parse $ minBound :| [succ minBound ..] + in firstRight $ map parse allHashTags parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash parseKeyHashRaw ba = - if (BS.length ba - 1 == keyHashLengthBytes) then + if (BS.length ba - 1 == hashLengthBytes) then case Get.runGetOrFail (decodeWithTag "key_hash" keyHashDecoders) (LBS.fromStrict ba) of Right (_, _, result) -> Right result Left (_, _, err) -> Left $ CryptoParseBinaryError (toText err) else Left $ CryptoParseUnexpectedLength "key_hash" (BS.length ba) -keyHashTagBytes :: KeyHashTag -> ByteString -keyHashTagBytes = +parseKeyHashL2Raw :: ByteString -> Either CryptoParseError KeyHashL2 +parseKeyHashL2Raw ba = + if (BS.length ba == hashLengthBytes) then + case Get.runGetOrFail (Hash HashBLS <$> getByteStringCopy hashLengthBytes) + (LBS.fromStrict ba) of + Right (_, _, result) -> Right result + Left (_, _, err) -> Left $ CryptoParseBinaryError (toText err) + else + Left $ CryptoParseUnexpectedLength "tx_rollup_l2_address" (BS.length ba) + +-- | Magic constants used by Tezos to encode hashes with proper prefixes. +hashTagBytes :: HashTag kind -> ByteString +hashTagBytes = \case - KeyHashEd25519 -> "\006\161\159" - KeyHashSecp256k1 -> "\006\161\161" - KeyHashP256 -> "\006\161\164" + HashEd25519 -> "\006\161\159" + -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L379 + HashSecp256k1 -> "\006\161\161" + -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L381 + HashP256 -> "\006\161\164" + -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L383 + HashContract -> "\2\90\121" + -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_alpha/lib_protocol/contract_hash.ml#L27 + HashBLS -> "\006\161\166" + -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L43 + HashTXR -> "\001\128\120\031" + -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L35 -instance HasCLReader KeyHash where - getReader = eitherReader (first pretty . parseKeyHash . toText) +instance AllTags kind => HasCLReader (Hash kind) where + getReader = eitherReader (first pretty . parseHash . toText) getMetavar = "KEY_HASH" keyDecoders :: [TaggedDecoder PublicKey] @@ -530,9 +617,9 @@ keyHashDecoders :: [TaggedDecoder KeyHash] keyHashDecoders = - [ 0x00 #: KeyHash KeyHashEd25519 <$> getPayload - , 0x01 #: KeyHash KeyHashSecp256k1 <$> getPayload - , 0x02 #: KeyHash KeyHashP256 <$> getPayload + [ 0x00 #: Hash HashEd25519 <$> getPayload + , 0x01 #: Hash HashSecp256k1 <$> getPayload + , 0x02 #: Hash HashP256 <$> getPayload ] where - getPayload = getByteStringCopy keyHashLengthBytes + getPayload = getByteStringCopy hashLengthBytes diff --git a/src/Morley/Util/CustomGeneric.hs b/src/Morley/Util/CustomGeneric.hs --- a/src/Morley/Util/CustomGeneric.hs +++ b/src/Morley/Util/CustomGeneric.hs @@ -34,6 +34,8 @@ , deriveFullType , customGeneric' , makeRightBalDepths + , mangleGenericStrategyFields + , mangleGenericStrategyConstructors ) where import Prelude hiding (Type) @@ -47,6 +49,8 @@ import Morley.Util.TH (lookupTypeNameOrFail) import Unsafe qualified (fromIntegral) +{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-} + ---------------------------------------------------------------------------- -- Simple type synonyms ---------------------------------------------------------------------------- @@ -410,7 +414,7 @@ -- | Reifies info from a type name (given as a 'String'). -- The lookup happens from the current splice's scope (see 'lookupTypeName') and -- the only accepted result is a "plain" data type (no GADTs). -reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con]) +reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr ()], [Con]) reifyDataType typeName = do typeInfo <- reify typeName case typeInfo of @@ -424,16 +428,16 @@ -- | Derives, as well as possible, a type definition from its name, its kind -- (where known) and its variables. -deriveFullType :: Name -> Maybe Kind -> [TyVarBndr] -> TypeQ +deriveFullType :: Name -> Maybe Kind -> [TyVarBndr flag] -> TypeQ deriveFullType tName mKind = addTypeSig . foldl appT (conT tName) . makeVarsType where addTypeSig :: TypeQ -> TypeQ addTypeSig = flip sigT $ fromMaybe StarT mKind - makeVarsType :: [TyVarBndr] -> [TypeQ] + makeVarsType :: [TyVarBndr flag] -> [TypeQ] makeVarsType = map $ \case - PlainTV vName -> varT vName - KindedTV vName kind -> sigT (varT vName) kind + PlainTV vName _ -> varT vName + KindedTV vName _ kind -> sigT (varT vName) kind -- | Extract the info for each of the given constructors. cstrNames :: [Con] -> Q [CstrNames] @@ -603,3 +607,16 @@ -- | Original name of a constructor or field. origName :: Name -> Text origName = toText . nameBase + + +-- | Patch a given strategy by applying a transformation function to constructor names +-- before passing them through ordering function. +mangleGenericStrategyConstructors :: (Text -> Text) -> GenericStrategy -> GenericStrategy +mangleGenericStrategyConstructors modCstr gs = gs + { gsReorderCstrsOn = gsReorderCstrsOn gs . fmap (first modCstr) } + +-- | Patch a given strategy by applying a transformation function to field names +-- before passing them through ordering function. +mangleGenericStrategyFields :: (Text -> Text) -> GenericStrategy -> GenericStrategy +mangleGenericStrategyFields modField gs = gs + { gsReorderFieldsOn = gsReorderFieldsOn gs . second (fmap (first modField)) } diff --git a/src/Morley/Util/Fcf.hs b/src/Morley/Util/Fcf.hs --- a/src/Morley/Util/Fcf.hs +++ b/src/Morley/Util/Fcf.hs @@ -9,7 +9,7 @@ , Eval ) where -import Data.Singletons.Prelude.Eq (DefaultEq) +import Data.Eq.Singletons (DefaultEq) import Fcf (type Eval, type Exp, type LiftM2) data Over2 :: (a -> b -> Exp r) -> (x -> Exp a) -> (x -> Exp b) -> x -> Exp r @@ -20,7 +20,7 @@ type instance Eval ('Just x <|> _) = 'Just x -- | Similar to 'Fcf.TyEq', but compares types via @DefaultEq@ used in singletons --- comparisons (see "Data.Singletons.Prelude.Eq" module). +-- comparisons (see "Data.Eq.Singletons" module). data TyEqSing :: a -> b -> Exp Bool type instance Eval (TyEqSing a b) = DefaultEq a b diff --git a/src/Morley/Util/Named.hs b/src/Morley/Util/Named.hs --- a/src/Morley/Util/Named.hs +++ b/src/Morley/Util/Named.hs @@ -13,7 +13,7 @@ , ApplyNamedFunctor , NamedInner , KnownNamedFunctor (..) - , NamedF (.., (:!), (:?), N, M, SomeArg, NoArg) + , NamedF (.., (:!), (:?)) , Name , arg , argF @@ -61,31 +61,6 @@ pattern (:?) n v <- ((Name,) -> (n, ArgF v)) where (:?) _ v = ArgF v {-# COMPLETE (:?) #-} - --- | Convenience pattern synonym, use this instead of 'Named.arg' with @ViewPatterns@ --- when the @name@ can be inferred. -pattern N :: a -> NamedF Identity a name -pattern N a = ArgF (Identity a) -{-# COMPLETE N #-} -{-# DEPRECATED N "Please use view patterns with 'arg' instead." #-} - --- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@ --- when the @name@ can be inferred. Matches only on @Just@ values -pattern SomeArg :: a -> NamedF Maybe a name -pattern SomeArg a = ArgF (Just a) - --- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@ --- when the @name@ can be inferred. Matches only on @Nothing@ values -pattern NoArg :: NamedF Maybe a name -pattern NoArg = ArgF Nothing -{-# COMPLETE NoArg, SomeArg #-} - --- | Convenience pattern synonym for @NamedF Maybe name a@, use this instead of 'Named.argF' with @ViewPatterns@ --- when the @name@ can be inferred. -pattern M :: Maybe a -> NamedF Maybe a name -pattern M a = ArgF a -{-# COMPLETE M #-} -{-# DEPRECATED M, SomeArg, NoArg "Please use view patterns with 'argF' instead." #-} -- | Special version of 'Morley.Util.Named.(:!)' for monadic operations (<:!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name) diff --git a/src/Morley/Util/Positive.hs b/src/Morley/Util/Positive.hs deleted file mode 100644 --- a/src/Morley/Util/Positive.hs +++ /dev/null @@ -1,40 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Definition of 'Positive' type and related utilities. -module Morley.Util.Positive - ( Positive (..) - , mkPositive - , lengthNE - , replicateNE - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Data (Data) -import Fmt (Buildable, pretty) -import Unsafe qualified (fromIntegral) - -import Morley.Util.Instances () - --- | Integer values starting from 1. --- --- 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 = UnsafePositive { unPositive :: Natural } - deriving stock (Eq, Ord, Data, Generic) - deriving newtype (Show, Buildable, ToJSON, FromJSON) - -instance NFData Positive - -mkPositive :: forall i. (Integral i, Buildable i) => i -> Either Text Positive -mkPositive a - | a > 0 = Right $ UnsafePositive (Unsafe.fromIntegral @i @Natural a) - | otherwise = Left $ "Number is not positive: " <> pretty a - --- | Count length of non-empty list. -lengthNE :: NonEmpty a -> Positive -lengthNE = UnsafePositive . Unsafe.fromIntegral @Int @Natural . length - --- | Produce a non empty list consisting of the given value. -replicateNE :: Positive -> a -> NonEmpty a -replicateNE (UnsafePositive i) a = a :| replicate (Unsafe.fromIntegral @Natural @Int i - 1) a diff --git a/src/Morley/Util/SizedList.hs b/src/Morley/Util/SizedList.hs --- a/src/Morley/Util/SizedList.hs +++ b/src/Morley/Util/SizedList.hs @@ -19,9 +19,9 @@ , tail -- * Construction - , fromList , withNonEmpty , withList + , fromList , fromListMaybe , fromListMaybe' , unsafeFromList @@ -53,7 +53,9 @@ , splitAt ) where -import Prelude hiding (drop, head, replicate, reverse, splitAt, tail, take, unzip, zip, zipWith) +import Prelude hiding + (drop, fromList, head, replicate, reverse, splitAt, tail, take, unzip, zip, zipWith) +import Prelude qualified (fromList) import Data.List qualified as List import Data.Singletons (SingI(..)) @@ -65,7 +67,7 @@ -- $setup -- --- >>> import Prelude hiding (drop, head, replicate, reverse, splitAt, tail, take, unzip, zip, zipWith) +-- >>> import Prelude hiding (drop, fromList, head, replicate, reverse, splitAt, tail, take, unzip, zip, zipWith) -- >>> import Morley.Util.Peano -- | The primary fixed-size list type. Parametrized by a type-level 'Nat' as length and type @@ -137,7 +139,7 @@ -- -- Unlike regular sized list, @SomeSizedList@ is a 'Semigroup' and a 'Monoid': -- --- >>> fromList "ab" <> fromList "de" <> mempty +-- >>> fromList "ab" <> fromList "de" <> mempty :: SomeSizedList Char -- SomeSizedList (SS (SS (SS (SS SZ)))) ('a' :< 'b' :< 'd' :< 'e' :< Nil) data SomeSizedList a where SomeSizedList :: SingNat n -> SizedList' n a -> SomeSizedList a @@ -162,6 +164,17 @@ type OneItem (SizedList' n a) = a one = singleton +instance FromList (SomeSizedList a) where + type ListElement (SomeSizedList a) = a + + fromList = fromList + +-- A type-specific `fromList` for use in qualified imports +fromList :: forall a. [a] -> SomeSizedList a +fromList [] = SomeSizedList SZ Nil +fromList (x:xs) = case fromList xs of + SomeSizedList n xs' -> SomeSizedList (SS n) (x :< xs') + -- | Try to make a fixed-size list from a regular list, given a 'Nat'. Returns 'Nothing' if -- the regular list has incorrect length. -- @@ -178,12 +191,6 @@ fromListMaybe' SZ [] = Just Nil fromListMaybe' (SS n) (x:xs) = (x :<) <$> fromListMaybe' n xs fromListMaybe' _ _ = Nothing - --- | Construct 'SomeSizedList' from a regular list -fromList :: forall a. [a] -> SomeSizedList a -fromList [] = SomeSizedList SZ Nil -fromList (x:xs) = case fromList xs of - SomeSizedList n xs' -> SomeSizedList (SS n) (x :< xs') -- | Run some computation with a 'NonEmpty' list converted to 'SizedList'. Similar -- to pattern-matching on 'SomeSizedList', but asserts on the type level that list is diff --git a/src/Morley/Util/TH.hs b/src/Morley/Util/TH.hs --- a/src/Morley/Util/TH.hs +++ b/src/Morley/Util/TH.hs @@ -8,8 +8,10 @@ , addTypeVariables ) where -import Language.Haskell.TH as TH +import Language.Haskell.TH +{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-} + -- | 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] @@ -18,8 +20,8 @@ unit <- [| () |] (TyConI (DataD _ dataName vars _ cons _)) <- reify name let - getNameFromVar (PlainTV n) = n - getNameFromVar (KindedTV n _) = n + getNameFromVar (PlainTV n _) = n + getNameFromVar (KindedTV n _ _) = n -- Unfolds multiple constructors of form "A, B, C :: A -> Stuff" -- into a list of tuples of constructor names and their data @@ -65,13 +67,13 @@ -- | Accepts a type constructor and fills it with variables until -- getting a type of kind @*@. -addTypeVariables :: Name -> Q TH.Type +addTypeVariables :: Name -> TypeQ addTypeVariables tyCtor = do tyVarBindrs <- reify tyCtor >>= \case TyConI (DataD _ _ tyVarBindrs _ _ _) -> pure tyVarBindrs TyConI (NewtypeD _ _ tyVarBindrs _ _ _) -> pure tyVarBindrs _ -> fail "Expected a plain datatype" let vars = tyVarBindrs <&> \case - PlainTV vName -> vName - KindedTV vName _ -> vName + PlainTV vName _ -> vName + KindedTV vName _ _ -> vName return $ foldl (\acc var -> acc `AppT` VarT var) (ConT tyCtor) vars diff --git a/src/Morley/Util/Type.hs b/src/Morley/Util/Type.hs --- a/src/Morley/Util/Type.hs +++ b/src/Morley/Util/Type.hs @@ -5,7 +5,8 @@ -- | General type utilities. module Morley.Util.Type - ( type (==) + ( IsEq + , type (==) , If , type (++) , IsElem @@ -41,7 +42,6 @@ import Data.Constraint (Dict(..), (:-)(..), (\\)) import Data.Singletons (SingI(sing)) -import Data.Singletons.Prelude.List (SList(..)) import Data.Type.Bool (If, Not, type (&&)) import Data.Type.Equality (type (==)) import Data.Vinyl.Core (Rec(..)) @@ -49,7 +49,12 @@ import Data.Vinyl.Recursive (recordToList, rmap) import Data.Vinyl.TypeLevel (type (++)) import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) +import Prelude.Singletons (SList(..)) import Unsafe.Coerce (unsafeCoerce) + +-- | Equality constraint in form of a typeclass. +class a ~ b => IsEq a b +instance a ~ b => IsEq a b type family IsElem (a :: k) (l :: [k]) :: Bool where IsElem _ '[] = 'False