diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,6 +1,123 @@
+1.19.2
+======
+* [!1365](https://gitlab.com/morley-framework/morley/-/merge_requests/1365)
+ Split optimizer module
+ + More utilities for writing rules are now exported from
+ `Morley.Michelson.Optimizer.Utils`;
+ + Fixed a bug with missing pattern in the `Buildable OptimizationStage`
+ instance.
+* [!1352](https://gitlab.com/morley-framework/morley/-/merge_requests/1352)
+ Clean-up Buildable ExecutorOp implementation
+ + Add `Buildable` instances for `OriginationOperation`, `TransferOperation`,
+ `SetDelegateOperation`, `EmitOperation`;
+ + Rewrite `Buildable ExecutorOp` to delegate to these new instances.
+* [!1357](https://gitlab.com/morley-framework/morley/-/merge_requests/1357)
+ Better tests for `PACK`
+ + Fix an issue when untyping `CREATE_CONTRACT` instruction -- morley would
+ always use `Readable` representation for its contents;
+ + Fix an issue in typechecking `CREATE_CONTRACT` instruction -- morley
+ `SELF` inside `CREATE_CONTRACT` inside lambdas was rejected.
+* [!1349](https://gitlab.com/morley-framework/morley/-/merge_requests/1349)
+ Improve morley compilation time
+ + `Forbid*` constraints are no longer carried as superclasses of `Comparable`.
+ Match on `comparableImplies` to bring those into scope. In case of
+ impossible patterns, empty `case` with `checkComparability` should do the
+ trick.
+* [!1351](https://gitlab.com/morley-framework/morley/-/merge_requests/1351)
+ Fix and improve `Buildable MichelsonFailureWithStack`
+* [!1346](https://gitlab.com/morley-framework/morley/-/merge_requests/1346)
+ Use proper datatype for Micheline primitives, refactor some FromExp instances
+ + Replace a list of strings with a proper datatype for Micheline primitives
+ + Refactor `FromExp` instances to make pattern-matches (more) total and reduce
+ redundancy
+ + Make `FromExp` exceptions more structured
+ + Other minor refactoring
+* [!1342](https://gitlab.com/morley-framework/morley/-/merge_requests/1342)
+ Replace fmt with prettyprinter
+ + Introduce overlappable `Buildable` instance for anything `RenderDoc` to
+ avoid proliferation of trivial instances
+ + Deprecate `buildRenderDoc` and `buildRenderDocExtended`
+ + Replace unnecessary `RenderDoc` instances with `Buildable` (this refers to
+ various error types)
+ + `printDoc`, `printDocB`, `printDocS` deprecated in favor of
+ `printRenderDoc`
+ + Redundant `forceSingleLine` parameter to `renderType` removed
+ + Obsolete `Prettier` newtype deprecated
+ + Improve `NotWellTyped` error formatting
+ + Improve formatting for `Buildable ExecutorOp`
+* [!1347](https://gitlab.com/morley-framework/morley/-/merge_requests/1347)
+ Better errors for missing contract fields
+ + Improve efficiency when constructing untyped contract from list of contract
+ blocks
+ + Rename `UnsafeViewsSet` to `ViewsSet`, as there's nothing inherently unsafe
+ about this constructor any more (old name is left as a pattern synonym, but
+ deprecated)
+* [!1343](https://gitlab.com/morley-framework/morley/-/merge_requests/1343)
+ Fix optimizer dipSwapDrop regression
+ + Fixed a bug where `DIP n code` would be deoptimized into `DIP (n - 1) {
+ SWAP; code }`
+ + While at it, `DUP; DUG (m + 1); DROP` is now optimized to `DUG m`
+* [!1344](https://gitlab.com/morley-framework/morley/-/merge_requests/1344)
+ Typecheck recursive lambda values
+* [!1323](https://gitlab.com/morley-framework/morley/-/merge_requests/1323)
+ Trace called contracts on error
+ + Trace operations in the Morley emulator
+* [!1310](https://gitlab.com/morley-framework/morley/-/merge_requests/1310)
+ Various parser fixes
+ + Make parser stricter wrt braces around code blocks. Now things like `DIP
+ DROP` are rejected (as per reference), but `DIP FAIL` are allowed (as `FAIL`
+ is a macro)
+ + Properly handle braced code blocks in typechecker's verbose error messages
+ + Use optimized untyped contract representation in `toExpression`
+ + Fix macro expansion rules to match reference; add macro expansion tests
+ against reference
+* [!1341](https://gitlab.com/morley-framework/morley/-/merge_requests/1341)
+ Refactor scope constraints
+ + Unified all `check*Presence` functions into `checkTPresence`
+ + Unified all `*Absense` (sic) and `check*Presence` into `tAbsence` and
+ `tPresence`
+ + Unified all `Contains*` type families, plus `IsComparable` into `ContainsT`
+ + All now-redundant synonyms are deprecated
+ + Deprecate `HasNo*` and `Proper*BetterErrors` in favor of `Forbid*` and
+ `*Scope` respectively.
+ + Simplify `WithDeMorganScope`
+ + Avoid unnecessary singleton traversals using `checkTPresence`, remove where
+ possible, use de Morgan laws otherwise.
+ + Improve `Forbid*` error messages
+ + Improve `*Scope` error messages with the suggestion to add the corresponding
+ scope constraint
+ + Improve error messages on stuck type families with `Forbid*` and `*Scope`
+ + Drop redundant uses of `(:-)` implication in `AsRPC`, use constraints
+ explicitly
+* [!1293](https://gitlab.com/morley-framework/morley/-/merge_requests/1293)
+ Add extensible metadata field to StkEl
+* [!1335](https://gitlab.com/morley-framework/morley/-/merge_requests/1335)
+ Include morley CLI commands with morley-client
+ + Moved morley CLI parser and REPL to library under `Morley.App`
+* [!1333](https://gitlab.com/morley-framework/morley/-/merge_requests/1333)
+ Improve typechecker error rendering
+ + Switched to `prettyprinter` from `wl-pprint-text`
+ + Introduced `Morley.Michelson.Printer.Compat` as a thin compatibility layer
+* [!1336](https://gitlab.com/morley-framework/morley/-/merge_requests/1336)
+ Improve non-recursive `deriveRPC` errors
+ + Print human-readable error messages when required `HasRPCRepr` instances are
+ missing in non-recursive mode (i.e. `droRecursive=False`)
+* [!1340](https://gitlab.com/morley-framework/morley/-/merge_requests/1340)
+ Remove deprecated types and functions
+ + `haskellRepStripFieldPrefix`
+ + `Morley.Michelson.Typed.Contract.mapEntriesOrdered`
+ + `Morley.Michelson.Untyped.Contract.mapContractCode`
+ + `linearizeRightCombValuePair`
+ + `expandList`
+ + `(|-)`
+ + `MockableConstraint` and `unsafeProvideConstraint`
+ + `failUnlessEvi`
+ + `failWhenEvi`
+ + `ConcatListOfTypesAssociativity` and `listOfTypesConcatAssociativityAxiom`
+
1.19.1
======
* [!1325](https://gitlab.com/morley-framework/morley/-/merge_requests/1325)
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -5,312 +5,14 @@
( main
) where
-import Data.Default (def)
-import Data.Singletons (demote)
-import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile)
import Data.Version (showVersion)
-import Fmt (pretty, unlinesF)
-import Named (paramF)
import Options.Applicative
- (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc, short,
- subparser, switch)
-import Options.Applicative qualified as Opt
+ (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc)
import Options.Applicative.Help.Pretty (Doc, linebreak)
import Paths_morley (version)
-import Text.Hex (encodeHex)
-import Morley.CLI
-import Morley.Michelson.Analyzer (analyze)
-import Morley.Michelson.Interpret (RemainingSteps(..))
-import Morley.Michelson.Optimizer (OptimizerConf(..), optimizeVerboseWithConf)
-import Morley.Michelson.Printer (printSomeContract, printTypedContract, printUntypedContract)
-import Morley.Michelson.Runtime
-import Morley.Michelson.Runtime.GState (genesisAddress)
-import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckValue, typeCheckingWith)
-import Morley.Michelson.TypeCheck qualified as TypeCheck
-import Morley.Michelson.Typed (Contract'(..), SomeContract(..), unContractCode)
-import Morley.Michelson.Typed qualified as T
-import Morley.Michelson.Typed.Contract (mapContractCodeM)
-import Morley.Tezos.Address
-import Morley.Tezos.Address.Alias
-import Morley.Tezos.Core (Mutez, tz)
-import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey)
-import Morley.Util.CLI (mkCLOptionParser, mkCommandParser, outputOption)
-import Morley.Util.Main (wrapMain)
-import Morley.Util.Named
-import REPL
-
-data DryRunOrWrite = DryRun | Write
-
-mkCommandParser' :: String -> String -> Opt.Parser a -> Opt.Mod Opt.CommandFields a
-mkCommandParser' = flip . mkCommandParser
-
-argParser :: Opt.Parser (IO ())
-argParser = subparser $ mconcat
- [ printSubCmd
- , typecheckSubCmd
- , emulateSubCmd
- , optimizeSubCmd
- , analyzeSubCmd
- , createChestSubCmd
- , replSubCmd
- ]
-
---------------------------------------------------------------------------------
--- Subcommands
---------------------------------------------------------------------------------
-
--- NB: in case this looks mysterious, in IOCmd functions, outer 'do' is
--- Opt.Parser using ApplicativeDo, which then returns an IO action, i.e. inner
--- 'do' is 'IO ()'. -- @lierdakil
-
-type IOCmd = Opt.Mod Opt.CommandFields (IO ())
-
-typecheckSubCmd :: IOCmd
-typecheckSubCmd = mkCommandParser' "typecheck" "Typecheck passed contract." do
- contractFile <- optional contractFileOption
- tcOptions <- typeCheckOptionsOption
- pure do
- morleyContract <- prepareContract contractFile
- -- At the moment of writing, 'tcStrict' option does not change anything
- -- because it affects only values parsing; but this may change
- contract <- either throwM pure . typeCheckingWith tcOptions
- $ typeCheckContract morleyContract
- when (TypeCheck.tcVerbose tcOptions) $
- putStrLn $ printSomeContract False contract
- putTextLn "Contract is well-typed"
-
-printSubCmd :: IOCmd
-printSubCmd = mkCommandParser' "print"
- "Parse a Morley contract and print corresponding Michelson \
- \contract that can be parsed by the OCaml reference client: octez-client."
- do
- mInputFile <- optional contractFileOption
- mOutputFile <- outputOption
- forceSingleLine <- onelineOption
- pure do
- contract <- prepareContract mInputFile
- let write = maybe putStrLn Utf8.writeFile mOutputFile
- write $ printUntypedContract forceSingleLine contract
-
-emulateSubCmd :: IOCmd
-emulateSubCmd = mkCommandParser' "emulate" "Set of commands to run in an emulated environment." $
- subparser $ mconcat
- [ runSubCmd
- , originateSubCmd
- , transferSubCmd
- , transferTicketSubCmd
- , runViewSubCmd
- ]
-
-runSubCmd :: IOCmd
-runSubCmd = mkCommandParser' "run"
- "Run passed contract. It's originated first and then a transaction is sent to it." do
- txData <- txDataOption
- contract <- contractSimpleOriginationDataOption
- cro <- commonRunOptions Write
- pure do
- michelsonContract <- traverse prepareContract contract
- void $ runContract cro michelsonContract txData
-
-runViewSubCmd :: IOCmd
-runViewSubCmd = mkCommandParser' "view"
- "Run some view on a contract either supplied directly or identified \
- \by an address. It's originated first if supplied directly." do
- cro <- commonRunOptions Write
- addressOrContract <-
- ContractSpecAddressOrAlias <$> addressOrAliasOption Nothing
- ! #name "contract-addr"
- ! #help "Contract address to call view on."
- <|> ContractSpecOrigination <$> contractSimpleOriginationDataOption
- viewName <- mkCLOptionParser Nothing
- ! #name "name"
- ! #help "View name."
- sender <- someAddressOrAliasOption
- (Just $ SAOAKindSpecified $ AddressResolved genesisAddress)
- ! #name "sender"
- ! #help "Sender address."
- viewArg <- TxUntypedParam <$> valueOption Nothing
- ! #name "arg"
- ! #help "View call argument."
- pure do
- contractSpec <- (traverse . traverse) prepareContract addressOrContract
- void $ runView cro contractSpec viewName sender viewArg
-
-replSubCmd :: IOCmd
-replSubCmd = mkCommandParser' "repl" "Start a Morley REPL." $ pure runRepl
-
-originateSubCmd :: IOCmd
-originateSubCmd = mkCommandParser' "originate" "Originate passed contract. Add it to passed DB." do
- simpleOriginationData <- contractSimpleOriginationDataOption
- dbPath <- dbPathOption
- tcOptions <- typeCheckOptionsOption
- verbose <- verboseFlag
- originator <- addressOption (Just genesisAddress)
- ! #name "originator"
- ! #help "Contract's originator."
- alias <- optional (aliasOption "alias")
- delegate <- optional $ keyHashOption Nothing
- ! #name "delegate"
- ! #help "Contract's optional delegate."
- pure do
- michelsonContract <- traverse prepareContract simpleOriginationData
- addr <-
- originateContract
- ! #dbPath dbPath
- ! #tcOpts tcOptions
- ! #originator originator
- ! paramF #alias alias
- ! paramF #delegate delegate
- ! #csod michelsonContract
- ! #verbose verbose
- putTextLn $ "Originated contract " <> pretty addr
-
-transferSubCmd :: IOCmd
-transferSubCmd = mkCommandParser' "transfer" "Transfer tokens to given address." do
- destination <- someAddressOrAliasOption Nothing
- ! #name "to"
- ! #help "Address or alias of the transfer's destination."
- txData <- txDataOption
- cro <- commonRunOptions DryRun
- pure $ transfer cro destination txData
-
-transferTicketSubCmd :: IOCmd
-transferTicketSubCmd = mkCommandParser' "transfer-ticket" "Transfer ticket to given address." do
- destination <- someAddressOrAliasOption Nothing
- ! #name "to"
- ! #help "Address or alias of the transfer's destination."
- tdSenderAddress :: L1Address <- Constrained <$> addressOption (Just genesisAddress)
- ! #name "sender" ! #help "Sender address"
- ticketer <- mkCLOptionParser @Address Nothing
- ! #name "ticketer" ! #help "Ticketer"
- value <- valueOption Nothing
- ! #name "value" ! #help "Ticket value"
- ty <- mkCLOptionParser Nothing
- ! #name "type" ! #help "Ticket argument type"
- tAmount <- mkCLOptionParser @Natural Nothing
- ! #name "amount" ! #help "Amount of tickets"
- tdAmount <- mutezOption (Just minBound)
- ! #name "mutez" ! #help "Mutez amount additionally sent by a transaction. \
- \Note that on network, as of Mumbai, implicit accounts can't send tickets \
- \and mutez in the same operation, however the Morley emulator allows it."
- tdEntrypoint <- entrypointOption
- ! #name "entrypoint" ! #help "Entrypoint to call"
- cro <- commonRunOptions DryRun
- pure $ T.withUType ty \(_ :: T.Notes t) -> do
- tValue <- either throwM pure . typeCheckingWith (croTCOpts cro) $
- typeCheckValue @t value
- T.Dict <- either (throwM . TypeCheck.UnsupportedTypeForScope (demote @t)) pure $
- T.checkScope @(T.ParameterScope t, T.Comparable t)
- let tdParameter = TxTypedParam $ T.VTicket ticketer tValue tAmount
- transfer cro destination TxData{..}
-
-optimizeSubCmd :: IOCmd
-optimizeSubCmd = mkCommandParser' "optimize" "Optimize the contract." do
- contractFile <- optional contractFileOption
- output <- outputOption
- singleLine <- onelineOption
- maxStageIterations <- mkCLOptionParser (Just $ ocMaxIterations def)
- ! #name "max-stage-iterations"
- ! #help "Maximum number of iterations per optimizer stage. \
- \The default is usually adequate, but you want to try raising it \
- \to see if it affects the result."
- verbose <- verboseFlag
- pure do
- untypedContract <- prepareContract contractFile
- SomeContract checkedContract <-
- either throwM pure . typeCheckingWith laxTcOptions $
- typeCheckContract untypedContract
- let (logs, optimizedContract) =
- mapContractCodeM (optimizeVerboseWithConf conf) checkedContract
- conf = def { ocMaxIterations = maxStageIterations }
- maybe putStrLn Utf8.writeFile output $ printTypedContract singleLine optimizedContract
- when verbose $ hPutStrLn stderr $ pretty @_ @Text $ unlinesF logs
-
-analyzeSubCmd :: IOCmd
-analyzeSubCmd = mkCommandParser' "analyze" "Analyze the contract." do
- contractFile <- optional contractFileOption
- pure do
- untypedContract <- prepareContract contractFile
- SomeContract contract <-
- either throwM pure . typeCheckingWith laxTcOptions $
- typeCheckContract untypedContract
- putTextLn $ pretty $ analyze (unContractCode $ cCode contract)
-
-createChestSubCmd :: IOCmd
-createChestSubCmd = mkCommandParser' "create_chest" "Create a timelocked chest and key." do
- payload <- payloadOption
- time <- timeOption
- pure do
- (chest, key) <- createChestAndChestKey payload time
- putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)
- putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key)
-
---------------------------------------------------------------------------------
--- Parsers
---------------------------------------------------------------------------------
-
-verboseFlag :: Opt.Parser Bool
-verboseFlag = switch $
- short 'v' <>
- long "verbose" <>
- help "Whether output should be verbose."
-
-typeCheckOptionsOption :: Opt.Parser TypeCheck.TypeCheckOptions
-typeCheckOptionsOption = do
- tcVerbose <- verboseFlag
- tcStrict <- fmap not . switch $
- long "typecheck-lax" <>
- help "Whether actions permitted in `octez-client run` but forbidden in \
- \e.g. `octez-client originate` should be allowed here."
- return TypeCheck.TypeCheckOptions{..}
-
-commonRunOptions :: DryRunOrWrite -> Opt.Parser CommonRunOptions
-commonRunOptions defaultDryRun = do
- croNow <- nowOption
- croLevel <- fromMaybe (croLevel def) <$> levelOption
- croMinBlockTime <- fromMaybe (croMinBlockTime def) <$> minBlockTimeOption
- croMaxSteps <- RemainingSteps <$> maxStepsOption
- croDBPath <- dbPathOption
- croTCOpts <- typeCheckOptionsOption
- croVerbose <- verboseFlag
- croDryRun <- case defaultDryRun of
- Write -> fmap not . switch $
- long "write" <>
- help "Write updated DB to the DB file."
- DryRun -> switch $
- long "dry-run" <>
- help "Do not write updated DB to the DB file."
- pure CommonRunOptions{..}
-
-contractSimpleOriginationDataOption :: Opt.Parser (ContractSimpleOriginationData (Maybe FilePath))
-contractSimpleOriginationDataOption = do
- csodStorage <- valueOption Nothing
- ! #name "storage"
- ! #help "Initial storage of the contract."
- csodContract <- optional contractFileOption
- csodBalance <- mutezOption (Just defaultBalance)
- ! #name "balance"
- ! #help "Initial balance of the contract."
- pure ContractSimpleOriginationData{..}
-
---------------------------------------------------------------------------------
--- Constants
---------------------------------------------------------------------------------
-
-defaultBalance :: Mutez
-defaultBalance = [tz|4|]
-
--- | Most permitting options, when we don't care much about typechecking.
-laxTcOptions :: TypeCheck.TypeCheckOptions
-laxTcOptions = TypeCheck.TypeCheckOptions
- { TypeCheck.tcVerbose = False
- , TypeCheck.tcStrict = False
- }
-
---------------------------------------------------------------------------------
--- Actual main
---------------------------------------------------------------------------------
+import Morley.App.CLI
+import Morley.Util.Main
main :: IO ()
main = wrapMain $ join $ execParser programInfo
diff --git a/app/REPL.hs b/app/REPL.hs
deleted file mode 100644
--- a/app/REPL.hs
+++ /dev/null
@@ -1,327 +0,0 @@
--- SPDX-FileCopyrightText: 2021 Oxhead Alpha
--- SPDX-License-Identifier: LicenseRef-MIT-OA
-{-|
-Implements an REPL that can execute Morley instructions. REPL starts with an
-empty stack. At each instruction entered, the modified stack, or an error is
-printed. Multiple instructions separated by semicolons should work as expected.
-Available meta commads are:
-
- ':help', displays this help\n ':stack', prints the current stack
- ':loadstack filename', loads the stack from a file
- ':dumpstack filename', dumps the stack to a file
- ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."
--}
-module REPL
- ( runRepl
- ) where
-
-import Control.Exception (IOException)
-import Control.Monad.Random (randomIO)
-import Data.Aeson qualified as Aeson
-import Data.ByteString.Base58 qualified as Base58
-import Data.ByteString.Lazy qualified as BSL
-import Data.List (stripPrefix)
-import Data.Singletons (fromSing)
-import Data.Text as T (length, replicate, strip)
-import Data.Text qualified as T (stripPrefix)
-import Data.Vinyl (Rec(..))
-import Fmt (fmt, pretty)
-import System.Console.Haskeline
- (InputT, Interrupt(..), defaultSettings, getInputLine, runInputT, withInterrupt)
-import Text.Megaparsec (parse)
-
-import Morley.Michelson.Interpret (interpretInstr)
-import Morley.Michelson.Macro (ParsedOp, expand)
-import Morley.Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_)
-import Morley.Michelson.Parser.Types (MichelsonSource(..))
-import Morley.Michelson.Printer (printDoc, printTypedValue)
-import Morley.Michelson.Printer.Util (buildRenderDoc, doesntNeedParens)
-import Morley.Michelson.Runtime.Dummy
-import Morley.Michelson.Runtime.Import (readValue)
-import Morley.Michelson.TypeCheck
- (SomeTcInstr(..), SomeTcInstrOut(..), TypeCheckOptions(..), runTypeCheckIsolated,
- typeCheckingWith)
-import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)
-import Morley.Michelson.TypeCheck.Types (HST(..))
-import Morley.Michelson.Typed qualified as T
-import Morley.Michelson.Untyped qualified as U
-import Morley.Tezos.Crypto
-import Morley.Util.Sing (castSing)
-import Text.Hex (decodeHex, encodeHex)
-
-data SomeStack = forall t. T.SingI t => SomeStack
- { stValues :: (Rec T.Value t)
- , stTypes :: HST t
- }
-
-type ReplM = InputT (StateT SomeStack IO)
-
-runRepl :: IO ()
-runRepl = evalStateT (runInputT defaultSettings repl) emptyStack
-
--- | Prints an error message to stderr
-printErr :: (MonadIO m) => Text -> m ()
-printErr m = liftIO $ hPutStrLn stderr m
-
--- | Read commands or instructions from stdin and executes them.
--- If user presses Ctrl-c during execution of an instruction, it will be
--- caught and handled here itself. This ensures that REPL does not crash as
--- a result of user pressing Ctrl-c in an attempt to end a loop.
-repl :: ReplM ()
-repl = do
- printHelp
- repl_
-
-repl_ :: ReplM ()
-repl_ = do
- minput <- getInputLine "Morley>>> "
- case strStrip <$> minput of
- Nothing -> pass -- Ctrl D
- Just ":quit" -> pass
- Just input -> do
- case input of
- "" -> pass
- ":clear" -> lift $ put emptyStack
- ":stack" -> printStack
- ":help" -> printHelp
- (stripPrefixNonEmpty ":dumpstack" -> Just filename) ->
- dumpStackToFile $ toString $ strip $ toText filename
- (stripPrefixNonEmpty ":loadstack" -> Just filename) ->
- loadStackFromFile $ toString $ strip $ toText filename
- (stripPrefixNonEmpty ":parse" -> Just parseInput) ->
- tryParse $ strip $ toText parseInput
- (stripPrefixNonEmpty ":base58encode" -> Just parseInput) ->
- base58Encode $ strip $ toText parseInput
- (stripPrefix ":genkeys" -> Just mseed) -> do
- seed <- case mseed of
- "" -> show <$> (liftIO (randomIO @Word64))
- seed -> pure seed
- let sk = detSecretKey (encodeUtf8 seed)
- let pk = toPublic sk
- let pkh = hashKey pk
- printResult "Secret Key" (formatSecretKey sk)
- printResult "Public Key" (formatPublicKey pk)
- 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)
- repl_
- where
- strStrip = toString . strip . toText
- stripPrefixNonEmpty p i = case stripPrefix p i of
- Just "" -> Nothing
- x -> x
-
-base58Encode :: Text -> ReplM ()
-base58Encode inp = case decodeHex $ fromMaybe inp $ (T.stripPrefix "0x" inp) of
- Just b -> do
- printResult "Base58encode" $ decodeUtf8 $ Base58.encodeBase58 Base58.bitcoinAlphabet b
- printResult "Base58encode with checksum" $ encodeBase58Check b
- Nothing -> putTextLn "Can't parse input as hex-encoded bytes"
-
-tryParseMichelsonValue :: forall (t :: T.T). (T.SingI t, T.HasNoOp t) => Text -> Text -> ReplM ()
-tryParseMichelsonValue msg parseInput =
- case readValue @t MSStdin parseInput of
- Right s -> printResult msg $ (fmt . buildRenderDoc) s
- Left _ -> pass
-
-underlined :: MonadIO m => Text -> m ()
-underlined x = liftIO do
- putTextLn x
- putTextLn $ T.replicate (T.length x) "-"
-
-printResult :: MonadIO m => Text -> Text -> m ()
-printResult heading result = do
- underlined heading
- putTextLn result
- putTextLn ""
-
-tryParse :: Text -> ReplM ()
-tryParse parseInput = do
- tryParseMichelsonValue @'T.TKey "Michelson Key" parseInput
- tryParseMichelsonValue @'T.TUnit "Michelson Unit" parseInput
- tryParseMichelsonValue @'T.TSignature "Michelson Signature" parseInput
- tryParseMichelsonValue @'T.TChainId "Michelson ChainId" parseInput
- tryParseMichelsonValue @'T.TTimestamp "Michelson Timestamp" parseInput
- tryParseMichelsonValue @'T.TAddress "Michelson Address" parseInput
- tryParseMichelsonValue @'T.TString "Michelson String" parseInput
- tryParseMichelsonValue @'T.TInt "Michelson Int" parseInput
- tryParseMichelsonValue @'T.TNat "Michelson Nat" parseInput
- tryParseMichelsonValue @'T.TBytes "Michelson Bytes" parseInput
- tryParseMichelsonValue @'T.TMutez "Michelson Mutez" parseInput
- tryParseMichelsonValue @'T.TKeyHash "Michelson KeyHash" parseInput
- tryParseMichelsonValue @'T.TBls12381Fr "Michelson Bls12381Fr" parseInput
- tryParseMichelsonValue @'T.TBls12381G1 "Michelson Bls12381G1" parseInput
- tryParseMichelsonValue @'T.TBls12381G2 "Michelson Bls12381G2" parseInput
- tryParseMichelsonValue @'T.TBool "Michelson Bool" parseInput
-
- case parsePublicKey parseInput of
- Right p -> do
- printResult "Public Key" $ formatPublicKey p
- Left _ -> pass
- case parseSignature parseInput of
- Right p -> do
- printResult "Signature" $ formatSignature p
- Left _ -> pass
- case parseSecretKey parseInput of
- Right p -> do
- printResult "Secret Key" $ formatSecretKey p
- Left _ -> pass
- case parseHash @'HashKindPublicKey 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)
- Nothing -> pass
- case decodeBase58Check parseInput of
- Just p -> do
- printResult "Base58Check Encoded Bytes" $ "0x" <> (encodeHex p)
- Nothing -> pass
-
--- | Try to execute the given input string as a Morley instruction.
-runCode :: Text -> ReplM ()
-runCode code = do
- case parseInstructions code of
- Left err -> printErr err
- Right [] -> pass
- Right parsedOps -> do
- let expandedOps = expand <$> parsedOps
- lift get >>= \case
- SomeStack {..} -> case castSing stTypes of
- Just hstInp -> case typeCheckingWith tcOptions . runTypeCheckIsolated $
- typeCheckList expandedOps hstInp of
- Right someInstr -> do
- case someInstr of
- _ :/ (instr ::: hstOut)-> case interpretInstr dummyContractEnv instr stValues of
- Right recOut -> do
- lift $ put (SomeStack recOut hstOut)
- printStack
- Left michelsonFail -> putTextLn (pretty michelsonFail)
- _ :/ (AnyOutInstr _) -> putTextLn "Encountered a FAILWITH instruction"
- Left err -> printErr $ pretty err
- Nothing -> printErr "Casting stack failed"
-
-printHelp :: ReplM ()
-printHelp = putTextLn "REPL starts with an empty stack. At each instruction entered,\
- \ the modified stack, or an error is printed. Multiple instructions separated by semicolons should work\
- \ as expected. Available meta commads are:\n\
- \ ':help', displays this help\n ':stack', prints the current stack\n\
- \ ':parse ', tries to parse the given string using known formats\n\
- \ ':base58encode ', prints the base58 encoding of a bytestring\n\
- \ ':genkeys ', generates a key pair with hash using the seed string \n\
- \ ':loadstack ', loads the stack from a file\n\
- \ ':dumpstack ', dumps the stack to a file \n\
- \ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."
-
-printStack :: ReplM ()
-printStack = lift get >>= \case
- SomeStack stk hst -> do
- putTextLn "--"
- putTextLn $ showStack stk hst
-
-emptyStack :: SomeStack
-emptyStack = SomeStack RNil SNil
-
-parseInstructions :: Text -> Either Text [ParsedOp]
-parseInstructions src =
- case parseNoEnv ops MSUnspecified src of
- Right p -> Right p
- Left err -> Left (toText $ errorBundlePretty err)
-
-tcOptions :: TypeCheckOptions
-tcOptions = TypeCheckOptions
- { tcVerbose = False
- , tcStrict = False
- }
-
--- helpers
-
-addValueToHST
- :: forall t xs. T.SingI xs
- => T.Value t
- -> HST xs
- -> 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.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.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
-
-dumpStackToFile :: FilePath -> ReplM ()
-dumpStackToFile fname =
- lift get >>= \case
- SomeStack stk hst -> case dumpStack stk hst of
- Right stkd -> liftIO $ Prelude.catch (BSL.writeFile fname $ Aeson.encode stkd) handler
- Left err -> printErr err
- where
- handler :: IOException -> IO ()
- handler e = printErr $ toText $ displayException e
-
-loadStackFromFile :: FilePath -> ReplM ()
-loadStackFromFile fname = do
- mStack <- liftIO $ flip Prelude.catch handler $ do
- stackTxt <- BSL.readFile fname
- case Aeson.decode @[(Text, Text)] stackTxt of
- Just s -> pure $ loadStack s
- Nothing -> pure $ Left "Decoding error when parsing stack data from file"
- case mStack of
- Right stk -> lift $ put stk
- Left err -> printErr err
- where
- handler :: IOException -> IO (Either Text a)
- handler e = pure $ Left $ toText $ displayException e
-
--- | 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, _) ::& 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) : t)
- Left e -> Left e
- T.OpPresent -> Left "Cannot dump stack with operations"
-
--- | Overwrite the current stack with a stack loaded from a list of tuples
--- representing (value/type) pairs.
-loadStack :: [(Text, Text)] -> Either Text SomeStack
-loadStack = foldl' buildStack (Right emptyStack) . reverse
- where
- 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 type_ "" txTyp) of
- (Right val, Right typ) ->
- case typeCheckingWith tcOptions $ typeCheckParameter mempty typ val of
- Right (T.SomeValue tVal) ->
- case addValueToHST tVal hst of
- Right (T.Dict, newHst) -> Right $ SomeStack (tVal :& stk) newHst
- Left err -> Left err
- Left tcError -> Left $ pretty tcError
- (Left err, _) -> Left $ pretty err
- (_, Left err) -> Left $ toText $ errorBundlePretty err
-
-showStack :: forall t. Rec T.Value t -> HST t -> Text
-showStack RNil _ = "--"
-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)
- _ -> -- else just call show, and indicate value has operation inside
- case (v, T.sing @a) of
- (T.VList [], T.STList T.STOperation) -> "{ } :: list operation\n" <> showStack rst rHst
- _ -> addSuffix $ "(operations container:" <> pretty v <> ")"
- where
- addSuffix val = val <>" :: " <> renderType notes <> "\n" <> showStack rst rHst
diff --git a/morley.cabal b/morley.cabal
--- a/morley.cabal
+++ b/morley.cabal
@@ -5,7 +5,7 @@
-- see: https://github.com/sol/hpack
name: morley
-version: 1.19.1
+version: 1.19.2
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
@@ -32,6 +32,8 @@
library
exposed-modules:
+ Morley.App.CLI
+ Morley.App.REPL
Morley.AsRPC
Morley.CLI
Morley.Micheline
@@ -39,6 +41,8 @@
Morley.Micheline.Binary.Internal
Morley.Micheline.Class
Morley.Micheline.Expression
+ Morley.Micheline.Expression.Internal.MichelinePrimitive
+ Morley.Micheline.Expression.Internal.TH
Morley.Micheline.Expression.WithMeta
Morley.Micheline.Json
Morley.Michelson.Analyzer
@@ -54,6 +58,9 @@
Morley.Michelson.Macro
Morley.Michelson.Optimizer
Morley.Michelson.Optimizer.Internal.Proofs
+ Morley.Michelson.Optimizer.Internal.Rules
+ Morley.Michelson.Optimizer.Internal.Ruleset
+ Morley.Michelson.Optimizer.Utils
Morley.Michelson.Parser
Morley.Michelson.Parser.Annotations
Morley.Michelson.Parser.Common
@@ -122,6 +129,15 @@
Morley.Michelson.Typed.Operation
Morley.Michelson.Typed.Polymorphic
Morley.Michelson.Typed.Scope
+ Morley.Michelson.Typed.Scope.Internal.CheckScope
+ Morley.Michelson.Typed.Scope.Internal.Comparable
+ Morley.Michelson.Typed.Scope.Internal.Deprecated
+ Morley.Michelson.Typed.Scope.Internal.ForbidT
+ Morley.Michelson.Typed.Scope.Internal.Presence
+ Morley.Michelson.Typed.Scope.Internal.Scopes
+ Morley.Michelson.Typed.Scope.Internal.TH
+ Morley.Michelson.Typed.Scope.Internal.WellTyped
+ Morley.Michelson.Typed.Scope.Internal.WithDeMorganScope
Morley.Michelson.Typed.Sing
Morley.Michelson.Typed.T
Morley.Michelson.Typed.TypeLevel
@@ -134,6 +150,7 @@
Morley.Michelson.Untyped.Contract
Morley.Michelson.Untyped.Entrypoints
Morley.Michelson.Untyped.Ext
+ Morley.Michelson.Untyped.HoistInstr
Morley.Michelson.Untyped.Instr
Morley.Michelson.Untyped.Type
Morley.Michelson.Untyped.Value
@@ -263,10 +280,10 @@
, dependent-sum-template
, elliptic-curve
, first-class-families >=0.5.0.0
- , fmt >=0.6.3.0
, galois-field
, generic-deriving
, gitrev
+ , haskeline
, hex-text
, hsblst
, lens
@@ -278,6 +295,7 @@
, optparse-applicative
, pairing
, parser-combinators >=1.0.0
+ , prettyprinter
, scientific
, semigroups >=0.19.1
, show-type
@@ -298,13 +316,11 @@
, vector
, vinyl >=0.13.1
, with-utf8
- , wl-pprint-text
default-language: Haskell2010
executable morley
main-is: Main.hs
other-modules:
- REPL
Paths_morley
autogen-modules:
Paths_morley
@@ -363,22 +379,8 @@
ViewPatterns
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode
build-depends:
- MonadRandom
- , aeson
- , base-noprelude >=4.7 && <5
- , base58-bytestring
- , bytestring
- , data-default
- , fmt
- , haskeline
- , hex-text
- , megaparsec >=7.0.0
+ base-noprelude >=4.7 && <5
, morley
, morley-prelude
- , named
, optparse-applicative
- , singletons
- , text
- , vinyl
- , with-utf8
default-language: Haskell2010
diff --git a/src/Morley/App/CLI.hs b/src/Morley/App/CLI.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/App/CLI.hs
@@ -0,0 +1,303 @@
+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+module Morley.App.CLI
+ ( argParser
+ ) where
+
+import Data.Default (def)
+import Data.Singletons (demote)
+import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile)
+import Fmt (pretty, prettyText, unlinesF)
+import Named (paramF)
+import Options.Applicative (help, long, short, subparser, switch)
+import Options.Applicative qualified as Opt
+import Text.Hex (encodeHex)
+
+import Morley.App.REPL
+import Morley.CLI
+import Morley.Michelson.Analyzer (analyze)
+import Morley.Michelson.Interpret (RemainingSteps(..))
+import Morley.Michelson.Optimizer (OptimizerConf(..), optimizeVerboseWithConf)
+import Morley.Michelson.Printer (printSomeContract, printTypedContract, printUntypedContract)
+import Morley.Michelson.Runtime
+import Morley.Michelson.Runtime.GState (genesisAddress)
+import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckValue, typeCheckingWith)
+import Morley.Michelson.TypeCheck qualified as TypeCheck
+import Morley.Michelson.Typed (Contract'(..), SomeContract(..), unContractCode)
+import Morley.Michelson.Typed qualified as T
+import Morley.Michelson.Typed.Contract (mapContractCodeM)
+import Morley.Tezos.Address
+import Morley.Tezos.Address.Alias
+import Morley.Tezos.Core (Mutez, tz)
+import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey)
+import Morley.Util.CLI (mkCLOptionParser, mkCommandParser, outputOption)
+import Morley.Util.Named
+
+data DryRunOrWrite = DryRun | Write
+
+mkCommandParser' :: String -> String -> Opt.Parser a -> Opt.Mod Opt.CommandFields a
+mkCommandParser' = flip . mkCommandParser
+
+argParser :: Opt.Parser (IO ())
+argParser = subparser $ mconcat
+ [ printSubCmd
+ , typecheckSubCmd
+ , emulateSubCmd
+ , optimizeSubCmd
+ , analyzeSubCmd
+ , createChestSubCmd
+ , replSubCmd
+ ]
+
+--------------------------------------------------------------------------------
+-- Subcommands
+--------------------------------------------------------------------------------
+
+-- NB: in case this looks mysterious, in IOCmd functions, outer 'do' is
+-- Opt.Parser using ApplicativeDo, which then returns an IO action, i.e. inner
+-- 'do' is 'IO ()'. -- @lierdakil
+
+type IOCmd = Opt.Mod Opt.CommandFields (IO ())
+
+typecheckSubCmd :: IOCmd
+typecheckSubCmd = mkCommandParser' "typecheck" "Typecheck passed contract." do
+ contractFile <- optional contractFileOption
+ tcOptions <- typeCheckOptionsOption
+ pure do
+ morleyContract <- prepareContract contractFile
+ -- At the moment of writing, 'tcStrict' option does not change anything
+ -- because it affects only values parsing; but this may change
+ contract <- either throwM pure . typeCheckingWith tcOptions
+ $ typeCheckContract morleyContract
+ when (TypeCheck.tcVerbose tcOptions) $
+ putStrLn $ printSomeContract False contract
+ putTextLn "Contract is well-typed"
+
+printSubCmd :: IOCmd
+printSubCmd = mkCommandParser' "print"
+ "Parse a Morley contract and print corresponding Michelson \
+ \contract that can be parsed by the OCaml reference client: octez-client."
+ do
+ mInputFile <- optional contractFileOption
+ mOutputFile <- outputOption
+ forceSingleLine <- onelineOption
+ pure do
+ contract <- prepareContract mInputFile
+ let write = maybe putStrLn Utf8.writeFile mOutputFile
+ write $ printUntypedContract forceSingleLine contract
+
+emulateSubCmd :: IOCmd
+emulateSubCmd = mkCommandParser' "emulate" "Set of commands to run in an emulated environment." $
+ subparser $ mconcat
+ [ runSubCmd
+ , originateSubCmd
+ , transferSubCmd
+ , transferTicketSubCmd
+ , runViewSubCmd
+ ]
+
+runSubCmd :: IOCmd
+runSubCmd = mkCommandParser' "run"
+ "Run passed contract. It's originated first and then a transaction is sent to it." do
+ txData <- txDataOption
+ contract <- contractSimpleOriginationDataOption
+ cro <- commonRunOptions Write
+ pure do
+ michelsonContract <- traverse prepareContract contract
+ void $ runContract cro michelsonContract txData
+
+runViewSubCmd :: IOCmd
+runViewSubCmd = mkCommandParser' "view"
+ "Run some view on a contract either supplied directly or identified \
+ \by an address. It's originated first if supplied directly." do
+ cro <- commonRunOptions Write
+ addressOrContract <-
+ ContractSpecAddressOrAlias <$> addressOrAliasOption Nothing
+ ! #name "contract-addr"
+ ! #help "Contract address to call view on."
+ <|> ContractSpecOrigination <$> contractSimpleOriginationDataOption
+ viewName <- mkCLOptionParser Nothing
+ ! #name "name"
+ ! #help "View name."
+ sender <- someAddressOrAliasOption
+ (Just $ SAOAKindSpecified $ AddressResolved genesisAddress)
+ ! #name "sender"
+ ! #help "Sender address."
+ viewArg <- TxUntypedParam <$> valueOption Nothing
+ ! #name "arg"
+ ! #help "View call argument."
+ pure do
+ contractSpec <- (traverse . traverse) prepareContract addressOrContract
+ void $ runView cro contractSpec viewName sender viewArg
+
+replSubCmd :: IOCmd
+replSubCmd = mkCommandParser' "repl" "Start a Morley REPL." $ pure runRepl
+
+originateSubCmd :: IOCmd
+originateSubCmd = mkCommandParser' "originate" "Originate passed contract. Add it to passed DB." do
+ simpleOriginationData <- contractSimpleOriginationDataOption
+ dbPath <- dbPathOption
+ tcOptions <- typeCheckOptionsOption
+ verbose <- verboseFlag
+ originator <- addressOption (Just genesisAddress)
+ ! #name "originator"
+ ! #help "Contract's originator."
+ alias <- optional (aliasOption "alias")
+ delegate <- optional $ keyHashOption Nothing
+ ! #name "delegate"
+ ! #help "Contract's optional delegate."
+ pure do
+ michelsonContract <- traverse prepareContract simpleOriginationData
+ addr <-
+ originateContract
+ ! #dbPath dbPath
+ ! #tcOpts tcOptions
+ ! #originator originator
+ ! paramF #alias alias
+ ! paramF #delegate delegate
+ ! #csod michelsonContract
+ ! #verbose verbose
+ putTextLn $ "Originated contract " <> pretty addr
+
+transferSubCmd :: IOCmd
+transferSubCmd = mkCommandParser' "transfer" "Transfer tokens to given address." do
+ destination <- someAddressOrAliasOption Nothing
+ ! #name "to"
+ ! #help "Address or alias of the transfer's destination."
+ txData <- txDataOption
+ cro <- commonRunOptions DryRun
+ pure $ transfer cro destination txData
+
+transferTicketSubCmd :: IOCmd
+transferTicketSubCmd = mkCommandParser' "transfer-ticket" "Transfer ticket to given address." do
+ destination <- someAddressOrAliasOption Nothing
+ ! #name "to"
+ ! #help "Address or alias of the transfer's destination."
+ tdSenderAddress :: L1Address <- Constrained <$> addressOption (Just genesisAddress)
+ ! #name "sender" ! #help "Sender address"
+ ticketer <- mkCLOptionParser @Address Nothing
+ ! #name "ticketer" ! #help "Ticketer"
+ value <- valueOption Nothing
+ ! #name "value" ! #help "Ticket value"
+ ty <- mkCLOptionParser Nothing
+ ! #name "type" ! #help "Ticket argument type"
+ tAmount <- mkCLOptionParser @Natural Nothing
+ ! #name "amount" ! #help "Amount of tickets"
+ tdAmount <- mutezOption (Just minBound)
+ ! #name "mutez" ! #help "Mutez amount additionally sent by a transaction. \
+ \Note that on network, as of Mumbai, implicit accounts can't send tickets \
+ \and mutez in the same operation, however the Morley emulator allows it."
+ tdEntrypoint <- entrypointOption
+ ! #name "entrypoint" ! #help "Entrypoint to call"
+ cro <- commonRunOptions DryRun
+ pure $ T.withUType ty \(_ :: T.Notes t) -> do
+ tValue <- either throwM pure . typeCheckingWith (croTCOpts cro) $
+ typeCheckValue @t value
+ T.Dict <- either (throwM . TypeCheck.UnsupportedTypeForScope (demote @t)) pure $
+ T.checkScope @(T.ParameterScope t, T.Comparable t)
+ let tdParameter = TxTypedParam $ T.VTicket ticketer tValue tAmount
+ transfer cro destination TxData{..}
+
+optimizeSubCmd :: IOCmd
+optimizeSubCmd = mkCommandParser' "optimize" "Optimize the contract." do
+ contractFile <- optional contractFileOption
+ output <- outputOption
+ singleLine <- onelineOption
+ maxStageIterations <- mkCLOptionParser (Just $ ocMaxIterations def)
+ ! #name "max-stage-iterations"
+ ! #help "Maximum number of iterations per optimizer stage. \
+ \The default is usually adequate, but you want to try raising it \
+ \to see if it affects the result."
+ verbose <- verboseFlag
+ pure do
+ untypedContract <- prepareContract contractFile
+ SomeContract checkedContract <-
+ either throwM pure . typeCheckingWith laxTcOptions $
+ typeCheckContract untypedContract
+ let (logs, optimizedContract) =
+ mapContractCodeM (optimizeVerboseWithConf conf) checkedContract
+ conf = def { ocMaxIterations = maxStageIterations }
+ maybe putStrLn Utf8.writeFile output $ printTypedContract singleLine optimizedContract
+ when verbose $ hPutStrLn stderr $ prettyText $ unlinesF logs
+
+analyzeSubCmd :: IOCmd
+analyzeSubCmd = mkCommandParser' "analyze" "Analyze the contract." do
+ contractFile <- optional contractFileOption
+ pure do
+ untypedContract <- prepareContract contractFile
+ SomeContract contract <-
+ either throwM pure . typeCheckingWith laxTcOptions $
+ typeCheckContract untypedContract
+ putTextLn $ pretty $ analyze (unContractCode $ cCode contract)
+
+createChestSubCmd :: IOCmd
+createChestSubCmd = mkCommandParser' "create_chest" "Create a timelocked chest and key." do
+ payload <- payloadOption
+ time <- timeOption
+ pure do
+ (chest, key) <- createChestAndChestKey payload time
+ putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)
+ putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key)
+
+--------------------------------------------------------------------------------
+-- Parsers
+--------------------------------------------------------------------------------
+
+verboseFlag :: Opt.Parser Bool
+verboseFlag = switch $
+ short 'v' <>
+ long "verbose" <>
+ help "Whether output should be verbose."
+
+typeCheckOptionsOption :: Opt.Parser TypeCheck.TypeCheckOptions
+typeCheckOptionsOption = do
+ tcVerbose <- verboseFlag
+ tcStrict <- fmap not . switch $
+ long "typecheck-lax" <>
+ help "Whether actions permitted in `octez-client run` but forbidden in \
+ \e.g. `octez-client originate` should be allowed here."
+ return TypeCheck.TypeCheckOptions{..}
+
+commonRunOptions :: DryRunOrWrite -> Opt.Parser CommonRunOptions
+commonRunOptions defaultDryRun = do
+ croNow <- nowOption
+ croLevel <- fromMaybe (croLevel def) <$> levelOption
+ croMinBlockTime <- fromMaybe (croMinBlockTime def) <$> minBlockTimeOption
+ croMaxSteps <- RemainingSteps <$> maxStepsOption
+ croDBPath <- dbPathOption
+ croTCOpts <- typeCheckOptionsOption
+ croVerbose <- verboseFlag
+ croDryRun <- case defaultDryRun of
+ Write -> fmap not . switch $
+ long "write" <>
+ help "Write updated DB to the DB file."
+ DryRun -> switch $
+ long "dry-run" <>
+ help "Do not write updated DB to the DB file."
+ pure CommonRunOptions{..}
+
+contractSimpleOriginationDataOption :: Opt.Parser (ContractSimpleOriginationData (Maybe FilePath))
+contractSimpleOriginationDataOption = do
+ csodStorage <- valueOption Nothing
+ ! #name "storage"
+ ! #help "Initial storage of the contract."
+ csodContract <- optional contractFileOption
+ csodBalance <- mutezOption (Just defaultBalance)
+ ! #name "balance"
+ ! #help "Initial balance of the contract."
+ pure ContractSimpleOriginationData{..}
+
+--------------------------------------------------------------------------------
+-- Constants
+--------------------------------------------------------------------------------
+
+defaultBalance :: Mutez
+defaultBalance = [tz|4|]
+
+-- | Most permitting options, when we don't care much about typechecking.
+laxTcOptions :: TypeCheck.TypeCheckOptions
+laxTcOptions = TypeCheck.TypeCheckOptions
+ { TypeCheck.tcVerbose = False
+ , TypeCheck.tcStrict = False
+ }
diff --git a/src/Morley/App/REPL.hs b/src/Morley/App/REPL.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/App/REPL.hs
@@ -0,0 +1,318 @@
+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+{-|
+Implements an REPL that can execute Morley instructions. REPL starts with an
+empty stack. At each instruction entered, the modified stack, or an error is
+printed. Multiple instructions separated by semicolons should work as expected.
+Available meta commads are:
+
+ ':help', displays this help\n ':stack', prints the current stack
+ ':loadstack filename', loads the stack from a file
+ ':dumpstack filename', dumps the stack to a file
+ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."
+-}
+module Morley.App.REPL
+ ( runRepl
+ ) where
+
+import Prelude hiding (group)
+
+import Control.Exception (IOException)
+import Control.Monad.Random (randomIO)
+import Data.Aeson qualified as Aeson
+import Data.ByteString.Base58 qualified as Base58
+import Data.ByteString.Lazy qualified as BSL
+import Data.List (stripPrefix)
+import Data.Singletons (fromSing)
+import Data.Text as T (length, replicate, strip)
+import Data.Text qualified as T (stripPrefix)
+import Data.Vinyl (Rec(..))
+import Fmt (Doc, build, pretty)
+import Prettyprinter (align, group, line, nest)
+import System.Console.Haskeline
+ (InputT, Interrupt(..), defaultSettings, getInputLine, runInputT, withInterrupt)
+import Text.Megaparsec (parse)
+
+import Morley.Michelson.Interpret (interpretInstr)
+import Morley.Michelson.Macro (ParsedOp, expand)
+import Morley.Michelson.Parser
+ (errorBundlePretty, parseExpandValue, parseNoEnv, rawOpsSequence, type_)
+import Morley.Michelson.Parser.Types (MichelsonSource(..))
+import Morley.Michelson.Printer.Util (printRenderDoc)
+import Morley.Michelson.Runtime.Dummy
+import Morley.Michelson.Runtime.Import (readValue)
+import Morley.Michelson.TypeCheck
+ (SomeTcInstr(..), SomeTcInstrOut(..), TypeCheckOptions(..), runTypeCheckIsolated,
+ typeCheckingWith)
+import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)
+import Morley.Michelson.TypeCheck.Types (HST(..))
+import Morley.Michelson.Typed qualified as T
+import Morley.Tezos.Crypto
+import Morley.Util.Sing (castSing)
+import Text.Hex (decodeHex, encodeHex)
+
+data SomeStack = forall t. T.SingI t => SomeStack
+ { stValues :: (Rec T.Value t)
+ , stTypes :: HST t
+ }
+
+type ReplM = InputT (StateT SomeStack IO)
+
+runRepl :: IO ()
+runRepl = evalStateT (runInputT defaultSettings repl) emptyStack
+
+-- | Prints an error message to stderr
+printErr :: (MonadIO m) => Text -> m ()
+printErr m = liftIO $ hPutStrLn stderr m
+
+-- | Read commands or instructions from stdin and executes them.
+-- If user presses Ctrl-c during execution of an instruction, it will be
+-- caught and handled here itself. This ensures that REPL does not crash as
+-- a result of user pressing Ctrl-c in an attempt to end a loop.
+repl :: ReplM ()
+repl = do
+ printHelp
+ repl_
+
+repl_ :: ReplM ()
+repl_ = do
+ minput <- getInputLine "Morley>>> "
+ case strStrip <$> minput of
+ Nothing -> pass -- Ctrl D
+ Just ":quit" -> pass
+ Just input -> do
+ case input of
+ "" -> pass
+ ":clear" -> lift $ put emptyStack
+ ":stack" -> printStack
+ ":help" -> printHelp
+ (stripPrefixNonEmpty ":dumpstack" -> Just filename) ->
+ dumpStackToFile $ toString $ strip $ toText filename
+ (stripPrefixNonEmpty ":loadstack" -> Just filename) ->
+ loadStackFromFile $ toString $ strip $ toText filename
+ (stripPrefixNonEmpty ":parse" -> Just parseInput) ->
+ tryParse $ strip $ toText parseInput
+ (stripPrefixNonEmpty ":base58encode" -> Just parseInput) ->
+ base58Encode $ strip $ toText parseInput
+ (stripPrefix ":genkeys" -> Just mseed) -> do
+ seed <- case mseed of
+ "" -> show <$> (liftIO (randomIO @Word64))
+ seed -> pure seed
+ let sk = detSecretKey (encodeUtf8 seed)
+ let pk = toPublic sk
+ let pkh = hashKey pk
+ printResult "Secret Key" (formatSecretKey sk)
+ printResult "Public Key" (formatPublicKey pk)
+ 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)
+ repl_
+ where
+ strStrip = toString . strip . toText
+ stripPrefixNonEmpty p i = case stripPrefix p i of
+ Just "" -> Nothing
+ x -> x
+
+base58Encode :: Text -> ReplM ()
+base58Encode inp = case decodeHex $ fromMaybe inp $ (T.stripPrefix "0x" inp) of
+ Just b -> do
+ printResult "Base58encode" $ decodeUtf8 $ Base58.encodeBase58 Base58.bitcoinAlphabet b
+ printResult "Base58encode with checksum" $ encodeBase58Check b
+ Nothing -> putTextLn "Can't parse input as hex-encoded bytes"
+
+tryParseMichelsonValue :: forall (t :: T.T). (T.SingI t) => Text -> Text -> ReplM ()
+tryParseMichelsonValue msg parseInput =
+ case readValue @t MSStdin parseInput of
+ Right s -> printResult msg $ pretty s
+ Left _ -> pass
+
+underlined :: MonadIO m => Text -> m ()
+underlined x = liftIO do
+ putTextLn x
+ putTextLn $ T.replicate (T.length x) "-"
+
+printResult :: MonadIO m => Text -> Text -> m ()
+printResult heading result = do
+ underlined heading
+ putTextLn result
+ putTextLn ""
+
+tryParse :: Text -> ReplM ()
+tryParse parseInput = do
+ tryParseMichelsonValue @'T.TKey "Michelson Key" parseInput
+ tryParseMichelsonValue @'T.TUnit "Michelson Unit" parseInput
+ tryParseMichelsonValue @'T.TSignature "Michelson Signature" parseInput
+ tryParseMichelsonValue @'T.TChainId "Michelson ChainId" parseInput
+ tryParseMichelsonValue @'T.TTimestamp "Michelson Timestamp" parseInput
+ tryParseMichelsonValue @'T.TAddress "Michelson Address" parseInput
+ tryParseMichelsonValue @'T.TString "Michelson String" parseInput
+ tryParseMichelsonValue @'T.TInt "Michelson Int" parseInput
+ tryParseMichelsonValue @'T.TNat "Michelson Nat" parseInput
+ tryParseMichelsonValue @'T.TBytes "Michelson Bytes" parseInput
+ tryParseMichelsonValue @'T.TMutez "Michelson Mutez" parseInput
+ tryParseMichelsonValue @'T.TKeyHash "Michelson KeyHash" parseInput
+ tryParseMichelsonValue @'T.TBls12381Fr "Michelson Bls12381Fr" parseInput
+ tryParseMichelsonValue @'T.TBls12381G1 "Michelson Bls12381G1" parseInput
+ tryParseMichelsonValue @'T.TBls12381G2 "Michelson Bls12381G2" parseInput
+ tryParseMichelsonValue @'T.TBool "Michelson Bool" parseInput
+
+ case parsePublicKey parseInput of
+ Right p -> do
+ printResult "Public Key" $ formatPublicKey p
+ Left _ -> pass
+ case parseSignature parseInput of
+ Right p -> do
+ printResult "Signature" $ formatSignature p
+ Left _ -> pass
+ case parseSecretKey parseInput of
+ Right p -> do
+ printResult "Secret Key" $ formatSecretKey p
+ Left _ -> pass
+ case parseHash @'HashKindPublicKey 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)
+ Nothing -> pass
+ case decodeBase58Check parseInput of
+ Just p -> do
+ printResult "Base58Check Encoded Bytes" $ "0x" <> (encodeHex p)
+ Nothing -> pass
+
+-- | Try to execute the given input string as a Morley instruction.
+runCode :: Text -> ReplM ()
+runCode code = do
+ case parseInstructions code of
+ Left err -> printErr err
+ Right [] -> pass
+ Right parsedOps -> do
+ let expandedOps = expand <$> parsedOps
+ lift get >>= \case
+ SomeStack {..} -> case castSing stTypes of
+ Just hstInp -> case typeCheckingWith tcOptions . runTypeCheckIsolated $
+ typeCheckList expandedOps hstInp of
+ Right someInstr -> do
+ case someInstr of
+ _ :/ (instr ::: hstOut)-> case interpretInstr dummyContractEnv instr stValues of
+ Right recOut -> do
+ lift $ put (SomeStack recOut hstOut)
+ printStack
+ Left michelsonFail -> putTextLn (pretty michelsonFail)
+ _ :/ (AnyOutInstr _) -> putTextLn "Encountered a FAILWITH instruction"
+ Left err -> printErr $ pretty err
+ Nothing -> printErr "Casting stack failed"
+
+printHelp :: ReplM ()
+printHelp = putTextLn "REPL starts with an empty stack. At each instruction entered,\
+ \ the modified stack, or an error is printed. Multiple instructions separated by semicolons should work\
+ \ as expected. Available meta commads are:\n\
+ \ ':help', displays this help\n ':stack', prints the current stack\n\
+ \ ':parse ', tries to parse the given string using known formats\n\
+ \ ':base58encode ', prints the base58 encoding of a bytestring\n\
+ \ ':genkeys ', generates a key pair with hash using the seed string \n\
+ \ ':loadstack ', loads the stack from a file\n\
+ \ ':dumpstack ', dumps the stack to a file \n\
+ \ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."
+
+printStack :: ReplM ()
+printStack = lift get >>= \case
+ SomeStack stk hst -> do
+ putTextLn "--"
+ putTextLn $ pretty $ showStack stk hst
+
+emptyStack :: SomeStack
+emptyStack = SomeStack RNil SNil
+
+parseInstructions :: Text -> Either Text [ParsedOp]
+parseInstructions src =
+ case parseNoEnv (rawOpsSequence $ pure ()) MSUnspecified src of
+ Right p -> Right p
+ Left err -> Left (toText $ errorBundlePretty err)
+
+tcOptions :: TypeCheckOptions
+tcOptions = TypeCheckOptions
+ { tcVerbose = False
+ , tcStrict = False
+ }
+
+-- helpers
+
+addValueToHST
+ :: forall t xs. T.SingI xs
+ => T.Value t
+ -> HST xs
+ -> 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.sing @t, wtpDict) ::& hstIn)
+ Left e -> Left $ pretty e
+
+dumpStackToFile :: FilePath -> ReplM ()
+dumpStackToFile fname =
+ lift get >>= \case
+ SomeStack stk hst -> case dumpStack stk hst of
+ Right stkd -> liftIO $ Prelude.catch (BSL.writeFile fname $ Aeson.encode stkd) handler
+ Left err -> printErr err
+ where
+ handler :: IOException -> IO ()
+ handler e = printErr $ toText $ displayException e
+
+loadStackFromFile :: FilePath -> ReplM ()
+loadStackFromFile fname = do
+ mStack <- liftIO $ flip Prelude.catch handler $ do
+ stackTxt <- BSL.readFile fname
+ case Aeson.decode @[(Text, Text)] stackTxt of
+ Just s -> pure $ loadStack s
+ Nothing -> pure $ Left "Decoding error when parsing stack data from file"
+ case mStack of
+ Right stk -> lift $ put stk
+ Left err -> printErr err
+ where
+ handler :: IOException -> IO (Either Text a)
+ handler e = pure $ Left $ toText $ displayException e
+
+-- | Dump stack as a list 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, _) ::& rHst) = case T.valueTypeSanity v of
+ T.Dict -> case T.checkTPresence T.SPSOp (T.sing @a) of
+ T.TAbsent -> case dumpStack rst rHst of
+ Right t -> Right $ (printRenderDoc True v, printRenderDoc True (fromSing notes)) : t
+ Left e -> Left e
+ T.TPresent -> Left "Cannot dump stack with operations"
+
+-- | Overwrite the current stack with a stack loaded from a list of tuples
+-- representing (value/type) pairs.
+loadStack :: [(Text, Text)] -> Either Text SomeStack
+loadStack = foldl' buildStack (Right emptyStack) . reverse
+ where
+ 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 type_ "" txTyp) of
+ (Right val, Right typ) ->
+ case typeCheckingWith tcOptions $ typeCheckParameter mempty typ val of
+ Right (T.SomeValue tVal) ->
+ case addValueToHST tVal hst of
+ Right (T.Dict, newHst) -> Right $ SomeStack (tVal :& stk) newHst
+ Left err -> Left err
+ Left tcError -> Left $ pretty tcError
+ (Left err, _) -> Left $ pretty err
+ (_, Left err) -> Left $ toText $ errorBundlePretty err
+
+showStack :: forall t. Rec T.Value t -> HST t -> Doc
+showStack RNil _ = "--"
+showStack ((v :: T.Value a) :& rst) ((notes, _) ::& rHst) = case T.valueTypeSanity v of
+ T.Dict -> case T.checkTPresence T.SPSOp (T.sing @a) of
+ T.TAbsent -> -- print nice if value has no operations
+ addSuffix (build v)
+ T.TPresent -> -- else just call show, and indicate value has operation inside
+ case (v, T.sing @a) of
+ (T.VList [], T.STList T.STOperation) -> "{ } :: list operation\n" <> showStack rst rHst
+ _ -> addSuffix $ "(operations container:" <> pretty v <> ")"
+ where
+ addSuffix val =
+ nest 2 (group $ val <> line <> ":: " <> align (pretty notes)) <> line <> showStack rst rHst
diff --git a/src/Morley/AsRPC.hs b/src/Morley/AsRPC.hs
--- a/src/Morley/AsRPC.hs
+++ b/src/Morley/AsRPC.hs
@@ -26,29 +26,26 @@
import Prelude qualified
import Control.Lens.Plated (universe)
-import Data.Constraint (Dict(..), (***), (:-)(Sub), (\\))
+import Data.Constraint ((\\))
import Data.Default (Default(..))
-import Data.Generics (everything, mkQ)
+import Data.Generics (everything, everywhere, mkQ, mkT)
import Data.List qualified as List ((\\))
import Data.Map qualified as Map
import Data.Singletons (Sing, withSingI)
import Data.Text qualified as T
+import Data.Type.Equality ((:~:)(Refl))
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(..), conT, cxt, instanceD, location, lookupTypeName, mkName,
- nameBase, normalB, ppr, reify, reifyInstances, standaloneDerivWithStrategyD, valD, varE, varP)
+ (Con(InfixC, NormalC, RecC), Cxt, Dec(DataD, NewtypeD, TySynD, TySynInstD), Info(TyConI), Kind,
+ Loc(loc_module), Name, Q, TyLit(StrTyLit), TySynEqn(..), TyVarBndr(..), Type(..), conT, cxt,
+ instanceD, location, lookupTypeName, mkName, nameBase, normalB, ppr, reify, reifyInstances, valD,
+ varE, varP)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.ReifyMany (reifyManyTyCons)
-import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames)
+import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames, unAppsT, unSigT)
import Morley.Michelson.Text (MText)
import Morley.Michelson.Typed
- (BigMap, BigMapId, ContractPresence(ContractAbsent), ContractRef, EpAddress, HasNoBigMap,
- HasNoContract, HasNoNestedBigMaps, HasNoOp, IsoValue, Notes(..), OpPresence(..), Operation,
- SingI(sing), SingT(..), StorageScope, T(..), ToT, Value, Value'(..), WellTyped,
- checkContractTypePresence, checkOpPresence, withDict)
import Morley.Tezos.Address (Address)
import Morley.Tezos.Core (ChainId, Mutez, Timestamp)
import Morley.Tezos.Crypto
@@ -57,14 +54,25 @@
mangleGenericStrategyConstructors, mangleGenericStrategyFields, reifyDataType)
import Morley.Util.Interpolate (itu)
import Morley.Util.Named hiding (Name)
+import Morley.Util.StubbedProof (stubProof)
import Morley.Util.TH (isTypeAlias, lookupTypeNameOrFail)
{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}
--- $setup
--- >>> import Morley.Michelson.Typed
--- >>> import Morley.Michelson.Text (MText)
+{- $setup
+>>> import Morley.Michelson.Typed
+>>> import Morley.Michelson.Text (MText)
+>>> import Data.Default (def)
+>>> :{
+-- mock definitions for doctests, mirroring those in Lorentz.
+data FollowEntrypointFlag = FollowEntrypoint | NotFollowEntrypoint
+class HasAnnotation a where
+ getAnnotation :: FollowEntrypointFlag -> Notes (ToT a)
+ annOptions :: ()
+:}
+-}
+
----------------------------------------------------------------------------
-- TAsRPC
----------------------------------------------------------------------------
@@ -300,38 +308,58 @@
{- | Derive an RPC representation for a type, as well as instances for
'Generic', 'IsoValue', 'HasRPCRepr' and optionally @HasAnnotation@.
-> data ExampleStorage a b = ExampleStorage
-> { esField1 :: Integer
-> , esField2 :: [BigMap Integer MText]
-> , esField3 :: a
-> }
-> deriving stock Generic
-> deriving anyclass IsoValue
->
-> deriveRPC "ExampleStorage"
+>>> :{
+data ExampleStorage a b = ExampleStorage
+ { esField1 :: Integer
+ , esField2 :: [BigMap Integer MText]
+ , esField3 :: a
+ }
+ deriving stock Generic
+ deriving anyclass IsoValue
+--
+deriveRPC "ExampleStorage"
+:}
Will generate:
-> data ExampleStorageRPC a b = ExampleStorageRPC
-> { esField1RPC :: AsRPC Integer
-> , esField2RPC :: AsRPC [BigMap Integer MText]
-> , esField3RPC :: AsRPC a
-> }
->
-> instance HasRPCRepr a => HasRPCRepr (ExampleStorage a b) where
-> type AsRPC (ExampleStorage a b) = ExampleStorageRPC a b
-> deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (ExampleStorageRPC a b)
-> instance Generic (ExampleStorageRPC a b) where
-> ...
+>>> :i ExampleStorageRPC
+...
+data ExampleStorageRPC a b
+ = ExampleStorageRPC {esField1RPC :: !(AsRPC Integer),
+ esField2RPC :: !(AsRPC [BigMap Integer MText]),
+ esField3RPC :: !(AsRPC a)}
+...
+instance forall a k (b :: k).
+ IsoValue (AsRPC a) =>
+ IsoValue (ExampleStorageRPC a b)
+...
+instance forall a k (b :: k). Generic (ExampleStorageRPC a b)
+...
-When 'droHasAnnotation' is @True@, it will also generate a @HasAnnotation@ (from
-@Lorentz@) instance like:
+>>> :i HasRPCRepr
+...
+instance forall a k (b :: k).
+ HasRPCRepr a =>
+ HasRPCRepr (ExampleStorage a b)
+...
-> instance With [HasAnnotation, HasRPCRepr] ExampleStorage
-> => HasAnnotation ExampleStorageRPC where
-> getAnnotation = notesAsRPC . getAnnotation @ExampleStorage
-> annOptions = annOptions @ExampleStorage
+>>> :i AsRPC
+...
+type instance forall k a (b :: k). AsRPC (ExampleStorage a b)
+ = ExampleStorageRPC a b
+...
+
+When 'droHasAnnotation' is @True@ (the default), it will also generate a
+@HasAnnotation@ (from @Lorentz@) instance like:
+
+>>> :i HasAnnotation
+...
+instance forall a k (b :: k).
+ With '[HasAnnotation, HasRPCRepr] (ExampleStorage a b) =>
+ HasAnnotation (ExampleStorageRPC a b)
+...
+
Note that if the type doesn't contain type variables or only contains phantom
type variables, 'HasRPCRepr' constraint is omitted, as it would be redundant.
@@ -339,16 +367,26 @@
Void types will generate a type synonym instead, e.g.
-> data MyVoidType
-> deriving stock Generic
-> deriving anyclass IsoValue
+>>> :{
+data MyVoidType
+ deriving stock Generic
+ deriving anyclass IsoValue
+--
+deriveRPC "MyVoidType"
+:}
will produce
-> instance HasRPCRepr MyVoidType where
-> type AsRPC MyVoidType = MyVoidTypeRPC
-> type MyVoidTypeRPC = MyVoidType
+>>> :i AsRPC
+...
+type instance AsRPC MyVoidType = MyVoidTypeRPC
+...
+>>> :i MyVoidTypeRPC
+...
+type MyVoidTypeRPC = MyVoidType
+...
+
When 'droRecursive' is @True@, recursively enumerate @data@, @newtype@ and
@type@ declarations, and derive an RPC representation for each type that doesn't
yet have one. This will however silently skip over void types that do not have
@@ -360,17 +398,69 @@
types somewhere. The algorithm isn't smart enough to figure out those don't need
RPC representation and will try to derive it anyway.
-In this example, this will generate an RPC representation for @A@ and @B@, but
-not for @C@ (because we explicitly said we don't want one) or @D@ (because it
-already has one).
+>>> :{
+data B = B deriving (Generic, IsoValue)
+data C = C deriving (Generic, IsoValue)
+data D = D deriving (Generic, IsoValue)
+data E a = E deriving (Generic, IsoValue)
+--
+instance HasRPCRepr D where type AsRPC D = ()
+--
+data A = A B (E C) D deriving (Generic, IsoValue)
+deriveRPCWithOptions "A" def{droRecursive=True, droRecursiveSkipTypes=["C"]}
+:}
-> data B = B
-> data C = C
-> data D = D
-> deriveRPC "D"
->
-> data A = A B C D
-> deriveRPCWithOptions "A" def{droRecursive=True, droRecursiveSkipTypes=["C"]}
+In this example, this will generate an RPC representation for @A@ and @B@,
+
+>>> :i ARPC
+...
+data ARPC = ...
+...
+>>> :i BRPC
+...
+data BRPC = ...
+...
+
+but not for @C@ (because we explicitly said we don't want one) or @D@ (because
+it already has one).
+
+>>> :i CRPC
+...
+... Not in scope: ...
+...
+>>> :i DRPC
+...
+... Not in scope: ...
+...
+
+When using with @droRecursive = False@, if some types do not have 'HasRPCRepr',
+'IsoValue' or 'Generic' instances, but need to, an error will be raised:
+
+>>> :{
+data B = B deriving (Generic, IsoValue)
+data A = A B deriving (Generic, IsoValue)
+--
+deriveRPCWithOptions "A" def{droRecursive = False}
+:}
+...
+... error:
+... Type ... must implement 'HasRPCRepr'.
+
+>>> :{
+data B = B deriving (Generic, IsoValue)
+data A = A B deriving (Generic, IsoValue)
+--
+deriveRPCWithOptions "B" def{droRecursive = False}
+deriveRPCWithOptions "A" def{droRecursive = False}
+:}
+
+>>> :i AsRPC
+...
+type instance AsRPC B = BRPC ...
+type instance AsRPC A = ARPC ...
+...
+
+This check isn't very smart, so it might miss some corner cases.
-}
deriveRPCWithOptions :: String -> DeriveRPCOptions -> Q [Dec]
deriveRPCWithOptions typeStr opts@DeriveRPCOptions{droRecursive}
@@ -448,10 +538,9 @@
, pure $ TySynD typeNameRPC [] $ ConT typeName
]
else do
- -- TODO [#722]: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`
- -- Print user-friendly error msg if it doesn't.
constructorsRPC <- traverse convertConstructor constructors
fieldTypes <- getFieldTypes constructors
+ forM_ fieldTypes checkInstanceForFieldTy
fieldTypesRPC <- getFieldTypes constructorsRPC
-- Note: we can't use `makeRep0Inline` to derive a `Rep` instance for `derivedTypeRPC`
@@ -484,6 +573,37 @@
]
where
+ checkInstanceForFieldTy fieldTy =
+ reifyInstances ''HasRPCRepr [fieldTy] >>= \case
+ [] | droRecursive -> pass
+ | otherwise
+ -> fail $ "Type '" <> show (ppr fieldTy) <> "' must implement 'HasRPCRepr'."
+ [TH.InstanceD _ cs (ConT n' `AppT` ty) _] | n' == ''HasRPCRepr -> do
+ let tyMap = Map.fromList $ filter isVarMapping $
+ zip (unSigT <$> unAppsT ty) (unSigT <$> unAppsT fieldTy)
+ isVarMapping = \case
+ (VarT{}, _) -> True
+ _ -> False
+ instantiatedConstraints =
+ map (everywhere (mkT substVar)) . concatMap getHasRPCReprTys $
+ everywhere (mkT unSigT) cs
+ getHasRPCReprTys = \case
+ ConT n `AppT` x | n == ''HasRPCRepr -> [x]
+ ConT n `AppT` (PromotedConsT `AppT` ConT n2 `AppT` PromotedNilT) `AppT` xs
+ | n == ''Each, n2 == ''HasRPCRepr -> flip unfoldr xs \case
+ PromotedNilT -> Nothing
+ PromotedConsT `AppT` x `AppT` xs' -> Just (x, xs')
+ _ -> Nothing
+ _ -> [] -- we could error here and above, but for safety we don't
+ substVar = \case
+ v@VarT{} | Just s <- Map.lookup v tyMap -> s
+ x -> x
+ forM_ instantiatedConstraints checkInstanceForFieldTy
+ [d] -> fail $ "Unexpected instance for " <> show (ppr fieldTy) <> ": " <> show (ppr d)
+ -- most likely fieldTy is a tyvar, if not, GHC will complain about
+ -- duplicate instances anyway
+ (_:_:_) -> pass
+
-- Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@.
convertFieldType :: Type -> Type
convertFieldType tp = ConT ''AsRPC `AppT` tp
@@ -583,13 +703,13 @@
-- Given the type @Foo a b = Foo (Bar a)@, generate an 'IsoValue' instance like:
--
- -- > deriving anyclass instance IsoValue (AsRPC (Bar a)) => IsoValue (FooRPC a b)
+ -- > instance IsoValue (AsRPC (Bar a)) => IsoValue (FooRPC a b)
--
-- Note that if a type variable @t@ is a phantom type variable, then no @IsoValue (AsRPC t)@
-- constraint is generated for it.
mkIsoValueInstance :: [Type] -> Type -> Q [Dec]
mkIsoValueInstance fieldTypes tp =
- one <$> standaloneDerivWithStrategyD (Just AnyclassStrategy) constraints [t|IsoValue $(pure tp)|]
+ one <$> instanceD constraints [t|IsoValue $(pure tp)|] []
where
constraints :: Q Cxt
constraints =
@@ -676,52 +796,45 @@
--
-- Throws an error if it finds a big_map without an ID.
valueAsRPC :: HasCallStack => Value t -> Value (TAsRPC t)
-valueAsRPC v =
- case v of
- VKey {} -> v
- VUnit {} -> v
- VSignature {} -> v
- VChainId {} -> v
- VChest {} -> v
- VChestKey {} -> v
- VOption (vMaybe :: Maybe (Value elem)) ->
- withDict (rpcSingIEvi @elem) $
- VOption $ valueAsRPC <$> vMaybe
- VList (vList :: [Value elem]) ->
- withDict (rpcSingIEvi @elem) $
- VList $ valueAsRPC <$> vList
- VSet {} -> v
- VOp {} -> v
- VContract {} -> v
- VTicket {} -> v
- VPair (x, y) -> VPair (valueAsRPC x, valueAsRPC y)
- VOr (vEither :: Either (Value l) (Value r)) ->
- withDict (rpcSingIEvi @l *** rpcSingIEvi @r) $
- case vEither of
- Right r -> VOr (Right (valueAsRPC r))
- Left l -> VOr (Left (valueAsRPC l))
- VLam {} -> v
- VMap (vMap :: Map (Value k) (Value v)) ->
- withDict (rpcSingIEvi @v) $
- VMap $ valueAsRPC <$> vMap
- VBigMap (Just bmId) _ -> VNat bmId
- VBigMap Nothing _ ->
- error $ unlines
- [ "Expected all big_maps to have an ID, but at least one big_map didn't."
- , "This is most likely a bug."
- ]
- VInt {} -> v
- VNat {} -> v
- VString {} -> v
- VBytes {} -> v
- VMutez {} -> v
- VBool {} -> v
- VKeyHash {} -> v
- VTimestamp {} -> v
- VAddress {} -> v
- VBls12381Fr {} -> v
- VBls12381G1 {} -> v
- VBls12381G2 {} -> v
+valueAsRPC v = case v of
+ VKey {} -> v
+ VUnit {} -> v
+ VSignature {} -> v
+ VChainId {} -> v
+ VChest {} -> v
+ VChestKey {} -> v
+ VOption (vMaybe :: Maybe (Value elem)) ->
+ VOption (valueAsRPC <$> vMaybe) \\ rpcSingIEvi @elem
+ VList (vList :: [Value elem]) ->
+ VList (valueAsRPC <$> vList) \\ rpcSingIEvi @elem
+ VSet {} -> v
+ VOp {} -> v
+ VContract {} -> v
+ VTicket {} -> v
+ VPair (x, y) -> VPair (valueAsRPC x, valueAsRPC y)
+ VOr (vEither :: Either (Value l) (Value r)) ->
+ VOr (bimap valueAsRPC valueAsRPC vEither) \\ rpcSingIEvi @l \\ rpcSingIEvi @r
+ VLam {} -> v
+ VMap (vMap :: Map (Value k) (Value v)) ->
+ VMap (valueAsRPC <$> vMap) \\ rpcSingIEvi @v
+ VBigMap (Just bmId) _ -> VNat bmId
+ VBigMap Nothing _ ->
+ error $ unlines
+ [ "Expected all big_maps to have an ID, but at least one big_map didn't."
+ , "This is most likely a bug."
+ ]
+ VInt {} -> v
+ VNat {} -> v
+ VString {} -> v
+ VBytes {} -> v
+ VMutez {} -> v
+ VBool {} -> v
+ VKeyHash {} -> v
+ VTimestamp {} -> v
+ VAddress {} -> v
+ VBls12381Fr {} -> v
+ VBls12381G1 {} -> v
+ VBls12381G2 {} -> v
-- | Replaces all bigmap IDs with their corresponding bigmap values.
-- This is the inverse of `valueAsRPC`.
@@ -778,42 +891,41 @@
-- | Replace all @big_map@ annotations in a value with @nat@ annotations.
notesAsRPC :: Notes t -> Notes (TAsRPC t)
-notesAsRPC notes =
- case notes of
- NTKey {} -> notes
- NTUnit {} -> notes
- NTSignature {} -> notes
- NTChainId {} -> notes
- NTChest {} -> notes
- NTChestKey {} -> notes
- NTOption typeAnn elemNotes -> NTOption typeAnn $ notesAsRPC elemNotes
- NTList typeAnn elemNotes -> NTList typeAnn $ notesAsRPC elemNotes
- NTSet {} -> notes
- NTOperation {} -> notes
- NTContract {} -> notes
- NTTicket {} -> notes
- NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 notes1 notes2 ->
- NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 (notesAsRPC notes1) (notesAsRPC notes2)
- NTOr typeAnn fieldAnn1 fieldAnn2 notes1 notes2 ->
- NTOr typeAnn fieldAnn1 fieldAnn2 (notesAsRPC notes1) (notesAsRPC notes2)
- NTLambda {} -> notes
- NTMap typeAnn keyAnns valueNotes -> NTMap typeAnn keyAnns (notesAsRPC valueNotes)
- NTBigMap typeAnn _ _ -> NTNat typeAnn
- NTInt {} -> notes
- NTNat {} -> notes
- NTString {} -> notes
- NTBytes {} -> notes
- NTMutez {} -> notes
- NTBool {} -> notes
- NTKeyHash {} -> notes
- NTTimestamp {} -> notes
- NTAddress {} -> notes
- NTBls12381Fr {} -> notes
- NTBls12381G1 {} -> notes
- NTBls12381G2 {} -> notes
- NTNever {} -> notes
- NTSaplingState {} -> notes
- NTSaplingTransaction {} -> notes
+notesAsRPC notes = case notes of
+ NTKey {} -> notes
+ NTUnit {} -> notes
+ NTSignature {} -> notes
+ NTChainId {} -> notes
+ NTChest {} -> notes
+ NTChestKey {} -> notes
+ NTOption typeAnn elemNotes -> NTOption typeAnn $ notesAsRPC elemNotes
+ NTList typeAnn elemNotes -> NTList typeAnn $ notesAsRPC elemNotes
+ NTSet {} -> notes
+ NTOperation {} -> notes
+ NTContract {} -> notes
+ NTTicket {} -> notes
+ NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 notes1 notes2 ->
+ NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 (notesAsRPC notes1) (notesAsRPC notes2)
+ NTOr typeAnn fieldAnn1 fieldAnn2 notes1 notes2 ->
+ NTOr typeAnn fieldAnn1 fieldAnn2 (notesAsRPC notes1) (notesAsRPC notes2)
+ NTLambda {} -> notes
+ NTMap typeAnn keyAnns valueNotes -> NTMap typeAnn keyAnns (notesAsRPC valueNotes)
+ NTBigMap typeAnn _ _ -> NTNat typeAnn
+ NTInt {} -> notes
+ NTNat {} -> notes
+ NTString {} -> notes
+ NTBytes {} -> notes
+ NTMutez {} -> notes
+ NTBool {} -> notes
+ NTKeyHash {} -> notes
+ NTTimestamp {} -> notes
+ NTAddress {} -> notes
+ NTBls12381Fr {} -> notes
+ NTBls12381G1 {} -> notes
+ NTBls12381G2 {} -> notes
+ NTNever {} -> notes
+ NTSaplingState {} -> notes
+ NTSaplingTransaction {} -> notes
----------------------------------------------------------------------------
-- Entailments
@@ -821,58 +933,50 @@
-- | A proof that if a singleton exists for @t@,
-- then so it does for @TAsRPC t@.
-rpcSingIEvi :: forall (t :: T). SingI t :- SingI (TAsRPC t)
-rpcSingIEvi =
- Sub $
- case sing @t of
- STKey -> Dict
- STUnit {} -> Dict
- STSignature {} -> Dict
- STChainId {} -> Dict
- STChest {} -> Dict
- STChestKey {} -> Dict
- STOption (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem
- STList (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem
- STSet (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem
- STOperation {} -> Dict
- STContract {} -> Dict
- STTicket {} -> Dict
- STPair (sa :: Sing a) (sb :: Sing b) ->
- withSingI sa $ withSingI sb $
- Dict \\ rpcSingIEvi @a \\ rpcSingIEvi @b
- STOr (sl :: Sing l) (sr :: Sing r) ->
- withSingI sl $ withSingI sr $
- Dict \\ rpcSingIEvi @l \\ rpcSingIEvi @r
- STLambda {} -> Dict
- STMap (sk :: Sing k) (sv :: Sing v) ->
- withSingI sk $ withSingI sv $
- Dict \\ rpcSingIEvi @k \\ rpcSingIEvi @v
- STBigMap {} -> Dict
- STInt {} -> Dict
- STNat {} -> Dict
- STString {} -> Dict
- STBytes {} -> Dict
- STMutez {} -> Dict
- STBool {} -> Dict
- STKeyHash {} -> Dict
- STBls12381Fr {} -> Dict
- STBls12381G1 {} -> Dict
- STBls12381G2 {} -> Dict
- STTimestamp {} -> Dict
- STAddress {} -> Dict
- STNever {} -> Dict
- STSaplingState _ -> Dict
- STSaplingTransaction _ -> Dict
+rpcSingIEvi :: forall t. SingI t => Dict (SingI (TAsRPC t))
+rpcSingIEvi = withSingI (rpcSing $ sing @t) Dict
+rpcSing :: Sing t -> Sing (TAsRPC t)
+rpcSing st = case st of
+ STKey -> st
+ STUnit {} -> st
+ STSignature {} -> st
+ STChainId {} -> st
+ STChest {} -> st
+ STChestKey {} -> st
+ STOption s -> STOption $ rpcSing s
+ STList s -> STList $ rpcSing s
+ STSet{} -> st
+ STOperation {} -> st
+ STContract {} -> st
+ STTicket {} -> st
+ STPair sa sb -> STPair (rpcSing sa) (rpcSing sb)
+ STOr sl sr -> STOr (rpcSing sl) (rpcSing sr)
+ STLambda {} -> st
+ STMap sk sv -> STMap sk (rpcSing sv)
+ STBigMap {} -> STNat
+ STInt {} -> st
+ STNat {} -> st
+ STString {} -> st
+ STBytes {} -> st
+ STMutez {} -> st
+ STBool {} -> st
+ STKeyHash {} -> st
+ STBls12381Fr {} -> st
+ STBls12381G1 {} -> st
+ STBls12381G2 {} -> st
+ STTimestamp {} -> st
+ STAddress {} -> st
+ STNever {} -> st
+ STSaplingState _ -> st
+ STSaplingTransaction _ -> st
+
-- | A proof that if @t@ is well-typed, then @TAsRPC t@ is also well-typed.
-rpcWellTypedEvi :: forall (t :: T). WellTyped t => WellTyped t :- WellTyped (TAsRPC t)
-rpcWellTypedEvi = rpcWellTypedEvi' sing
+rpcWellTypedEvi :: forall t. WellTyped t => Dict (WellTyped (TAsRPC t))
+rpcWellTypedEvi = rpcWellTypedEvi' $ sing @t
-rpcWellTypedEvi'
- :: WellTyped t
- => Sing t
- -> WellTyped t :- WellTyped (TAsRPC t)
-rpcWellTypedEvi' sng = Sub $ case sng of
+rpcWellTypedEvi' :: WellTyped t => Sing t -> Dict (WellTyped (TAsRPC t))
+rpcWellTypedEvi' sng = case sng of
STKey -> Dict
STUnit {} -> Dict
STSignature {} -> Dict
@@ -907,187 +1011,113 @@
STSaplingTransaction _ -> Dict
-- | A proof that if @t@ does not contain any operations, then neither does @TAsRPC t@.
-rpcHasNoOpEvi :: forall (t :: T). (SingI t, HasNoOp t) => HasNoOp t :- HasNoOp (TAsRPC t)
-rpcHasNoOpEvi = rpcHasNoOpEvi' sing
-
-rpcHasNoOpEvi'
- :: HasNoOp t
- => Sing t
- -> HasNoOp t :- HasNoOp (TAsRPC t)
-rpcHasNoOpEvi' sng = Sub $ case sng of
- STKey -> Dict
- STUnit {} -> Dict
- STSignature {} -> Dict
- STChainId {} -> Dict
- STChest {} -> Dict
- STChestKey {} -> Dict
- STOption s -> Dict \\ rpcHasNoOpEvi' s
- STList s -> Dict \\ rpcHasNoOpEvi' s
- STSet s -> Dict \\ rpcHasNoOpEvi' s
- STContract {} -> Dict
- STTicket {} -> Dict
- STPair sa sb -> case checkOpPresence sa of
- OpAbsent -> Dict \\ rpcHasNoOpEvi' sa \\ rpcHasNoOpEvi' sb
- STOr sl sr -> case checkOpPresence sl of
- OpAbsent -> Dict \\ rpcHasNoOpEvi' sl \\ rpcHasNoOpEvi' sr
- STLambda {} -> Dict
- STMap _ sv -> case checkOpPresence sv of
- OpAbsent -> Dict \\ rpcHasNoOpEvi' sv
- STBigMap {} -> Dict
- STInt {} -> Dict
- STNat {} -> Dict
- STString {} -> Dict
- STBytes {} -> Dict
- STMutez {} -> Dict
- STBool {} -> Dict
- STKeyHash {} -> Dict
- STBls12381Fr {} -> Dict
- STBls12381G1 {} -> Dict
- STBls12381G2 {} -> Dict
- STTimestamp {} -> Dict
- STAddress {} -> Dict
- STNever {} -> Dict
- STSaplingState {} -> Dict
- STSaplingTransaction {} -> Dict
+rpcHasNoOpEvi :: forall (t :: T). (SingI t, ForbidOp t) => Dict (ForbidOp (TAsRPC t))
+rpcHasNoOpEvi = Dict \\ rpcHasNoTEvi @t SPSOp
-- | A proof that @AsRPC (Value t)@ does not contain big_maps.
-rpcHasNoBigMapEvi :: forall (t :: T). SingI t => Dict (HasNoBigMap (TAsRPC t))
-rpcHasNoBigMapEvi = rpcHasNoBigMapEvi' (sing @t)
-
-rpcHasNoBigMapEvi' :: Sing t -> Dict (HasNoBigMap (TAsRPC t))
-rpcHasNoBigMapEvi' = \case
- STKey -> Dict
- STUnit {} -> Dict
- STSignature {} -> Dict
- STChainId {} -> Dict
- STChest {} -> Dict
- STChestKey {} -> Dict
- STOption s -> Dict \\ rpcHasNoBigMapEvi' s
- STList s -> Dict \\ rpcHasNoBigMapEvi' s
- STSet s -> Dict \\ rpcHasNoBigMapEvi' s
- STOperation {} -> Dict
- STContract {} -> Dict
- STTicket {} -> Dict
- STPair sa sb -> Dict \\ rpcHasNoBigMapEvi' sa \\ rpcHasNoBigMapEvi' sb
- STOr sl sr -> Dict \\ rpcHasNoBigMapEvi' sl \\ rpcHasNoBigMapEvi' sr
- STLambda {} -> Dict
- STMap sk sv -> Dict \\ rpcHasNoBigMapEvi' sk \\ rpcHasNoBigMapEvi' sv
- STBigMap {} -> Dict
- STInt {} -> Dict
- STNat {} -> Dict
- STString {} -> Dict
- STBytes {} -> Dict
- STMutez {} -> Dict
- STBool {} -> Dict
- STKeyHash {} -> Dict
- STBls12381Fr {} -> Dict
- STBls12381G1 {} -> Dict
- STBls12381G2 {} -> Dict
- STTimestamp {} -> Dict
- STAddress {} -> Dict
- STNever {} -> Dict
- STSaplingState {} -> Dict
- STSaplingTransaction {} -> Dict
+rpcHasNoBigMapEvi :: forall (t :: T). (SingI t, ForbidBigMap t) => Dict (ForbidBigMap (TAsRPC t))
+rpcHasNoBigMapEvi = Dict \\ rpcHasNoTEvi @t SPSBigMap
--- | A proof that @AsRPC (Value t)@ does not contain big_maps.
+-- | A proof that @AsRPC (Value t)@ does not contain nested big_maps.
rpcHasNoNestedBigMapsEvi
- :: forall (t :: T).
- SingI t
- => Dict (HasNoNestedBigMaps (TAsRPC t))
-rpcHasNoNestedBigMapsEvi = rpcHasNoNestedBigMapsEvi' (sing @t)
+ :: forall (t :: T). (SingI t, ForbidNestedBigMaps t) => Dict (ForbidNestedBigMaps (TAsRPC t))
+rpcHasNoNestedBigMapsEvi = Dict \\ rpcHasNoTEvi @t SPSNestedBigMaps
-rpcHasNoNestedBigMapsEvi' :: Sing t -> Dict (HasNoNestedBigMaps (TAsRPC t))
-rpcHasNoNestedBigMapsEvi' = \case
- STKey -> Dict
- STUnit {} -> Dict
- STSignature {} -> Dict
- STChainId {} -> Dict
- STChest {} -> Dict
- STChestKey {} -> Dict
- STOption s -> Dict \\ rpcHasNoNestedBigMapsEvi' s
- STList s -> Dict \\ rpcHasNoNestedBigMapsEvi' s
- STSet s -> Dict \\ rpcHasNoNestedBigMapsEvi' s
- STOperation {} -> Dict
- STContract {} -> Dict
- STTicket {} -> Dict
- STPair sa sb ->
- Dict \\ rpcHasNoNestedBigMapsEvi' sa \\ rpcHasNoNestedBigMapsEvi' sb
- STOr sl sr ->
- Dict \\ rpcHasNoNestedBigMapsEvi' sl \\ rpcHasNoNestedBigMapsEvi' sr
- STLambda {} -> Dict
- STMap sk sv ->
- Dict \\ rpcHasNoNestedBigMapsEvi' sk \\ rpcHasNoNestedBigMapsEvi' sv
- STBigMap {} -> Dict
- STInt {} -> Dict
- STNat {} -> Dict
- STString {} -> Dict
- STBytes {} -> Dict
- STMutez {} -> Dict
- STBool {} -> Dict
- STKeyHash {} -> Dict
- STBls12381Fr {} -> Dict
- STBls12381G1 {} -> Dict
- STBls12381G2 {} -> Dict
- STTimestamp {} -> Dict
- STAddress {} -> Dict
- STNever {} -> Dict
- STSaplingState {} -> Dict
- STSaplingTransaction {} -> Dict
+-- | A proof that @AsRPC (Value t)@ does not contain some type defined by a predicate.
+rpcHasNoTEvi
+ :: forall (t :: T) p.
+ (SingI t, ContainsT p t ~ 'False)
+ => Sing p -> (ContainsT p (TAsRPC t) :~: 'False)
+rpcHasNoTEvi sp = rpcHasNoTEvi' sp (sing @t)
+rpcHasNoTEvi'
+ :: forall t p. (ContainsT p t ~ 'False)
+ => Sing p -> Sing t -> ContainsT p (TAsRPC t) :~: 'False
+rpcHasNoTEvi' ps ts = stubProof case ts of
+ STKey -> Refl
+ STUnit {} -> Refl
+ STSignature {} -> Refl
+ STChainId {} -> Refl
+ STChest {} -> Refl
+ STChestKey {} -> Refl
+ STOption s -> Refl \\ go s
+ STList s -> case ps of
+ SPSOp -> Refl \\ go s
+ SPSContract -> Refl \\ go s
+ SPSTicket -> Refl \\ go s
+ SPSBigMap -> Refl \\ go s
+ SPSNestedBigMaps -> Refl \\ go s
+ SPSSaplingState -> Refl \\ go s
+ STSet _ -> case ps of
+ SPSOp -> Refl
+ SPSContract -> Refl
+ SPSTicket -> Refl
+ SPSBigMap -> Refl
+ SPSNestedBigMaps -> Refl
+ SPSSaplingState -> Refl
+ STOperation {} -> case ps of
+ SPSContract -> Refl
+ SPSTicket -> Refl
+ SPSBigMap -> Refl
+ SPSNestedBigMaps -> Refl
+ SPSSaplingState -> Refl
+ STContract {} -> case ps of
+ SPSOp -> Refl
+ SPSTicket -> Refl
+ SPSBigMap -> Refl
+ SPSNestedBigMaps -> Refl
+ SPSSaplingState -> Refl
+ STTicket _ -> case ps of
+ SPSOp -> Refl
+ SPSContract -> Refl
+ SPSBigMap -> Refl
+ SPSNestedBigMaps -> Refl
+ SPSSaplingState -> Refl
+ STPair sa sb -> deMorganForbidT ps sa sb $ Refl \\ go sa \\ go sb
+ STOr sl sr -> deMorganForbidT ps sl sr $ Refl \\ go sl \\ go sr
+ STLambda {} -> Refl
+ STMap sk sv -> case ps of
+ SPSOp -> deMorganForbidT ps sk sv $ Refl \\ go sv
+ SPSContract -> deMorganForbidT ps sk sv $ Refl \\ go sv
+ SPSTicket -> deMorganForbidT ps sk sv $ Refl \\ go sv
+ SPSBigMap -> deMorganForbidT ps sk sv $ Refl \\ go sv
+ SPSNestedBigMaps -> deMorganForbidT ps sk sv $ Refl \\ go sv
+ SPSSaplingState -> deMorganForbidT ps sk sv $ Refl \\ go sv
+ STBigMap {} -> Refl
+ STInt {} -> Refl
+ STNat {} -> Refl
+ STString {} -> Refl
+ STBytes {} -> Refl
+ STMutez {} -> Refl
+ STBool {} -> Refl
+ STKeyHash {} -> Refl
+ STBls12381Fr {} -> Refl
+ STBls12381G1 {} -> Refl
+ STBls12381G2 {} -> Refl
+ STTimestamp {} -> Refl
+ STAddress {} -> Refl
+ STNever {} -> Refl
+ STSaplingState {} -> case ps of
+ SPSOp -> Refl
+ SPSTicket -> Refl
+ SPSContract -> Refl
+ SPSBigMap -> Refl
+ SPSNestedBigMaps -> Refl
+ STSaplingTransaction {} -> Refl
+ where
+ go :: (ContainsT p t' ~ 'False) => Sing t' -> ContainsT p (TAsRPC t') :~: 'False
+ go = rpcHasNoTEvi' ps
+
-- | A proof that if @t@ does not contain any contract values, then neither does @TAsRPC t@.
rpcHasNoContractEvi
- :: forall (t :: T).
- (SingI t, HasNoContract t)
- => HasNoContract t :- HasNoContract (TAsRPC t)
-rpcHasNoContractEvi = rpcHasNoContractEvi' sing
-
-rpcHasNoContractEvi'
- :: HasNoContract t
- => Sing t
- -> HasNoContract t :- HasNoContract (TAsRPC t)
-rpcHasNoContractEvi' sng = Sub $ case sng of
- STKey -> Dict
- STUnit {} -> Dict
- STSignature {} -> Dict
- STChainId {} -> Dict
- STChest {} -> Dict
- STChestKey {} -> Dict
- STOption s -> Dict \\ rpcHasNoContractEvi' s
- STList s -> Dict \\ rpcHasNoContractEvi' s
- STSet _ -> Dict
- STOperation {} -> Dict
- STTicket {} -> Dict
- STPair sa sb -> case checkContractTypePresence sa of
- ContractAbsent ->
- Dict \\ rpcHasNoContractEvi' sa \\ rpcHasNoContractEvi' sb
- STOr sl sr -> case checkContractTypePresence sl of
- ContractAbsent ->
- Dict \\ rpcHasNoContractEvi' sl \\ rpcHasNoContractEvi' sr
- STLambda {} -> Dict
- STMap _ sv -> Dict \\ rpcHasNoContractEvi' sv
- STBigMap {} -> Dict
- STInt {} -> Dict
- STNat {} -> Dict
- STString {} -> Dict
- STBytes {} -> Dict
- STMutez {} -> Dict
- STBool {} -> Dict
- STKeyHash {} -> Dict
- STBls12381Fr {} -> Dict
- STBls12381G1 {} -> Dict
- STBls12381G2 {} -> Dict
- STTimestamp {} -> Dict
- STAddress {} -> Dict
- STNever {} -> Dict
- STSaplingState {} -> Dict
- STSaplingTransaction {} -> Dict
+ :: forall (t :: T). (SingI t, ForbidContract t) => Dict (ForbidContract (TAsRPC t))
+rpcHasNoContractEvi = Dict \\ rpcHasNoTEvi @t SPSContract
-- | A proof that if @t@ is a valid storage type, then so is @TAsRPC t@.
-rpcStorageScopeEvi :: forall (t :: T). StorageScope t :- StorageScope (TAsRPC t)
-rpcStorageScopeEvi =
- Sub $ Dict
- \\ rpcSingIEvi @t
- \\ rpcHasNoOpEvi @t
- \\ rpcHasNoNestedBigMapsEvi @t
- \\ rpcHasNoContractEvi @t
- \\ rpcWellTypedEvi @t
+rpcStorageScopeEvi :: forall (t :: T). StorageScope t => Dict (StorageScope (TAsRPC t))
+rpcStorageScopeEvi = Dict
+ \\ rpcSingIEvi @t
+ \\ rpcHasNoOpEvi @t
+ \\ rpcHasNoNestedBigMapsEvi @t
+ \\ rpcHasNoContractEvi @t
+ \\ rpcWellTypedEvi @t
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
@@ -16,7 +16,6 @@
import Data.Binary.Get qualified as Bi
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
-import Data.Sequence qualified as Seq
import Unsafe qualified (fromIntegral)
import Morley.Micheline.Binary.Internal
@@ -54,9 +53,7 @@
buildList = foldMap buildExpr
buildPrim :: MichelinePrimitive -> Bi.Builder
-buildPrim (MichelinePrimitive p) = case Seq.elemIndexL p michelsonPrimitive of
- Nothing -> error $ "unknown Michelson/Micheline primitive: " <> p
- Just ix -> buildWord8 (Unsafe.fromIntegral @Int @Word8 ix)
+buildPrim = buildWord8 . Unsafe.fromIntegral @Int @Word8 . fromEnum
buildAnnotationList :: [Annotation] -> Bi.Builder
buildAnnotationList listAnn = buildDynamic buildText (DynamicSize $ unwords . fmap annotToText $ listAnn)
@@ -92,10 +89,8 @@
getList = many getExpr
getPrim :: Bi.Get MichelinePrimitive
-getPrim =
- Bi.getWord8 >>= \ix -> case Seq.lookup (fromIntegral ix) michelsonPrimitive of
- Nothing -> fail "unknown Michelson/Micheline opcode"
- Just str -> pure $ MichelinePrimitive str
+getPrim = maybe (fail "unknown Michelson/Micheline opcode") pure . toEnumSafe . fromIntegral
+ =<< Bi.getWord8
getAnnotationList :: Bi.Get [Annotation]
getAnnotationList = mapM annotFromText . words . unDynamicSize =<< (getDynamic getText)
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
@@ -14,1046 +14,945 @@
import Control.Lens ((<>~))
import Data.Bits (Bits)
-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 (TypeCheckOptions(..), typeCheckingWith)
-import Morley.Michelson.TypeCheck.Instr (typeCheckValue)
-import Morley.Michelson.Typed
- (Contract, HasNoOp, Instr, LambdaCode'(..), 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
- Untyped.ValueLamRec ops -> expressionPrim' "Lambda_rec" [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 t) []
- 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.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 :: Untyped.T -> [Expression]
- rightCombedPairToList t =
- let go ty (fa, va)
- | Ty (Untyped.TPair faL faR vaL vaR l r) ta <- ty
- , ta == noAnn, fa == noAnn, va == noAnn
- = toExpression l `addAnns` mkAnns [] [faL] [vaL] : go r (faR, vaR)
- | otherwise
- = one $ toExpression ty `addAnns` mkAnns [] [fa] [va]
- in go (Ty t noAnn) (noAnn, noAnn)
-
-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
-
--- Note: On adding new expressions here, you must also add the symmetric (reading) case
--- to FromExp x (InstrAbstract op) as well.
-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]
- LAMBDA_REC va tyin tyout ops ->
- expressionPrim' "LAMBDA_REC" [ 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]
- NAT va -> expressionPrim' "NAT" [] $ mkAnns [] [] [va]
- BYTES va -> expressionPrim' "BYTES" [] $ mkAnns [] [] [va]
- VIEW va n t -> expressionPrim' "VIEW" [toExpression n, toExpression t] $
- mkAnns [] [] [va]
- SELF va fa -> expressionPrim' "SELF" [] $ mkAnns [] [fa] [va]
- 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]
- TICKET_DEPRECATED va -> expressionPrim' "TICKET_DEPRECATED" [] $ 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
- EMIT va tag ty -> expressionPrim' "EMIT" (toExpression <$> maybeToList ty) $ mkAnns [] [tag] [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) $
- 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
- ExpPrim' _ "Lambda_rec" [args] [] -> fmap Untyped.ValueLamRec $
- fromExp args >>= maybeToRight (FromExpError e "Expected at least one instruction") . nonEmpty
- 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
-
--- Note: On adding new expressions here, you must also add the symmetric (writing) case
--- to ToExpression as well.
-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' _ "LAMBDA_REC" [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_REC 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' _ "NAT" [] anns -> mkInstrWithVarAnn NAT anns
- ExpPrim' _ "BYTES" [] anns -> mkInstrWithVarAnn BYTES anns
- ExpPrim' _ "VIEW" [name, t] _ -> do
- let va = firstAnn @VarTag annSet
- name' <- fromExp @x @ViewName name
- 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_DEPRECATED" [] anns ->
- mkInstrWithVarAnn TICKET_DEPRECATED anns
- 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
- ExpPrim' _ "EMIT" mty _ -> do
- checkAnnsCount e annSet (0, 1, 1)
- let tag = firstAnn @FieldTag annSet
- va = firstAnn @VarTag annSet
- ty' <- maybe (pure Nothing) (fmap Just . fromExp @x @Ty) $ listToMaybe mty
- pure $ EMIT va tag ty'
- _ -> 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" [] [] ->
- Left $ FromExpError e "Transaction rollups are not supported"
- 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 (LambdaCode instr) -> pure $ rfAnyInstr instr
- VLam LambdaCodeRec{} -> Left $ FromExpError expr
- "Expected block of code, found Lambda_rec"
-
-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"
+import Data.Singletons (SingI(..), demote, fromSing)
+import Fmt (Buildable(..), fillSepF, indentF, nameF, pretty, punctuateF, unlinesF, (++|), (|++))
+
+import Morley.Micheline.Expression
+import Morley.Michelson.Text (mkMText, unMText)
+import Morley.Michelson.TypeCheck (TcError, TypeCheckOptions(..), typeCheckingWith)
+import Morley.Michelson.TypeCheck.Instr (typeCheckValue)
+import Morley.Michelson.Typed
+ (Contract, ForbidOp, Instr, LambdaCode'(..), Notes(..), T(..), Value, Value'(..), fromUType,
+ mkUType, rfAnyInstr, toUType)
+import Morley.Michelson.Typed.Convert
+ (convertContractOptimized, instrToOpsOptimized, untypeValueOptimized)
+import Morley.Michelson.Untyped qualified as Untyped
+import Morley.Michelson.Untyped.Annotation
+ (AnnotationSet(..), FieldAnn, FieldTag, RootAnn, TypeAnn, TypeTag, VarAnn, VarTag, annsCount,
+ firstAnn, noAnn, secondAnn)
+import Morley.Michelson.Untyped.Contract (ContractBlock(..), ContractBlockError, orderContractBlock)
+import Morley.Michelson.Untyped.Instr (ExpandedInstr, ExpandedOp(..), InstrAbstract(..))
+import Morley.Michelson.Untyped.Type (Ty(..))
+import Morley.Michelson.Untyped.View
+import Morley.Util.MismatchError
+
+-- ToExpression
+----------------------------------------------------------------------------
+
+-- | Type class that provides an ability to convert
+-- something to Micheline Expression.
+class ToExpression a where
+ toExpression :: a -> Expression
+
+instance ForbidOp 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' Prim_Unit [] []
+ Untyped.ValueTrue -> expressionPrim' Prim_True [] []
+ Untyped.ValueFalse -> expressionPrim' Prim_False [] []
+ Untyped.ValuePair l r ->
+ expressionPrim' Prim_Pair [toExpression l, toExpression r] []
+ Untyped.ValueLeft v -> expressionPrim' Prim_Left [toExpression v] []
+ Untyped.ValueRight v -> expressionPrim' Prim_Right [toExpression v] []
+ Untyped.ValueSome v -> expressionPrim' Prim_Some [toExpression v] []
+ Untyped.ValueNone -> expressionPrim' Prim_None [] []
+ Untyped.ValueNil -> expressionSeq []
+ Untyped.ValueSeq vs -> toExpression vs
+ Untyped.ValueMap elts -> toExpression $ eltToExpr <$> elts
+ Untyped.ValueLambda ops -> toExpression ops
+ Untyped.ValueLamRec ops -> expressionPrim' Prim_Lambda_rec [toExpression ops] []
+ where
+ eltToExpr :: Untyped.Elt [] ExpandedOp -> Expression
+ eltToExpr (Untyped.Elt l r) = expressionPrim' Prim_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' Prim_key [] []
+ Untyped.TUnit -> expressionPrim' Prim_unit [] []
+ Untyped.TSignature -> expressionPrim' Prim_signature [] []
+ Untyped.TChainId -> expressionPrim' Prim_chain_id [] []
+ Untyped.TOption arg -> expressionPrim' Prim_option [toExpression arg] []
+ Untyped.TList arg -> expressionPrim' Prim_list [toExpression arg] []
+ Untyped.TSet arg -> expressionPrim' Prim_set [toExpression arg] []
+ Untyped.TOperation -> expressionPrim' Prim_operation [] []
+ Untyped.TContract arg -> expressionPrim' Prim_contract [toExpression arg] []
+ Untyped.TTicket arg -> expressionPrim' Prim_ticket [toExpression arg] []
+ t@Untyped.TPair{} -> expressionPrim' Prim_pair (rightCombedPairToList t) []
+ Untyped.TOr fa1 fa2 l r ->
+ let exprL = addTrimmedAnns (toExpression l) [] [fa1] []
+ exprR = addTrimmedAnns (toExpression r) [] [fa2] []
+ in expressionPrim' Prim_or [exprL, exprR] []
+ Untyped.TLambda inp out ->
+ expressionPrim' Prim_lambda [toExpression inp, toExpression out] []
+ Untyped.TMap k v ->
+ expressionPrim' Prim_map [toExpression k, toExpression v] []
+ Untyped.TBigMap k v ->
+ expressionPrim' Prim_big_map [toExpression k, toExpression v] []
+ Untyped.TInt -> expressionPrim' Prim_int [] []
+ Untyped.TNat -> expressionPrim' Prim_nat [] []
+ Untyped.TString -> expressionPrim' Prim_string [] []
+ Untyped.TBytes -> expressionPrim' Prim_bytes [] []
+ Untyped.TMutez -> expressionPrim' Prim_mutez [] []
+ Untyped.TBool -> expressionPrim' Prim_bool [] []
+ Untyped.TKeyHash -> expressionPrim' Prim_key_hash [] []
+ Untyped.TBls12381Fr -> expressionPrim' Prim_bls12_381_fr [] []
+ Untyped.TBls12381G1 -> expressionPrim' Prim_bls12_381_g1 [] []
+ Untyped.TBls12381G2 -> expressionPrim' Prim_bls12_381_g2 [] []
+ Untyped.TTimestamp -> expressionPrim' Prim_timestamp [] []
+ Untyped.TAddress -> expressionPrim' Prim_address [] []
+ Untyped.TChest -> expressionPrim' Prim_chest [] []
+ Untyped.TChestKey -> expressionPrim' Prim_chest_key [] []
+ Untyped.TNever -> expressionPrim' Prim_never [] []
+ Untyped.TSaplingState n -> expressionPrim' Prim_sapling_state [integralToExpr n] []
+ Untyped.TSaplingTransaction n -> expressionPrim' Prim_sapling_transaction [integralToExpr n] []
+
+ where
+ addAnns :: Expression -> [Annotation] -> Expression
+ addAnns e anns =
+ e & _ExpressionPrim . mpaAnnotsL <>~ anns
+
+ rightCombedPairToList :: Untyped.T -> [Expression]
+ rightCombedPairToList t =
+ let go ty (fa, va)
+ | Ty (Untyped.TPair faL faR vaL vaR l r) ta <- ty
+ , ta == noAnn, fa == noAnn, va == noAnn
+ = toExpression l `addAnns` mkAnns [] [faL] [vaL] : go r (faR, vaR)
+ | otherwise
+ = one $ toExpression ty `addAnns` mkAnns [] [fa] [va]
+ in go (Ty t noAnn) (noAnn, noAnn)
+
+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
+
+-- Note: On adding new expressions here, you must also add the symmetric (reading) case
+-- to FromExp x (InstrAbstract [] op) as well.
+instance ToExpression ExpandedInstr where
+ toExpression = \case
+ PUSH va ty v -> expressionPrim' Prim_PUSH [toExpression ty, toExpression v] $
+ mkAnns [] [] [va]
+ DROP -> expressionPrim' Prim_DROP [] []
+ DROPN n -> expressionPrim' Prim_DROP [integralToExpr n] []
+ DUP va -> expressionPrim' Prim_DUP [] $ mkAnns [] [] [va]
+ DUPN va n -> expressionPrim' Prim_DUP [integralToExpr n] $ mkAnns [] [] [va]
+ SWAP -> expressionPrim' Prim_SWAP [] []
+ DIG n -> expressionPrim' Prim_DIG [integralToExpr n] []
+ DUG n -> expressionPrim' Prim_DUG [integralToExpr n] []
+ SOME ta va ->
+ expressionPrim' Prim_SOME [] $ mkAnns [ta] [] [va]
+ NONE ta va ty -> expressionPrim' Prim_NONE [toExpression ty] $ mkAnns [ta] [] [va]
+ UNIT ta va -> expressionPrim' Prim_UNIT [] $ mkAnns [ta] [] [va]
+ IF_NONE ops1 ops2 ->
+ expressionPrim' Prim_IF_NONE [toExpression ops1, toExpression ops2] []
+ PAIR ta va fa1 fa2 -> expressionPrim' Prim_PAIR [] $ mkAnns [ta] [fa1, fa2] [va]
+ UNPAIR va1 va2 fa1 fa2 -> expressionPrim' Prim_UNPAIR [] $
+ mkAnns [] [fa1, fa2] [va1, va2]
+ PAIRN va n -> expressionPrim' Prim_PAIR [integralToExpr n] $ mkAnns [] [] [va]
+ UNPAIRN n -> expressionPrim' Prim_UNPAIR [integralToExpr n] []
+ CAR va fa -> expressionPrim' Prim_CAR [] $ mkAnns [] [fa] [va]
+ CDR va fa -> expressionPrim' Prim_CDR [] $ mkAnns [] [fa] [va]
+ LEFT ta va fa1 fa2 ty -> expressionPrim' Prim_LEFT [toExpression ty] $
+ mkAnns [ta] [fa1, fa2] [va]
+ RIGHT ta va fa1 fa2 ty -> expressionPrim' Prim_RIGHT [toExpression ty] $
+ mkAnns [ta] [fa1, fa2] [va]
+ IF_LEFT ops1 ops2 ->
+ expressionPrim' Prim_IF_LEFT [toExpression ops1, toExpression ops2] []
+ NIL ta va ty -> expressionPrim' Prim_NIL [toExpression ty] $
+ mkAnns [ta] [] [va]
+ CONS va -> expressionPrim' Prim_CONS [] $ mkAnns [] [] [va]
+ IF_CONS ops1 ops2 ->
+ expressionPrim' Prim_IF_CONS [toExpression ops1, toExpression ops2] []
+ SIZE va -> expressionPrim' Prim_SIZE [] $ mkAnns [] [] [va]
+ EMPTY_SET ta va ty -> expressionPrim' Prim_EMPTY_SET [toExpression ty] $
+ mkAnns [ta] [] [va]
+ EMPTY_MAP ta va kty vty ->
+ expressionPrim' Prim_EMPTY_MAP [toExpression kty, toExpression vty] $
+ mkAnns [ta] [] [va]
+ EMPTY_BIG_MAP ta va kty vty ->
+ expressionPrim' Prim_EMPTY_BIG_MAP [toExpression kty, toExpression vty] $
+ mkAnns [ta] [] [va]
+ MAP va ops -> expressionPrim' Prim_MAP [toExpression ops] $ mkAnns [] [] [va]
+ ITER ops -> expressionPrim' Prim_ITER [toExpression ops] []
+ MEM va -> expressionPrim' Prim_MEM [] $ mkAnns [] [] [va]
+ GET va -> expressionPrim' Prim_GET [] $ mkAnns [] [] [va]
+ GETN va n -> expressionPrim' Prim_GET [integralToExpr n] $ mkAnns [] [] [va]
+ UPDATE va -> expressionPrim' Prim_UPDATE [] $ mkAnns [] [] [va]
+ UPDATEN va n -> expressionPrim' Prim_UPDATE [integralToExpr n] $ mkAnns [] [] [va]
+ GET_AND_UPDATE va -> expressionPrim' Prim_GET_AND_UPDATE [] $ mkAnns [] [] [va]
+ IF ops1 ops2 ->
+ expressionPrim' Prim_IF [toExpression ops1, toExpression ops2] []
+ LOOP ops -> expressionPrim' Prim_LOOP [toExpression ops] []
+ LOOP_LEFT ops -> expressionPrim' Prim_LOOP_LEFT [toExpression ops] []
+ LAMBDA va tyin tyout ops ->
+ expressionPrim' Prim_LAMBDA [ toExpression tyin
+ , toExpression tyout
+ , toExpression ops
+ ] $ mkAnns [] [] [va]
+ LAMBDA_REC va tyin tyout ops ->
+ expressionPrim' Prim_LAMBDA_REC [ toExpression tyin
+ , toExpression tyout
+ , toExpression ops
+ ] $ mkAnns [] [] [va]
+ EXEC va -> expressionPrim' Prim_EXEC [] $ mkAnns [] [] [va]
+ APPLY va -> expressionPrim' Prim_APPLY [] $ mkAnns [] [] [va]
+ DIP ops -> expressionPrim' Prim_DIP [toExpression ops] []
+ DIPN n ops -> expressionPrim' Prim_DIP [integralToExpr n, toExpression ops] []
+ FAILWITH -> expressionPrim' Prim_FAILWITH [] []
+ CAST va ty -> expressionPrim' Prim_CAST [toExpression ty] $ mkAnns [] [] [va]
+ RENAME va -> expressionPrim' Prim_RENAME [] $ mkAnns [] [] [va]
+ PACK va -> expressionPrim' Prim_PACK [] $ mkAnns [] [] [va]
+ UNPACK ta va ty -> expressionPrim' Prim_UNPACK [toExpression ty] $
+ mkAnns [ta] [] [va]
+ CONCAT va -> expressionPrim' Prim_CONCAT [] $ mkAnns [] [] [va]
+ SLICE va -> expressionPrim' Prim_SLICE [] $ mkAnns [] [] [va]
+ ISNAT va -> expressionPrim' Prim_ISNAT [] $ mkAnns [] [] [va]
+ ADD va -> expressionPrim' Prim_ADD [] $ mkAnns [] [] [va]
+ SUB va -> expressionPrim' Prim_SUB [] $ mkAnns [] [] [va]
+ SUB_MUTEZ va -> expressionPrim' Prim_SUB_MUTEZ [] $ mkAnns [] [] [va]
+ MUL va -> expressionPrim' Prim_MUL [] $ mkAnns [] [] [va]
+ EDIV va -> expressionPrim' Prim_EDIV [] $ mkAnns [] [] [va]
+ ABS va -> expressionPrim' Prim_ABS [] $ mkAnns [] [] [va]
+ NEG va -> expressionPrim' Prim_NEG [] $ mkAnns [] [] [va]
+ LSL va -> expressionPrim' Prim_LSL [] $ mkAnns [] [] [va]
+ LSR va -> expressionPrim' Prim_LSR [] $ mkAnns [] [] [va]
+ OR va -> expressionPrim' Prim_OR [] $ mkAnns [] [] [va]
+ AND va -> expressionPrim' Prim_AND [] $ mkAnns [] [] [va]
+ XOR va -> expressionPrim' Prim_XOR [] $ mkAnns [] [] [va]
+ NOT va -> expressionPrim' Prim_NOT [] $ mkAnns [] [] [va]
+ COMPARE va -> expressionPrim' Prim_COMPARE [] $ mkAnns [] [] [va]
+ Untyped.EQ va -> expressionPrim' Prim_EQ [] $ mkAnns [] [] [va]
+ NEQ va -> expressionPrim' Prim_NEQ [] $ mkAnns [] [] [va]
+ Untyped.LT va -> expressionPrim' Prim_LT [] $ mkAnns [] [] [va]
+ Untyped.GT va -> expressionPrim' Prim_GT [] $ mkAnns [] [] [va]
+ LE va -> expressionPrim' Prim_LE [] $ mkAnns [] [] [va]
+ GE va -> expressionPrim' Prim_GE [] $ mkAnns [] [] [va]
+ INT va -> expressionPrim' Prim_INT [] $ mkAnns [] [] [va]
+ NAT va -> expressionPrim' Prim_NAT [] $ mkAnns [] [] [va]
+ BYTES va -> expressionPrim' Prim_BYTES [] $ mkAnns [] [] [va]
+ VIEW va n t -> expressionPrim' Prim_VIEW [toExpression n, toExpression t] $
+ mkAnns [] [] [va]
+ SELF va fa -> expressionPrim' Prim_SELF [] $ mkAnns [] [fa] [va]
+ CONTRACT va fa ty -> expressionPrim' Prim_CONTRACT [toExpression ty] $
+ mkAnns [] [fa] [va]
+ TRANSFER_TOKENS va -> expressionPrim' Prim_TRANSFER_TOKENS [] $ mkAnns [] [] [va]
+ SET_DELEGATE va -> expressionPrim' Prim_SET_DELEGATE [] $ mkAnns [] [] [va]
+ CREATE_CONTRACT va1 va2 c ->
+ expressionPrim' Prim_CREATE_CONTRACT [toExpression c] $
+ mkAnns [] [] [va1, va2]
+ IMPLICIT_ACCOUNT va -> expressionPrim' Prim_IMPLICIT_ACCOUNT [] $
+ mkAnns [] [] [va]
+ NOW va -> expressionPrim' Prim_NOW [] $ mkAnns [] [] [va]
+ AMOUNT va -> expressionPrim' Prim_AMOUNT [] $ mkAnns [] [] [va]
+ BALANCE va -> expressionPrim' Prim_BALANCE [] $ mkAnns [] [] [va]
+ VOTING_POWER va -> expressionPrim' Prim_VOTING_POWER [] $ mkAnns [] [] [va]
+ TOTAL_VOTING_POWER va -> expressionPrim' Prim_TOTAL_VOTING_POWER [] $
+ mkAnns [] [] [va]
+ CHECK_SIGNATURE va -> expressionPrim' Prim_CHECK_SIGNATURE [] $ mkAnns [] [] [va]
+ SHA256 va -> expressionPrim' Prim_SHA256 [] $ mkAnns [] [] [va]
+ SHA512 va -> expressionPrim' Prim_SHA512 [] $ mkAnns [] [] [va]
+ BLAKE2B va -> expressionPrim' Prim_BLAKE2B [] $ mkAnns [] [] [va]
+ SHA3 va -> expressionPrim' Prim_SHA3 [] $ mkAnns [] [] [va]
+ KECCAK va -> expressionPrim' Prim_KECCAK [] $ mkAnns [] [] [va]
+ HASH_KEY va -> expressionPrim' Prim_HASH_KEY [] $ mkAnns [] [] [va]
+ PAIRING_CHECK va -> expressionPrim' Prim_PAIRING_CHECK [] $ mkAnns [] [] [va]
+ SOURCE va -> expressionPrim' Prim_SOURCE [] $ mkAnns [] [] [va]
+ SENDER va -> expressionPrim' Prim_SENDER [] $ mkAnns [] [] [va]
+ ADDRESS va -> expressionPrim' Prim_ADDRESS [] $ mkAnns [] [] [va]
+ CHAIN_ID va -> expressionPrim' Prim_CHAIN_ID [] $ mkAnns [] [] [va]
+ LEVEL va -> expressionPrim' Prim_LEVEL [] $ mkAnns [] [] [va]
+ SELF_ADDRESS va -> expressionPrim' Prim_SELF_ADDRESS [] $ mkAnns [] [] [va]
+ TICKET va -> expressionPrim' Prim_TICKET [] $ mkAnns [] [] [va]
+ TICKET_DEPRECATED va -> expressionPrim' Prim_TICKET_DEPRECATED [] $ mkAnns [] [] [va]
+ READ_TICKET va -> expressionPrim' Prim_READ_TICKET [] $ mkAnns [] [] [va]
+ SPLIT_TICKET va -> expressionPrim' Prim_SPLIT_TICKET [] $ mkAnns [] [] [va]
+ JOIN_TICKETS va -> expressionPrim' Prim_JOIN_TICKETS [] $ mkAnns [] [] [va]
+ OPEN_CHEST va -> expressionPrim' Prim_OPEN_CHEST [] $ mkAnns [] [] [va]
+ NEVER -> expressionPrim' Prim_NEVER [] []
+ EXT _ -> expressionSeq []
+ SAPLING_EMPTY_STATE va n -> expressionPrim' Prim_SAPLING_EMPTY_STATE [integralToExpr n] $ mkAnns [] [] [va]
+ SAPLING_VERIFY_UPDATE va -> expressionPrim' Prim_SAPLING_VERIFY_UPDATE [] $ mkAnns [] [] [va]
+ MIN_BLOCK_TIME va -> expressionPrim' Prim_MIN_BLOCK_TIME [] $ mkAnnsFromAny va
+ EMIT va tag ty -> expressionPrim' Prim_EMIT (toExpression <$> maybeToList ty) $ mkAnns [] [tag] [va]
+
+instance ToExpression Untyped.Contract where
+ toExpression contract
+ = expressionSeq $ Untyped.mapEntriesOrdered contract
+ (\(Untyped.ParameterType ty rootAnn) -> expressionPrim' Prim_parameter
+ [insertRootAnn (toExpression ty) rootAnn] [])
+ (\storage -> expressionPrim' Prim_storage [toExpression storage] [])
+ (\code -> expressionPrim' Prim_code [toExpression code] [])
+ (\Untyped.View{..} -> expressionPrim' Prim_view
+ [toExpression viewName, toExpression viewArgument, toExpression viewReturn, toExpression viewCode] []
+ )
+
+instance ToExpression (Contract cp st) where
+ toExpression = toExpression . convertContractOptimized
+
+-- FromExpression
+----------------------------------------------------------------------------
+
+-- | Errors that can happen when we convert an 'Exp' to our
+-- data type.
+data FromExpError x = FromExpError (Exp x) FromExpErrorReason
+
+deriving stock instance Show (Exp x) => Show (FromExpError x)
+deriving stock instance Eq (Exp x) => Eq (FromExpError x)
+
+data FromExpErrorReason
+ = FEERMTextDecodingFailure Text
+ | FEERTcError T TcError
+ | FEERNotEnoughArguments Word Int
+ | FEERUnexpectedPrim (Maybe MichelinePrimitive) MichelinePrimitive
+ | FEERUnexpectedPrimClass MichelinePrimitiveTag MichelinePrimitiveTag
+ | FEERArgumentCountMismatch (NonEmpty Word) Int
+ | FEERUnexpectedAnnotations
+ | FEERExpectedPrim (NonEmpty MichelinePrimitiveTag)
+ | FEERExpectedSeq
+ | FEERUnsupported
+ | FEERDeprecated
+ | FEERTooManyAnns (Maybe Int, Maybe Int, Maybe Int) (Int, Int, Int)
+ | FEEROutOfBounds
+ | FEERExpectedNumber
+ | FEERExpectedString
+ | FEERViewNameError BadViewNameError
+ | FEERBadContractBlocks (NonEmpty ContractBlockError)
+ deriving stock (Show, Eq)
+
+instance Buildable FromExpErrorReason where
+ build = \case
+ FEERMTextDecodingFailure msg -> nameF "Text decoding failure" $ build msg
+ FEERTcError ty err -> unlinesF
+ [ nameF "Failed to typecheck expression as a value of type" $ build ty
+ , mempty
+ , nameF "Typechecker error" $ build err
+ ]
+ FEERNotEnoughArguments minArgs numArgs ->
+ "Expected at least" ++| minArgs |++ "arguments, but got" ++| numArgs |++ ""
+ FEERUnexpectedPrim expected got ->
+ nameF "Unexpected primitive" $ case expected of
+ Nothing -> build got
+ Just e -> build MkMismatchError { meExpected = e, meActual = got }
+ FEERUnexpectedPrimClass expected got ->
+ nameF "Unexpected primitive class" $ build $ MkMismatchError
+ { meExpected = expected, meActual = got }
+ FEERArgumentCountMismatch expected got ->
+ fillSepF
+ $ "Expected exactly"
+ : punctuateF "," " or" expected <>
+ [ "arguments, but got"
+ , build got
+ ]
+ FEERUnexpectedAnnotations -> "Unexpected annotations"
+ FEERExpectedPrim prims -> fillSepF
+ $ "Expected primitive"
+ : punctuateF "," " or" prims
+ FEERExpectedSeq -> "Expected sequence"
+ FEERTooManyAnns (maxTas, maxFas, maxVas) (tasCnt, fasCnt, vasCnt) -> unlinesF
+ [ nameF "Expected at most" $ unlinesF $ catMaybes
+ [ (<> " type annotations") . build <$> maxTas
+ , (<> " field annotations") . build <$> maxFas
+ , (<> " variable annotations") . build <$> maxVas
+ ]
+ , nameF "but found" $ unlinesF $ catMaybes
+ [ (<> " type annotations") . build <$> (maxTas $> tasCnt)
+ , (<> " field annotations") . build <$> (maxFas $> fasCnt)
+ , (<> " variable annotations") . build <$> (maxVas $> vasCnt)
+ ]
+ ]
+ FEEROutOfBounds -> "Value is out of bounds"
+ FEERBadContractBlocks cbes -> unlinesF $ build <$> cbes
+ FEERUnsupported -> "Unsupported"
+ FEERDeprecated -> "Deprecated primitive"
+ FEERExpectedNumber -> "Expected number"
+ FEERExpectedString -> "Expected string"
+ FEERViewNameError err -> nameF "View name error" $ build err
+
+-- | 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 $ FEERTcError (demote @t) tcErr
+ Right tv -> Right tv
+ Left e -> Left e
+ where
+ typeCheck uv = typeCheckingWith (TypeCheckOptions False False) $
+ 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 . FEERMTextDecodingFailure)
+ (Untyped.ValueString <$> mkMText s)
+ ExpBytes _ bs -> pure $ Untyped.ValueBytes $ Untyped.InternalByteString bs
+ ExpPrim _ (MichelinePrimAp prim args _) -> withClassifiedPrim prim \case
+ SMPTValue -> \case
+ C_Prim_Unit -> withArgs Untyped.ValueUnit
+ C_Prim_True -> withArgs Untyped.ValueTrue
+ C_Prim_False -> withArgs Untyped.ValueFalse
+ C_Prim_Pair ->
+ case nonEmpty args >>= forbidSingletonList of
+ Nothing -> Left $ FromExpError e $ FEERNotEnoughArguments 2 (length args)
+ Just args' -> do
+ tys <- mapM fromExp args'
+ return $ foldr1 Untyped.ValuePair tys
+ C_Prim_Left -> withArgs Untyped.ValueLeft
+ C_Prim_Right -> withArgs Untyped.ValueRight
+ C_Prim_Some -> withArgs Untyped.ValueSome
+ C_Prim_None -> withArgs Untyped.ValueNone
+ C_Prim_Lambda_rec -> withArgs Untyped.ValueLamRec
+ C_Prim_Elt -> Left $ FromExpError e $ FEERUnexpectedPrim Nothing Prim_Elt
+ s -> const $ Left $ FromExpError e $ FEERUnexpectedPrimClass MPTValue (fromSing s)
+ where
+ withArgs :: WithArgsRec x a r => a -> Either (FromExpError x) r
+ withArgs = withArgsRec e args
+ 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 $
+ FEERExpectedPrim (MPTValue :| [MPTInstr])
+ Right h' -> do
+ t' <- traverse fromExp t
+ pure . Untyped.ValueSeq $ h' :| t'
+ ExpX _ -> Left $ FromExpError e $ FEERExpectedPrim (one MPTValue)
+ where
+ exprToElt :: Exp x -> Either (FromExpError x) (Untyped.Elt [] op)
+ exprToElt ex = case ex of
+ ExpPrim' _ Prim_Elt [l, r] [] -> do
+ l' <- fromExp l
+ r' <- fromExp r
+ pure $ Untyped.Elt l' r'
+ ExpPrim' _ Prim_Elt args' [] -> Left $ FromExpError ex $
+ FEERArgumentCountMismatch (one 2) (length args')
+ ExpPrim' _ Prim_Elt _ _ -> Left $ FromExpError ex FEERUnexpectedAnnotations
+ ExpPrim' _ prim _ _ -> Left $ FromExpError ex $ FEERUnexpectedPrim (Just Prim_Elt) prim
+ _ -> Left $ FromExpError ex $ FEERExpectedPrim $ one MPTValue
+
+instance FromExp x a => FromExp x [a] where
+ fromExp = \case
+ ExpSeq _ exprs -> traverse fromExp exprs
+ e -> Left $ FromExpError e FEERExpectedSeq
+
+instance FromExp RegularExp ExpandedOp where
+ fromExp = \case
+ ExpSeq _ s -> SeqEx <$> traverse fromExp s
+ e -> PrimEx <$> fromExp e
+
+instance FromExp x Word where
+ fromExp = integralFromExpr
+
+instance FromExp x Natural where
+ fromExp = integralFromExpr
+
+-- | Used to improve type inference with 'WithArgsRec'.
+type family EndResult a where
+ EndResult (_ -> b) = EndResult b
+ EndResult b = b
+
+-- | Recursive typeclass that unpacks a list of constructor arguments and
+-- applies a function to them.
+class (EndResult a ~ r, CountArgs a r) => WithArgsRec x a r where
+ -- | Given the 'Exp' itself (used for error reporting), its arguments, and a
+ -- function constructing the result form the arguments, produce the result or
+ -- an error if the argument count is mismatched.
+ withArgsRec' :: FromExpError x -> [Exp x] -> a -> Either (FromExpError x) r
+
+instance (FromExp x a, WithArgsRec x b r) => WithArgsRec x (a -> b) r where
+ withArgsRec' ee (e:es) f = fromExp @x e >>= withArgsRec' ee es . f
+ withArgsRec' ee [] _ = Left ee
+
+instance (EndResult r ~ r) => WithArgsRec x r r where
+ withArgsRec' _ [] x = pure x
+ withArgsRec' ee _ _ = Left ee
+
+class CountArgs a r where countArgs :: Word
+instance CountArgs r r where countArgs = 0
+instance CountArgs b r => CountArgs (a -> b) r where countArgs = succ $ countArgs @b @r
+
+withArgsRec
+ :: forall x a r. WithArgsRec x a r
+ => Exp x -> [Exp x] -> a -> Either (FromExpError x) r
+withArgsRec e args = withArgsRec'
+ (FromExpError e $ FEERArgumentCountMismatch (one $ countArgs @a @r) (length args))
+ args
+
+-- Note: On adding new expressions here, you must also add the symmetric (writing) case
+-- to ToExpression as well.
+instance FromExp x op =>
+ FromExp x (InstrAbstract [] op) where
+ fromExp e@(ExpPrim' _ prim args anns) = withClassifiedPrim prim \case
+ SMPTInstr -> \case
+ C_Prim_DROP -> nilAnns *> case args of
+ [] -> pure DROP
+ [n] -> DROPN <$> integralFromExpr n
+ _ -> invalidNumArgs $ 0 :| [1]
+ C_Prim_DUP -> annsCnt (0, 0, 1) *> case args of
+ [n] -> DUPN va <$> integralFromExpr n
+ [] -> pure $ DUP va
+ _ -> invalidNumArgs $ 0 :| [1]
+ C_Prim_SWAP -> withArgsAnns nil SWAP
+ C_Prim_DIG -> withArgsAnns nil DIG
+ C_Prim_DUG -> withArgsAnns nil DUG
+ C_Prim_PUSH -> withArgsAnns (0, 0, 1) $ PUSH va
+ C_Prim_SOME -> withArgsAnns (1, 0, 1) $ SOME ta va
+ C_Prim_NONE -> withArgsAnns (1, 0, 1) $ NONE ta va
+ C_Prim_UNIT -> withArgsAnns (1, 0, 1) $ UNIT ta va
+ C_Prim_IF_NONE -> withArgsAnns nil IF_NONE
+ C_Prim_PAIR -> case args of
+ [] -> annsCnt (1, 2, 1) $> PAIR ta va fa1 fa2
+ [n] -> annsCnt (0, 0, 1) $> PAIRN va <*> integralFromExpr n
+ _ -> invalidNumArgs $ 0 :| [1]
+ C_Prim_UNPAIR -> case args of
+ [] -> annsCnt (0, 2, 2) $> UNPAIR va1 va2 fa1 fa2
+ [n] -> nilAnns $> UNPAIRN <*> integralFromExpr n
+ _ -> invalidNumArgs $ 0 :| [1]
+ C_Prim_CAR -> withArgsAnns (0, 1, 1) $ CAR va fa
+ C_Prim_CDR -> withArgsAnns (0, 1, 1) $ CDR va fa
+ C_Prim_LEFT -> withArgsAnns (1, 2, 1) $ LEFT ta va fa1 fa2
+ C_Prim_RIGHT -> withArgsAnns (1, 2, 1) $ RIGHT ta va fa1 fa2
+ C_Prim_IF_LEFT -> withArgsAnns nil IF_LEFT
+ C_Prim_NIL -> withArgsAnns (1, 0, 1) $ NIL ta va
+ C_Prim_CONS -> mkInstrWithVarAnn CONS
+ C_Prim_IF_CONS -> withArgsAnns nil IF_CONS
+ C_Prim_SIZE -> mkInstrWithVarAnn SIZE
+ C_Prim_EMPTY_SET -> withArgsAnns (1, 0, 1) $ EMPTY_SET ta va
+ C_Prim_EMPTY_MAP -> withArgsAnns (1, 0, 1) $ EMPTY_MAP ta va
+ C_Prim_EMPTY_BIG_MAP -> withArgsAnns (1, 0, 1) $ EMPTY_BIG_MAP ta va
+ C_Prim_MAP -> withArgsAnns (0, 0, 1) $ MAP va
+ C_Prim_ITER -> withArgsAnns nil ITER
+ C_Prim_MEM -> mkInstrWithVarAnn MEM
+ C_Prim_GET -> case args of
+ [] -> mkInstrWithVarAnn GET
+ [n] -> annsCnt (0, 0, 1) $> GETN va <*> integralFromExpr n
+ _ -> invalidNumArgs $ 0 :| [1]
+ C_Prim_UPDATE -> case args of
+ [] -> mkInstrWithVarAnn UPDATE
+ [n] -> annsCnt (0, 0, 1) $> UPDATEN va <*> integralFromExpr n
+ _ -> invalidNumArgs $ 0 :| [1]
+ C_Prim_GET_AND_UPDATE -> mkInstrWithVarAnn GET_AND_UPDATE
+ C_Prim_IF -> withArgsAnns nil IF
+ C_Prim_LOOP -> withArgsAnns nil LOOP
+ C_Prim_LOOP_LEFT -> withArgsAnns nil LOOP_LEFT
+ C_Prim_LAMBDA -> withArgsAnns (0, 0, 1) $ LAMBDA va
+ C_Prim_LAMBDA_REC -> withArgsAnns (0, 0, 1) $ LAMBDA_REC va
+ C_Prim_EXEC -> mkInstrWithVarAnn EXEC
+ C_Prim_APPLY -> mkInstrWithVarAnn APPLY
+ C_Prim_DIP -> nilAnns *> case args of
+ [ops] -> DIP <$> fromExp ops
+ [n, ops] -> DIPN <$> fromExp n <*> fromExp ops
+ _ -> invalidNumArgs $ 1 :| [2]
+ C_Prim_FAILWITH -> withArgsAnns nil FAILWITH
+ C_Prim_CAST -> withArgsAnns (0, 0, 1) $ CAST va
+ C_Prim_RENAME -> mkInstrWithVarAnn RENAME
+ C_Prim_PACK -> mkInstrWithVarAnn PACK
+ C_Prim_UNPACK -> withArgsAnns (1, 0, 1) $ UNPACK ta va
+ C_Prim_CONCAT -> mkInstrWithVarAnn CONCAT
+ C_Prim_SLICE -> mkInstrWithVarAnn SLICE
+ C_Prim_ISNAT -> mkInstrWithVarAnn ISNAT
+ C_Prim_ADD -> mkInstrWithVarAnn ADD
+ C_Prim_SUB -> mkInstrWithVarAnn SUB
+ C_Prim_SUB_MUTEZ -> mkInstrWithVarAnn SUB_MUTEZ
+ C_Prim_MUL -> mkInstrWithVarAnn MUL
+ C_Prim_EDIV -> mkInstrWithVarAnn EDIV
+ C_Prim_ABS -> mkInstrWithVarAnn ABS
+ C_Prim_NEG -> mkInstrWithVarAnn NEG
+ C_Prim_LSL -> mkInstrWithVarAnn LSL
+ C_Prim_LSR -> mkInstrWithVarAnn LSR
+ C_Prim_OR -> mkInstrWithVarAnn OR
+ C_Prim_AND -> mkInstrWithVarAnn AND
+ C_Prim_XOR -> mkInstrWithVarAnn XOR
+ C_Prim_NOT -> mkInstrWithVarAnn NOT
+ C_Prim_COMPARE -> mkInstrWithVarAnn COMPARE
+ C_Prim_EQ -> mkInstrWithVarAnn Untyped.EQ
+ C_Prim_NEQ -> mkInstrWithVarAnn NEQ
+ C_Prim_LT -> mkInstrWithVarAnn Untyped.LT
+ C_Prim_GT -> mkInstrWithVarAnn Untyped.GT
+ C_Prim_LE -> mkInstrWithVarAnn LE
+ C_Prim_GE -> mkInstrWithVarAnn GE
+ C_Prim_INT -> mkInstrWithVarAnn INT
+ C_Prim_NAT -> mkInstrWithVarAnn NAT
+ C_Prim_BYTES -> mkInstrWithVarAnn BYTES
+ C_Prim_VIEW -> withArgsAnns (0, 0, 1) $ VIEW va
+ C_Prim_SELF -> withArgsAnns (0, 1, 1) $ SELF va fa
+ C_Prim_CONTRACT -> withArgsAnns (0, 1, 1) $ CONTRACT va fa
+ C_Prim_TRANSFER_TOKENS -> mkInstrWithVarAnn TRANSFER_TOKENS
+ C_Prim_SET_DELEGATE -> mkInstrWithVarAnn SET_DELEGATE
+ C_Prim_CREATE_CONTRACT -> withArgsAnns (0, 0, 2) $ CREATE_CONTRACT va1 va2
+ C_Prim_IMPLICIT_ACCOUNT -> mkInstrWithVarAnn IMPLICIT_ACCOUNT
+ C_Prim_NOW -> mkInstrWithVarAnn NOW
+ C_Prim_AMOUNT -> mkInstrWithVarAnn AMOUNT
+ C_Prim_BALANCE -> mkInstrWithVarAnn BALANCE
+ C_Prim_VOTING_POWER -> mkInstrWithVarAnn VOTING_POWER
+ C_Prim_TOTAL_VOTING_POWER -> mkInstrWithVarAnn TOTAL_VOTING_POWER
+ C_Prim_CHECK_SIGNATURE -> mkInstrWithVarAnn CHECK_SIGNATURE
+ C_Prim_SHA256 -> mkInstrWithVarAnn SHA256
+ C_Prim_SHA512 -> mkInstrWithVarAnn SHA512
+ C_Prim_BLAKE2B -> mkInstrWithVarAnn BLAKE2B
+ C_Prim_SHA3 -> mkInstrWithVarAnn SHA3
+ C_Prim_KECCAK -> mkInstrWithVarAnn KECCAK
+ C_Prim_HASH_KEY -> mkInstrWithVarAnn HASH_KEY
+ C_Prim_PAIRING_CHECK -> mkInstrWithVarAnn PAIRING_CHECK
+ C_Prim_SOURCE -> mkInstrWithVarAnn SOURCE
+ C_Prim_SENDER -> mkInstrWithVarAnn SENDER
+ C_Prim_ADDRESS -> mkInstrWithVarAnn ADDRESS
+ C_Prim_CHAIN_ID -> mkInstrWithVarAnn CHAIN_ID
+ C_Prim_LEVEL -> mkInstrWithVarAnn LEVEL
+ C_Prim_SELF_ADDRESS -> mkInstrWithVarAnn SELF_ADDRESS
+ C_Prim_NEVER -> withArgsAnns nil NEVER
+ C_Prim_TICKET_DEPRECATED -> mkInstrWithVarAnn TICKET_DEPRECATED
+ C_Prim_TICKET -> mkInstrWithVarAnn TICKET
+ C_Prim_READ_TICKET -> mkInstrWithVarAnn READ_TICKET
+ C_Prim_SPLIT_TICKET -> mkInstrWithVarAnn SPLIT_TICKET
+ C_Prim_JOIN_TICKETS -> mkInstrWithVarAnn JOIN_TICKETS
+ C_Prim_OPEN_CHEST -> mkInstrWithVarAnn OPEN_CHEST
+ C_Prim_SAPLING_EMPTY_STATE -> withArgsAnns (0, 0, 1) $ SAPLING_EMPTY_STATE va
+ C_Prim_SAPLING_VERIFY_UPDATE -> mkInstrWithVarAnn SAPLING_VERIFY_UPDATE
+ C_Prim_MIN_BLOCK_TIME -> withArgsRec e args $ mkInstrWithAnyAnns MIN_BLOCK_TIME
+ C_Prim_EMIT -> annsCnt (0, 1, 1) $> EMIT va fa <*> case args of
+ [] -> pure Nothing
+ [ty] -> Just <$> fromExp ty
+ _ -> invalidNumArgs (0 :| [1])
+ s -> const $ Left $ FromExpError e $ FEERUnexpectedPrimClass MPTInstr (fromSing s)
+
+ where
+ annSet = toAnnSet anns
+ va = firstAnn @VarTag annSet
+ ta = firstAnn @TypeTag annSet
+ fa = firstAnn @FieldTag annSet
+ fa1 = fa
+ fa2 = secondAnn @FieldTag annSet
+ va1 = va
+ va2 = secondAnn @VarTag annSet
+
+ withArgsAnns
+ :: WithArgsRec x a (InstrAbstract [] op)
+ => (Int, Int, Int) -> a -> Either (FromExpError x) (InstrAbstract [] op)
+ withArgsAnns n f = annsCnt n *> withArgsRec e args f
+
+ invalidNumArgs :: NonEmpty Word -> Either (FromExpError x) b
+ invalidNumArgs expected = Left $ FromExpError e $
+ FEERArgumentCountMismatch expected (length args)
+
+ annsCnt = checkAnnsCount e annSet
+
+ nil = (0, 0, 0)
+
+ nilAnns = annsCnt nil
+
+ mkInstrWithVarAnn
+ :: WithArgsRec x a (InstrAbstract [] op)
+ => (Untyped.Annotation VarTag -> a)
+ -> Either (FromExpError x) (InstrAbstract [] op)
+ mkInstrWithVarAnn ctor = withArgsAnns (0, 0, 1) $ ctor va
+
+ mkInstrWithAnyAnns :: ([Untyped.AnyAnn] -> t) -> t
+ mkInstrWithAnyAnns ctor = ctor $ anns <&> \case
+ AnnotationType x -> Untyped.AnyAnnType x
+ AnnotationField x -> Untyped.AnyAnnField x
+ AnnotationVariable x -> Untyped.AnyAnnVar x
+
+ fromExp e = Left $ FromExpError e $ FEERExpectedPrim (one MPTInstr)
+
+instance (FromExp x op) => FromExp x (Untyped.Contract' op) where
+ fromExp blocks = case blocks of
+ ExpSeq _ bs -> do
+ bs' <- mapM exprToCB bs
+ first (FromExpError blocks . FEERBadContractBlocks) $ orderContractBlock bs'
+ expr -> Left $ FromExpError expr FEERExpectedSeq
+ where
+ exprToCB
+ :: Exp x
+ -> Either (FromExpError x) (ContractBlock op)
+ exprToCB e@(ExpPrim' _ prim args anns) = withClassifiedPrim prim \case
+ SMPTKeyword -> \case
+ C_Prim_parameter -> mkCbParam e args anns
+ C_Prim_storage -> mkCBStorage e args anns
+ C_Prim_code -> mkCBCode e args anns
+ C_Prim_view -> mkCBView e args anns
+ s -> const $ Left $ FromExpError e $ FEERUnexpectedPrimClass MPTKeyword (fromSing s)
+ exprToCB e = Left $ FromExpError e $ FEERExpectedPrim $ one MPTKeyword
+
+ mkCbParam
+ :: Exp x
+ -> [Exp x]
+ -> [Annotation]
+ -> Either (FromExpError x) (ContractBlock op)
+ mkCbParam e args anns = checkAnnsCount e (toAnnSet anns) (0, 0, 0) *> case args of
+ [p] -> do
+ let annSet = toAnnSet (p ^. _ExpPrim . _2 . mpaAnnotsL)
+ annCnt = annsCount annSet
+ let rootAnn = firstAnn @FieldTag annSet
+ unless (secondAnn @FieldTag annSet == noAnn) $
+ Left $ FromExpError p $ FEERTooManyAnns (Nothing, Just 1, Nothing) annCnt
+ p' <- fromExp @x @Ty
+ (p & _ExpPrim . _2 . mpaAnnotsL %~ filter (not . isAnnotationField))
+ pure $ CBParam $ Untyped.ParameterType p' rootAnn
+ _ -> Left $ FromExpError e $ FEERArgumentCountMismatch (one 1) (length args)
+
+ mkCBStorage
+ :: Exp x
+ -> [Exp x]
+ -> [Annotation]
+ -> Either (FromExpError x) (ContractBlock op)
+ mkCBStorage e args anns = checkAnnsCount e (toAnnSet anns) (0, 0, 0) *>
+ withArgsRec e args CBStorage
+
+ mkCBCode
+ :: Exp x
+ -> [Exp x]
+ -> [Annotation]
+ -> Either (FromExpError x) (ContractBlock op)
+ mkCBCode e args anns = checkAnnsCount e (toAnnSet anns) (0, 0, 0) *>
+ withArgsRec e args CBCode
+
+ mkCBView
+ :: Exp x
+ -> [Exp x]
+ -> [Annotation]
+ -> Either (FromExpError x) (ContractBlock op)
+ mkCBView e args anns = checkAnnsCount e (toAnnSet anns) (0, 0, 0) *>
+ withArgsRec e args (CBView ... Untyped.View)
+
+instance FromExp x Untyped.T where
+ fromExp e@(ExpPrim' _ prim args anns) = assertNoAnns *> withClassifiedPrim prim \case
+ SMPTType -> \case
+ C_Prim_key -> withArgs Untyped.TKey
+ C_Prim_unit -> withArgs Untyped.TUnit
+ C_Prim_signature -> withArgs Untyped.TSignature
+ C_Prim_chain_id -> withArgs Untyped.TChainId
+ C_Prim_option -> withArgs Untyped.TOption
+ C_Prim_list -> withArgs Untyped.TList
+ C_Prim_set -> withArgs Untyped.TSet
+ C_Prim_operation -> withArgs Untyped.TOperation
+ C_Prim_contract -> withArgs Untyped.TContract
+ C_Prim_ticket -> withArgs Untyped.TTicket
+ C_Prim_or
+ | [arg1, arg2] <- args -> 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
+ | otherwise -> Left $ FromExpError e $
+ FEERArgumentCountMismatch (one 2) (length args)
+ C_Prim_pair -> do
+ args2 <- case nonEmpty args >>= forbidSingletonList of
+ Nothing -> Left $ FromExpError e $ FEERNotEnoughArguments 2 (length args)
+ 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
+ C_Prim_lambda -> withArgs Untyped.TLambda
+ C_Prim_map -> withArgs Untyped.TMap
+ C_Prim_big_map -> withArgs Untyped.TBigMap
+ C_Prim_int -> withArgs Untyped.TInt
+ C_Prim_nat -> withArgs Untyped.TNat
+ C_Prim_string -> withArgs Untyped.TString
+ C_Prim_bytes -> withArgs Untyped.TBytes
+ C_Prim_mutez -> withArgs Untyped.TMutez
+ C_Prim_bool -> withArgs Untyped.TBool
+ C_Prim_key_hash -> withArgs Untyped.TKeyHash
+ C_Prim_bls12_381_fr -> withArgs Untyped.TBls12381Fr
+ C_Prim_bls12_381_g1 -> withArgs Untyped.TBls12381G1
+ C_Prim_bls12_381_g2 -> withArgs Untyped.TBls12381G2
+ C_Prim_timestamp -> withArgs Untyped.TTimestamp
+ C_Prim_address -> withArgs Untyped.TAddress
+ C_Prim_chest -> withArgs Untyped.TChest
+ C_Prim_chest_key -> withArgs Untyped.TChestKey
+ C_Prim_tx_rollup_l2_address ->
+ Left $ FromExpError e FEERUnsupported
+ C_Prim_never -> withArgs Untyped.TNever
+ C_Prim_sapling_state -> withArgs Untyped.TSaplingState
+ C_Prim_sapling_transaction -> withArgs Untyped.TSaplingTransaction
+ C_Prim_sapling_transaction_deprecated ->
+ Left $ FromExpError e FEERDeprecated
+ s -> const $ Left $ FromExpError e $ FEERUnexpectedPrimClass MPTType (fromSing s)
+ where
+ assertNoAnns = unless (null anns) $ Left $ FromExpError e FEERUnexpectedAnnotations
+ withArgs :: WithArgsRec x a Untyped.T => a -> Either (FromExpError x) Untyped.T
+ withArgs = withArgsRec e args
+
+ removeAnns :: Exp x -> (Annotation -> Bool) -> Exp x
+ removeAnns expr p =
+ expr & _ExpPrim . _2 . mpaAnnotsL %~ filter (not . p)
+ fromExp e = Left $ FromExpError e $ FEERExpectedPrim $ one MPTType
+
+instance FromExp x Ty where
+ fromExp e = case e of
+ ExpPrim' ex primName args anns -> do
+ let annSet = toAnnSet anns
+ annCnt = annsCount annSet
+ let ta = firstAnn @TypeTag annSet
+ when (secondAnn @TypeTag annSet /= noAnn) $
+ Left $ FromExpError e $ FEERTooManyAnns (Just 1, Nothing, Nothing) annCnt
+ t <- fromExp @x @Untyped.T $ ExpPrim' ex primName args $ filter
+ (not . isAnnotationType) anns
+ pure $ Ty t ta
+ _ -> Left $ FromExpError e $ FEERExpectedPrim (one MPTType)
+
+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 (LambdaCode instr) -> pure $ rfAnyInstr instr
+ VLam LambdaCodeRec{} -> Left $ FromExpError expr $
+ FEERUnexpectedPrim Nothing Prim_Lambda_rec
+
+instance FromExp x ViewName where
+ fromExp e = case e of
+ ExpString _ s ->
+ first (FromExpError e . FEERViewNameError) $ mkViewName s
+ _ -> Left $ FromExpError e FEERExpectedString
+
+----------------------------------------------------------------------------
+-- 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) = do
+ let actualCount = annsCount annSet
+ unless (actualCount <= maxCount) $
+ Left $ FromExpError e $ FEERTooManyAnns (Just maxTas, Just maxFas, Just maxVas) actualCount
+
+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 FEEROutOfBounds)
+ (fromIntegralMaybe @Integer v)
+ _ -> Left $ FromExpError e FEERExpectedNumber
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,10 +8,7 @@
-- | Module that defines Expression type, its related types
-- and its JSON instance.
module Morley.Micheline.Expression
- ( Exp
- ( ..
- , ExpPrim'
- )
+ ( Exp(.., ExpPrim')
, expressionInt
, expressionString
, expressionBytes
@@ -20,9 +17,12 @@
, expressionPrim'
, RegularExp
, Expression
- , MichelinePrimAp(..)
- , MichelinePrimitive(..)
- , michelsonPrimitive
+ , MichelinePrimAp (..)
+ , MichelinePrimitive (..)
+ , MichelinePrimitiveTag (..)
+ , SingMichelinePrimitiveTag (..)
+ , ClassifiedMichelinePrimitive (..)
+ , withClassifiedPrim
, ExpExtensionDescriptorKind
, ExpExtensionDescriptor (..)
@@ -64,7 +64,7 @@
, mpaAnnotsL
) where
-import Control.Lens (Iso', Plated, Prism', iso, prism')
+import Control.Lens (Iso', Plated, Prism', iso)
import Control.Lens.TH (makeLensesWith, makePrisms)
import Data.Aeson
@@ -74,12 +74,16 @@
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types qualified as Aeson
import Data.Data (Data)
-import Data.Sequence qualified as Seq
-import Data.Text qualified as T (uncons)
-import Fmt (Buildable(..), pretty, (+|), (|+))
+import Data.Singletons (Sing, sing)
+import Data.Text qualified as T
+import Fmt (Buildable(..), listF, pretty, tupleF, unwordsF)
+import Language.Haskell.TH (Dec(..), caseE, conE, conP, conT, gadtC, match, normalB)
import Language.Haskell.TH.Syntax (Lift)
+import Morley.Micheline.Expression.Internal.MichelinePrimitive
+import Morley.Micheline.Expression.Internal.TH
import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.TH (promote)
import Morley.Michelson.Untyped qualified as U
import Morley.Michelson.Untyped.Annotation
(AnnotationSet(..), FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag,
@@ -88,53 +92,26 @@
import Morley.Util.ByteString (HexJSONByteString(..))
import Morley.Util.Lens (postfixLFields)
-newtype MichelinePrimitive = MichelinePrimitive Text
- deriving newtype (Eq, Ord, IsString, ToJSON, FromJSON)
- deriving stock (Show, Data, Lift)
+-- | GADT that has the same shape as 'MichelinePrimitive', but each constructor
+-- carries a 'MichelinePrimitiveTag' tag with classification.
+do
+ [DataD cxt' name tvb mk _ ders] <-
+ [d|data ClassifiedMichelinePrimitive (tag :: MichelinePrimitiveTag) where|]
+ cons <- withMichelinePrimitiveCons \nm classifiedName ->
+ gadtC [classifiedName] [] [t|$(conT name) $(promote $ primClassification $ primFromName nm)|]
+ pure [DataD cxt' name tvb mk cons ders]
-michelsonPrimitive :: Seq Text
-michelsonPrimitive = Seq.fromList [
- -- NOTE: The order of this list *matters*!
- --
- -- The position of each item in the list determines which binary code it gets packed to.
- -- E.g.
- -- * "parameter" is at index 0 on the list, so it gets packed to `0x0300`
- -- * "storage" is at index 1, so it gets packed to `0x0301`
- --
- -- You can ask `octez-client` which code corresponds to a given instruction/type/constructor.
- --
- -- > octez-client convert data 'storage' from michelson to binary
- -- > 0x0301
- --
- -- Whenever new instructions/types/constructors are added to the protocol,
- -- we can regenerate this list using this script:
- --
- -- > ./scripts/get-micheline-exprs.sh
- --
- -- or find the full primitives list in the ,
- -- see "prim_encoding" variable.
- --
- "parameter", "storage", "code", "False", "Elt", "Left", "None", "Pair",
- "Right", "Some", "True", "Unit", "PACK", "UNPACK", "BLAKE2B", "SHA256",
- "SHA512", "ABS", "ADD", "AMOUNT", "AND", "BALANCE", "CAR", "CDR",
- "CHECK_SIGNATURE", "COMPARE", "CONCAT", "CONS", "CREATE_ACCOUNT", "CREATE_CONTRACT", "IMPLICIT_ACCOUNT", "DIP",
- "DROP", "DUP", "EDIV", "EMPTY_MAP", "EMPTY_SET", "EQ", "EXEC", "FAILWITH",
- "GE", "GET", "GT", "HASH_KEY", "IF", "IF_CONS", "IF_LEFT", "IF_NONE",
- "INT", "LAMBDA", "LE", "LEFT", "LOOP", "LSL", "LSR", "LT",
- "MAP", "MEM", "MUL", "NEG", "NEQ", "NIL", "NONE", "NOT",
- "NOW", "OR", "PAIR", "PUSH", "RIGHT", "SIZE", "SOME", "SOURCE",
- "SENDER", "SELF", "STEPS_TO_QUOTA", "SUB", "SWAP", "TRANSFER_TOKENS", "SET_DELEGATE", "UNIT",
- "UPDATE", "XOR", "ITER", "LOOP_LEFT", "ADDRESS", "CONTRACT", "ISNAT", "CAST",
- "RENAME", "bool", "contract", "int", "key", "key_hash", "lambda", "list",
- "map", "big_map", "nat", "option", "or", "pair", "set", "signature",
- "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_deprecated", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket",
- "TICKET_DEPRECATED", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE", "chest", "chest_key", "OPEN_CHEST",
- "VIEW", "view", "constant", "SUB_MUTEZ", "tx_rollup_l2_address", "MIN_BLOCK_TIME", "sapling_transaction", "EMIT",
- "Lambda_rec", "LAMBDA_REC", "TICKET", "BYTES", "NAT"
- ]
+-- | Classify a 'MichelinePrimitive'. Intended to be used with @LambdaCase@,
+-- similar to @withClassifiedInstr@.
+withClassifiedPrim
+ :: MichelinePrimitive
+ -> (forall tag. Sing tag -> ClassifiedMichelinePrimitive tag -> r)
+ -> r
+withClassifiedPrim prim f = $(do
+ matches <- withMichelinePrimitiveCons \nm classifiedName ->
+ match (conP nm []) (normalB [|f sing $(conE classifiedName)|]) []
+ caseE [|prim|] $ pure <$> matches
+ )
-- | Type for Micheline Expression with extension points.
--
@@ -264,9 +241,9 @@
expressionPrim :: MichelinePrimAp RegularExp -> Expression
expressionPrim a = ExpPrim () a
-expressionPrim' :: Text -> [Expression] -> [Annotation] -> Expression
-expressionPrim' primName args anns =
- ExpPrim () (MichelinePrimAp (MichelinePrimitive primName) args anns)
+expressionPrim' :: MichelinePrimitive -> [Expression] -> [Annotation] -> Expression
+expressionPrim' prim args anns =
+ ExpPrim () (MichelinePrimAp prim args anns)
-- | Default instance that uses @uniplate@ as implementation.
--
@@ -284,13 +261,9 @@
ExpString () s -> build s
ExpBytes () b ->
build $ encodeBase58Check b
- ExpSeq () s -> "(" +| buildList build s |+ ")"
- ExpPrim () (MichelinePrimAp (MichelinePrimitive text) s annots) ->
- text <> " " |+ "(" +|
- buildList build s +| ") " +|
- buildList (build . annotToText) annots
- where
- buildList buildElem = mconcat . intersperse ", " . map buildElem
+ ExpSeq () s -> listF s
+ ExpPrim () (MichelinePrimAp prim s annots) ->
+ unwordsF [build prim, listF s, tupleF $ annotToText <$> annots]
data Annotation
= AnnotationType TypeAnn
@@ -416,30 +389,7 @@
-- 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
+makePrisms ''Exp
neglecting :: Iso' ((), a) a
neglecting = iso snd pure
diff --git a/src/Morley/Micheline/Expression/Internal/MichelinePrimitive.hs b/src/Morley/Micheline/Expression/Internal/MichelinePrimitive.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Micheline/Expression/Internal/MichelinePrimitive.hs
@@ -0,0 +1,127 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE DeriveLift #-}
+
+-- | Micheline primitive datatype
+module Morley.Micheline.Expression.Internal.MichelinePrimitive
+ ( module Morley.Micheline.Expression.Internal.MichelinePrimitive
+ ) where
+
+import Data.Aeson qualified as Aeson
+import Data.Char (isDigit, isLower, isUpper)
+import Data.Data (Data)
+import Data.Text qualified as T
+import Fmt (Buildable(..), pretty)
+import Language.Haskell.TH.Syntax (Lift)
+
+import Morley.Util.Sing (genSingletonsType)
+
+data MichelinePrimitive
+ -- NOTE: The order of constructors in this datatype *matters*!
+ --
+ -- The position of each constructor determines which binary code it gets
+ -- packed to. E.g.
+ -- * "parameter" is at index 0 on the list, so it gets packed to `0x0300`
+ -- * "storage" is at index 1, so it gets packed to `0x0301`
+ --
+ -- You can ask `octez-client` which code corresponds to a given
+ -- instruction/type/constructor.
+ --
+ -- > octez-client convert data 'storage' from michelson to binary
+ -- > 0x0301
+ --
+ -- Whenever new instructions/types/constructors are added to the protocol, we
+ -- can regenerate this list using this script:
+ --
+ -- > ./scripts/get-micheline-exprs.sh
+ --
+ -- or find the full primitives list in the sources, see "prim_encoding"
+ -- variable.
+ -- https://gitlab.com/tezos/tezos/blob/master/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml
+ --
+ -- Invariant: each constructor starts with `Prim_`
+ = Prim_parameter | Prim_storage | Prim_code | Prim_False | Prim_Elt | Prim_Left
+ | Prim_None | Prim_Pair | Prim_Right | Prim_Some | Prim_True | Prim_Unit
+ | Prim_PACK | Prim_UNPACK | Prim_BLAKE2B | Prim_SHA256 | Prim_SHA512 | Prim_ABS
+ | Prim_ADD | Prim_AMOUNT | Prim_AND | Prim_BALANCE | Prim_CAR | Prim_CDR
+ | Prim_CHECK_SIGNATURE | Prim_COMPARE | Prim_CONCAT | Prim_CONS
+ | Prim_CREATE_ACCOUNT | Prim_CREATE_CONTRACT | Prim_IMPLICIT_ACCOUNT | Prim_DIP
+ | Prim_DROP | Prim_DUP | Prim_EDIV | Prim_EMPTY_MAP | Prim_EMPTY_SET | Prim_EQ
+ | Prim_EXEC | Prim_FAILWITH | Prim_GE | Prim_GET | Prim_GT | Prim_HASH_KEY
+ | Prim_IF | Prim_IF_CONS | Prim_IF_LEFT | Prim_IF_NONE | Prim_INT | Prim_LAMBDA
+ | Prim_LE | Prim_LEFT | Prim_LOOP | Prim_LSL | Prim_LSR | Prim_LT | Prim_MAP
+ | Prim_MEM | Prim_MUL | Prim_NEG | Prim_NEQ | Prim_NIL | Prim_NONE | Prim_NOT
+ | Prim_NOW | Prim_OR | Prim_PAIR | Prim_PUSH | Prim_RIGHT | Prim_SIZE
+ | Prim_SOME | Prim_SOURCE | Prim_SENDER | Prim_SELF | Prim_STEPS_TO_QUOTA
+ | Prim_SUB | Prim_SWAP | Prim_TRANSFER_TOKENS | Prim_SET_DELEGATE | Prim_UNIT
+ | Prim_UPDATE | Prim_XOR | Prim_ITER | Prim_LOOP_LEFT | Prim_ADDRESS
+ | Prim_CONTRACT | Prim_ISNAT | Prim_CAST | Prim_RENAME | Prim_bool
+ | Prim_contract | Prim_int | Prim_key | Prim_key_hash | Prim_lambda | Prim_list
+ | Prim_map | Prim_big_map | Prim_nat | Prim_option | Prim_or | Prim_pair
+ | Prim_set | Prim_signature | Prim_string | Prim_bytes | Prim_mutez
+ | Prim_timestamp | Prim_unit | Prim_operation | Prim_address | Prim_SLICE
+ | Prim_DIG | Prim_DUG | Prim_EMPTY_BIG_MAP | Prim_APPLY | Prim_chain_id
+ | Prim_CHAIN_ID | Prim_LEVEL | Prim_SELF_ADDRESS | Prim_never | Prim_NEVER
+ | Prim_UNPAIR | Prim_VOTING_POWER | Prim_TOTAL_VOTING_POWER | Prim_KECCAK
+ | Prim_SHA3 | Prim_PAIRING_CHECK | Prim_bls12_381_g1 | Prim_bls12_381_g2
+ | Prim_bls12_381_fr | Prim_sapling_state | Prim_sapling_transaction_deprecated
+ | Prim_SAPLING_EMPTY_STATE | Prim_SAPLING_VERIFY_UPDATE | Prim_ticket
+ | Prim_TICKET_DEPRECATED | Prim_READ_TICKET | Prim_SPLIT_TICKET
+ | Prim_JOIN_TICKETS | Prim_GET_AND_UPDATE | Prim_chest | Prim_chest_key
+ | Prim_OPEN_CHEST | Prim_VIEW | Prim_view | Prim_constant | Prim_SUB_MUTEZ
+ | Prim_tx_rollup_l2_address | Prim_MIN_BLOCK_TIME | Prim_sapling_transaction
+ | Prim_EMIT | Prim_Lambda_rec | Prim_LAMBDA_REC | Prim_TICKET | Prim_BYTES
+ | Prim_NAT
+ deriving stock (Eq, Ord, Enum, Bounded, Show, Read, Data, Lift)
+
+type instance PrettyShow MichelinePrimitive = ()
+
+instance Buildable MichelinePrimitive where
+ build = build . T.drop 5 . show
+
+instance Aeson.ToJSON MichelinePrimitive where
+ toJSON = Aeson.String . pretty
+
+instance Aeson.FromJSON MichelinePrimitive where
+ parseJSON = Aeson.withText "MichelinePrimitive" \t ->
+ either (fail . toString) pure $ readEither ("Prim_" <> t)
+
+-- | Simple classification datakind for 'MichelinePrimitive'.
+data MichelinePrimitiveTag
+ = MPTKeyword -- ^ Keywords, like @parameter@, @code@, @storage@, @view@
+ | MPTInstr -- ^ Instructions, e.g. @UNIT@, @DIP@, etc
+ | MPTValue -- ^ Value constructors like @Left@, @Lambda_rec@, etc
+ | MPTType -- ^ Types, like @unit@, @list@, etc
+ | MPTRemoved -- ^ Removed primitives: @CREATE_ACCOUNT@, @STEPS_TO_QUOTA@
+ | MPTConstant -- ^ Keyword @constant@ for global constants
+ deriving stock (Show, Eq, Enum, Bounded, Lift)
+
+instance Buildable MichelinePrimitiveTag where
+ build = \case
+ MPTKeyword -> "keyword"
+ MPTInstr -> "instruction"
+ MPTValue -> "value"
+ MPTType -> "type"
+ MPTRemoved -> "removed"
+ MPTConstant -> "constant"
+
+genSingletonsType ''MichelinePrimitiveTag
+
+-- | Classify 'MichelinePrimitive'. This function uses heuristics to avoid
+-- writing a giant case match, which means it's potentially partial. This should
+-- be fine as it's used with TemplateHaskell, hence if some cases are not
+-- covered, the build will fail.
+primClassification :: MichelinePrimitive -> MichelinePrimitiveTag
+primClassification cs
+ | cs `elem` [Prim_CREATE_ACCOUNT, Prim_STEPS_TO_QUOTA] = MPTRemoved
+ | cs `elem` [Prim_code, Prim_parameter, Prim_storage, Prim_view] = MPTKeyword
+ | cs == Prim_constant = MPTConstant
+ | all (isUpper || (== '_') || isDigit) str = MPTInstr
+ | all (isLower || (== '_') || isDigit) str = MPTType
+ | Just (c, rest) <- T.uncons str
+ , all (isLower || (== '_') || isDigit) rest
+ , isUpper c = MPTValue
+ | otherwise = error $ "Unknown primitive class: " <> str
+ where str = pretty cs :: Text
diff --git a/src/Morley/Micheline/Expression/Internal/TH.hs b/src/Morley/Micheline/Expression/Internal/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Micheline/Expression/Internal/TH.hs
@@ -0,0 +1,33 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | @TemplateHaskell@ helpers
+module Morley.Micheline.Expression.Internal.TH
+ ( module Morley.Micheline.Expression.Internal.TH
+ ) where
+
+import Prelude hiding (Type, lift)
+
+import Language.Haskell.TH
+ (Con(..), Dec(..), Info(..), Lit(..), Name, Q, mkName, nameBase, ppr, reify)
+import Language.Haskell.TH.Lib (caseE, conE, litP, match, normalB)
+
+import Morley.Micheline.Expression.Internal.MichelinePrimitive
+
+withMichelinePrimitiveCons :: (Name -> Name -> Q r) -> Q [r]
+withMichelinePrimitiveCons subs = do
+ TyConI (DataD _ _ _ _ cons _) <- reify ''MichelinePrimitive
+ forM cons \case
+ NormalC nm _ -> subs nm $ mkName $ "C_" <> nameBase nm
+ c -> error $ "unsupported " <> show (ppr c)
+
+-- | Construct 'MichelinePrimitive' from its constructor name. NB: partial function!
+primFromName :: Name -> MichelinePrimitive
+primFromName inputName = $(do
+ TyConI (DataD _ _ _ _ cons _) <- reify ''MichelinePrimitive
+ caseE [|nameBase inputName|] $ cons <&> \case
+ NormalC nm _ -> match (litP $ StringL $ nameBase nm) (normalB $ conE nm) []
+ c -> error $ "unsupported " <> show (ppr c)
+ )
diff --git a/src/Morley/Michelson/Analyzer.hs b/src/Morley/Michelson/Analyzer.hs
--- a/src/Morley/Michelson/Analyzer.hs
+++ b/src/Morley/Michelson/Analyzer.hs
@@ -11,8 +11,7 @@
import Data.Default (def)
import Data.HashMap.Strict qualified as HM
import Data.List.NonEmpty qualified as NE
-import Fmt (Buildable(..), Builder, blockMapF', hexF, nameF, (+|))
-import Unsafe qualified (fromIntegral)
+import Fmt (Buildable(..), Doc, blockMapF', hexF, nameF, (+|))
import Morley.Michelson.FailPattern
import Morley.Michelson.Text (MText)
@@ -66,7 +65,7 @@
longest ::
Container x =>
- Builder -> [(x, Word)] -> ([(x, Word)] -> Builder) -> Builder
+ Doc -> [(x, Word)] -> ([(x, Word)] -> Doc) -> Doc
longest name items builder
| length items > 6 =
nameF ("Longest " <> name) $ builder $ take 4 $ sortByLength items
@@ -100,7 +99,7 @@
countItems :: (Ord i, Hashable i) => [i] -> HashMap i Word
countItems = HM.fromList . map f . NE.group . sort
where
- f ne = (head ne, Unsafe.fromIntegral @Int @Word $ length ne)
+ f ne = (head ne, length @Word ne)
analyzeConstants :: forall i o. Instr i o -> AnalyzerRes
analyzeConstants = \case
diff --git a/src/Morley/Michelson/Doc.hs b/src/Morley/Michelson/Doc.hs
--- a/src/Morley/Michelson/Doc.hs
+++ b/src/Morley/Michelson/Doc.hs
@@ -68,7 +68,7 @@
import Data.Text.Lazy qualified as LT
import Data.Typeable (cast, typeRep)
import Development.GitRev (gitCommitDate, gitHash)
-import Fmt (Buildable, build, fmt, (+|), (|+))
+import Fmt (Buildable, build, fmt, isEmpty, (+|), (|+))
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import System.Environment (lookupEnv)
@@ -804,7 +804,7 @@
attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a
attachToc toc = finalizedAsIs ... modifyDoc $ \case
- DToc "" -> Just toc
+ DToc d | isEmpty d -> Just toc
_ -> Nothing
-- | Attach common information that is available only in the end.
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
@@ -14,9 +14,7 @@
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Data.Default (Default(..))
-import Fmt (Buildable(..))
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended, renderAnyBuildable)
-import Text.PrettyPrint.Leijen.Text ((<+>))
+import Fmt (Buildable(..), (<+>))
import Morley.Util.Aeson
@@ -50,13 +48,9 @@
deriving newtype (Default)
deriving anyclass (NFData)
-instance RenderDoc ErrorSrcPos where
- renderDoc _ ErrorSrcPos{unErrorSrcPos = SrcPos (Pos row) (Pos col)} =
- "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1))
- <> "."
-
instance Buildable ErrorSrcPos where
- build = buildRenderDocExtended
+ build ErrorSrcPos{unErrorSrcPos = SrcPos (Pos row) (Pos col)} =
+ "Error occurred on line" <+> build (row + 1) <+> "char" <+> build (col + 1) <> "."
instance Default Pos where
def = Pos 0
diff --git a/src/Morley/Michelson/Internal/ViewName.hs b/src/Morley/Michelson/Internal/ViewName.hs
--- a/src/Morley/Michelson/Internal/ViewName.hs
+++ b/src/Morley/Michelson/Internal/ViewName.hs
@@ -14,8 +14,8 @@
import Data.Aeson.Types qualified as AesonTypes
import Data.Data (Data)
import Data.Text qualified as Text
-import Fmt (Buildable(..), pretty, (+|), (|+))
-import Text.PrettyPrint.Leijen.Text (Doc, dquotes, textStrict)
+import Fmt (Buildable(..), Doc, pretty, (+|), (|+))
+import Prettyprinter (dquotes)
import Morley.Michelson.Printer.Util
import Morley.Michelson.Text
@@ -84,7 +84,7 @@
return (UnsafeViewName txt)
renderViewName :: ViewName -> Doc
-renderViewName = dquotes . textStrict . unViewName
+renderViewName = dquotes . build . unViewName
instance RenderDoc ViewName where
renderDoc _ = renderViewName
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
@@ -29,8 +29,12 @@
, ContractResult
, extractValOps
, EvalM
+ , EvalM'
, InterpreterStateMonad (..)
- , StkEl (..)
+ , StkEl (.., StkEl)
+ , NoStkElMeta(..)
+ , seValueL
+ , seMetaL
, InstrRunner
, runInstr
, runInstrNoGas
@@ -48,8 +52,16 @@
, runEvalOp
, runInstrImpl
, assignBigMapIds
+ , mapToStkEl
+ , mapToValue
+ , mkStkEl
+ , mkDuplicateStkEl
+ , runEvalOpT
+ , interpret'
, interpretView'
- , EvalOp (..)
+ , StkElMeta(..)
+ , EvalOpT (..)
+ , EvalOp
-- * Prisms
, _MorleyLogs
@@ -57,21 +69,23 @@
import Prelude hiding (EQ, GT, LT)
-import Control.Lens (makeLensesFor, makePrisms, traverseOf, (<<+=))
+import Control.Lens (makeLensesFor, makePrisms, (<<+=))
import Control.Monad.Except (MonadError, liftEither, throwError)
-import Control.Monad.RWS.Strict (RWS, RWST, runRWS)
+import Control.Monad.RWS.Strict (RWST, runRWST)
import Control.Monad.Writer (MonadWriter, WriterT, tell)
import Data.Default (Default(..))
+import Data.GADT.Compare (GEq(..))
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Singletons (demote)
import Data.Singletons.Decide (decideEquality)
import Data.Vinyl (Rec(..), (<+>))
-import Data.Vinyl.Recursive (rmap)
-import Fmt (Buildable(build), blockListF, pretty, prettyLn, (+|), (|+))
+import Data.Vinyl.Recursive (rmap, rtraverse)
+import Fmt
+ (Buildable(build), blockListF, nameF, pretty, quoteOrIndentF, (++|), (+|), (|+), (|++), (|++^))
import Unsafe qualified (fromIntegral)
-import Morley.Michelson.ErrorPos (ErrorSrcPos(..))
+import Morley.Michelson.ErrorPos
import Morley.Michelson.Interpret.Pack (packValue')
import Morley.Michelson.Interpret.Unpack (UnpackError, unpackValue')
import Morley.Michelson.Runtime.GState
@@ -88,12 +102,19 @@
(KeyHash, OpeningResult(..), blake2b, checkSignature, hashKey, keccak, mkTLTime, openChest,
sha256, sha3, sha512)
import Morley.Tezos.Crypto.BLS12381 (checkPairing)
+import Morley.Util.Lens
import Morley.Util.MismatchError
import Morley.Util.Peano (LongerThan, Peano)
import Morley.Util.PeanoNatural (PeanoNatural(..))
import Morley.Util.Sing (eqParamSing)
import Morley.Util.Typeable
+{- $setup
+>>> import Morley.Michelson.ErrorPos
+>>> import Morley.Michelson.Typed
+>>> import Fmt (pretty)
+-}
+
-- | Morley logs appearing as interpreter result.
newtype MorleyLogs = MorleyLogs { unMorleyLogs :: [Text] }
deriving stock (Show, Eq, Generic)
@@ -136,15 +157,85 @@
makePrisms ''MorleyLogs
-newtype StkEl t = StkEl
- { seValue :: Value t
+-- | Represents a value on the stack. Aside from the value itself, it contains
+-- arbitrary user-defined metadata. The metadata in question is defined by
+-- 'StkElMeta' type class, the interpreter doesn't know anything about it.
+--
+-- The metadata should not be copied between different stack elements, the only
+-- case where it can be copied is when the stack element is copied in its
+-- entirety, i.e. when running instructions like @DUP@.
+--
+-- To create a new t'StkEl' from a value, 'mkStkEl' should always be used. For
+-- duplicated stack elements, 'mkDuplicateStkEl' should be used instead, to
+-- still give the user an option to override metadata for the duplicated
+-- element.
+--
+-- The data constructor should almost never be used by itself.
+data StkEl meta t = MkStkEl
+ { seMeta :: meta t
+ , seValue :: Value t
} deriving stock (Eq, Show)
-makeLensesFor
- [ ("seValue", "seValueL")
- ]
- ''StkEl
+makeLensesWith postfixLFields ''StkEl
+instance (forall t. Eq (meta t)) => GEq (StkEl meta) where
+ geq se1 se2
+ | Just Refl <- geq (seValue se1) (seValue se2)
+ , seMeta se1 == seMeta se2
+ = Just Refl
+ | otherwise = Nothing
+
+-- | Arbitrary stack element metadata that can be constructed in a particular
+-- monad. Interpreter doesn't know anything about metadata, and doesn't try to
+-- do anything with it. 'mkStkElMeta' describes how to construct metadata for
+-- new stack elements based on its value. When a stack element is duplicated,
+-- specifically with instructions like @DUP@, old metadata is passed to
+-- 'mkStkElMeta' to provide an opportunity to modify it. Implementation is free
+-- to either copy it verbatim or ignore the old and generate new.
+--
+-- See t'StkEl' documentation for an overview of the motivation and design.
+type StkElMeta :: (T -> Type) -> (Type -> Type) -> Constraint
+class (forall t. Eq (meta t), forall t. Show (meta t)) => StkElMeta meta m where
+ -- | How to construct new metadata.
+ mkStkElMeta
+ :: Maybe (meta t)
+ -- ^ For instructions duplicating the value, this @Just meta@ from the
+ -- original instruction, @Nothing@ otherwise
+ -> Value t
+ -- ^ The value for the new stack element.
+ -> m (meta t)
+
+-- | Default metadata that does nothing.
+data NoStkElMeta t = NoStkElMeta
+ deriving stock (Eq, Show)
+
+instance Applicative m => StkElMeta NoStkElMeta m where
+ mkStkElMeta _ _ = pure NoStkElMeta
+
+-- | Make an entirely new t'StkEl' from a value.
+mkStkEl :: forall meta t m. (Applicative m, StkElMeta meta m) => Value t -> m (StkEl meta t)
+mkStkEl val = flip MkStkEl val <$> mkStkElMeta Nothing val
+
+-- | Make a duplicate t'StkEl', constructing metadata via 'mkStkElMeta'.
+mkDuplicateStkEl
+ :: forall meta t m. (Applicative m, StkElMeta meta m)
+ => StkEl meta t -> m (StkEl meta t)
+mkDuplicateStkEl MkStkEl{..} = flip MkStkEl seValue <$> mkStkElMeta (Just seMeta) seValue
+
+pattern StkEl :: Value t -> StkEl meta t
+pattern StkEl x <- MkStkEl _ x
+{-# COMPLETE StkEl #-}
+
+-- | Helper function to convert a record of @Value@ to @StkEl@.
+mapToStkEl
+ :: forall meta inp m. (Applicative m, StkElMeta meta m)
+ => Rec Value inp -> m (Rec (StkEl meta) inp)
+mapToStkEl = rtraverse $ mkStkEl
+
+-- | Helper function to convert a record of @StkEl@ to @Value@.
+mapToValue :: Rec (StkEl meta) inp -> Rec Value inp
+mapToValue = rmap seValue
+
type ContractEnv :: Type
type ContractEnv = ContractEnv' EvalOp
@@ -223,7 +314,7 @@
build =
\case
MichelsonFailedWith v ->
- "Reached FAILWITH instruction with " +| v |+ ""
+ "Reached FAILWITH instruction with" ++| quoteOrIndentF v |++^ ""
MichelsonArithError v -> build v
MichelsonGasExhaustion ->
"Gas limit exceeded on contract execution"
@@ -238,8 +329,33 @@
, mfwsErrorSrcPos :: ErrorSrcPos
} deriving stock (Show, Generic, Eq)
+{- | Pretty-printer for 'MichelsonFailureWithStack'.
+
+>>> let pos = ErrorSrcPos $ SrcPos (Pos 123) (Pos 456)
+>>> let largeValue = VList $ replicate 10 VUnit
+
+>>> pretty $ MichelsonFailureWithStack @Void MichelsonGasExhaustion pos
+Gas limit exceeded on contract execution at line 124 char 457.
+
+>>> pretty $ MichelsonFailureWithStack @Void (MichelsonFailedWith VUnit) pos
+Reached FAILWITH instruction with 'Unit' at line 124 char 457.
+
+>>> pretty $ MichelsonFailureWithStack @Void (MichelsonFailedWith largeValue) pos
+Reached FAILWITH instruction with
+ { Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit }
+at line 124 char 457.
+
+>>> pretty $ MichelsonFailureWithStack @Void (MichelsonFailedWith $ VPair (largeValue, largeValue)) pos
+Reached FAILWITH instruction with
+ Pair
+ { Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit }
+ { Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit; Unit }
+at line 124 char 457.
+-}
instance Buildable ext => Buildable (MichelsonFailureWithStack ext) where
- build (MichelsonFailureWithStack err loc) = build err <> " at " <> build loc
+ build (MichelsonFailureWithStack err loc)
+ | SrcPos (Pos row) (Pos col) <- unErrorSrcPos loc
+ = "" ++| err |++ "at line" ++| build (row + 1) |++ "char" ++| build (col + 1) <> "." |++ ""
data InterpretError ext = InterpretError
{ ieLogs :: MorleyLogs
@@ -249,7 +365,7 @@
deriving stock instance Show ext => Show (InterpretError ext)
instance Buildable ext => Buildable (InterpretError ext) where
- build InterpretError{..} = prettyLn ieFailure
+ build InterpretError{..} = pretty ieFailure
data ResultStateLogs res = ResultStateLogs
{ rslResult :: res
@@ -283,7 +399,7 @@
handleReturn rsl@ResultStateLogs{..} = first (InterpretError rslLogs) . sequence $ rsl
-- | Reset 'ceMetaWrapper` after it is used with an instr.
-withMetaWrapper :: forall ext m. EvalM' ext m => InstrRunner m -> InstrRunner m
+withMetaWrapper :: forall ext meta m. EvalM' ext m => InstrRunner meta m -> InstrRunner meta m
withMetaWrapper runner instr s = do
ContractEnv{ceMetaWrapper} <- ask
local (\env -> env {ceMetaWrapper = id}) $
@@ -293,38 +409,28 @@
extractValOps :: Value (ContractOut1 st) -> ([Operation], Value st)
extractValOps (VPair x) = first fromVal x
--- | Helper function to convert a record of @Value@ to @StkEl@. These will be
--- created with @starNotes@.
-mapToStkEl :: Rec Value inp -> Rec StkEl inp
-mapToStkEl = rmap StkEl
-
--- | Helper function to convert a record of @StkEl@ to @Value@. Any present
--- notes will be discarded.
-mapToValue :: Rec StkEl inp -> Rec Value inp
-mapToValue = rmap seValue
-
interpret'
- :: forall cp st arg.
- Contract cp st
+ :: forall cp st arg m. (Monad m)
+ => Contract cp st
-> EntrypointCallT cp arg
-> Value arg
-> Value st
- -> ContractEnv
+ -> ContractEnv' (EvalOpT m)
-> InterpreterState
- -> ContractReturn st
-interpret' Contract{..} epc param initSt env ist = (fmap . fmap) (\(StkEl val :& RNil) -> val) $
- runEvalOp
- (runInstr (unContractCode cCode) $ mkInitStack (liftCallArg epc param) initSt)
+ -> m (ContractReturn st)
+interpret' Contract{..} epc param initSt env ist = (fmap . fmap) (\(StkEl val :& RNil) -> val) <$>
+ runEvalOpT
+ (runInstr (unContractCode cCode) =<< mapToStkEl @NoStkElMeta initStack)
env
ist
+ where
+ initStack = mkInitStack (liftCallArg epc param) initSt
mkInitStack
:: Value param
-> Value st
- -> Rec StkEl (ContractInp param st)
-mkInitStack param st = StkEl
- (VPair (param, st))
- :& RNil
+ -> Rec Value (ContractInp param st)
+mkInitStack param st = VPair (param, st) :& RNil
interpret
:: Contract cp st
@@ -335,7 +441,7 @@
-> BigMapCounter
-> ContractEnv
-> ContractReturn st
-interpret contract epc param initSt globalCounter bmCounter env =
+interpret contract epc param initSt globalCounter bmCounter env = runIdentity $
interpret' contract epc param initSt env (initInterpreterState globalCounter bmCounter env)
initInterpreterState :: GlobalCounter -> BigMapCounter -> ContractEnv -> InterpreterState
@@ -361,11 +467,11 @@
:: ContractEnv
-> Instr inp out
-> Rec Value inp
- -> Either (MichelsonFailureWithStack Void) (Rec StkEl out)
+ -> Either (MichelsonFailureWithStack Void) (Rec (StkEl NoStkElMeta) out)
interpretInstrAnnotated env instr inpSt =
rslResult $
runEvalOp
- (runInstr instr $ mapToStkEl inpSt)
+ (runInstr instr =<< mapToStkEl @NoStkElMeta inpSt)
env
InterpreterState
{ isRemainingSteps = 9999999999
@@ -373,35 +479,52 @@
, isGlobalCounter = 0
}
-data SomeItStack where
- SomeItStack :: ExtInstr inp -> Rec StkEl inp -> SomeItStack
+data SomeItStack meta where
+ SomeItStack :: ExtInstr inp -> Rec (StkEl meta) inp -> SomeItStack meta
--- | The main interpreter monad. Downstream consumers which use 'runInstrImpl'
--- directly may define their own monad similar to this one.
+-- | The main interpreter monad, used by the higher-level functions like
+-- 'interpret' and 'interpretView'.
--
+-- Downstream consumers which use 'runInstrImpl' directly may define their own
+-- monad similar to this one, or alternatively use 'EvalOpT' with the slightly
+-- lower-level functions, e.g. `interpret'` and `interpretView'`.
+type EvalOp = EvalOpT Identity
+
+-- | The main interpreter monad transformer. Provides a more convenient way of
+-- enriching the interpreter monad without redefining it entirely.
+--
-- This is a newtype and not a type synonym due to the reader environment, i.e.
--- t'ContractEnv', being parameterized by this monad.
-newtype EvalOp a = EvalOp
- (ExceptT (MichelsonFailureWithStack Void) (RWS ContractEnv MorleyLogsBuilder InterpreterState) a)
+-- t'ContractEnv', being parameterized by the interpreter monad.
+newtype EvalOpT m a = EvalOpT
+ (ExceptT (MichelsonFailureWithStack Void)
+ (RWST (ContractEnv' (EvalOpT m)) MorleyLogsBuilder InterpreterState m) a)
deriving newtype
( MonadError (MichelsonFailureWithStack Void)
, MonadState InterpreterState
, InterpreterStateMonad
, MonadWriter MorleyLogsBuilder
- , MonadReader ContractEnv
+ , MonadReader (ContractEnv' (EvalOpT m))
, Monad
, Applicative
, Functor
+ , MonadIO
)
-runEvalOp
- :: EvalOp a
- -> ContractEnv
+instance MonadTrans EvalOpT where
+ lift = EvalOpT . lift . lift
+
+runEvalOp :: EvalOp a -> ContractEnv -> InterpreterState -> RunEvalOpReturn a
+runEvalOp = runIdentity ... runEvalOpT
+
+runEvalOpT
+ :: Monad m
+ => EvalOpT m a
+ -> ContractEnv' (EvalOpT m)
-> InterpreterState
- -> RunEvalOpReturn a
-runEvalOp (EvalOp act) env initSt =
- let (rslResult, rslState, buildMorleyLogs -> rslLogs) = runRWS (runExceptT act) env initSt
- in ResultStateLogs{..}
+ -> m (RunEvalOpReturn a)
+runEvalOpT (EvalOpT act) env initSt = do
+ (rslResult, rslState, buildMorleyLogs -> rslLogs) <- runRWST (runExceptT act) env initSt
+ pure ResultStateLogs{..}
class Monad m => InterpreterStateMonad m where
getInterpreterState :: m InterpreterState
@@ -445,17 +568,17 @@
type EvalM m = EvalM' Void m
-type InstrRunner m =
+type InstrRunner meta m =
forall inp out.
Instr inp out
- -> Rec StkEl inp
- -> m (Rec StkEl out)
+ -> Rec (StkEl meta) inp
+ -> m (Rec (StkEl meta) out)
throwMichelson :: EvalM' ext m => MichelsonFailed ext -> m a
throwMichelson mf = asks ceErrorSrcPos >>= throwError . MichelsonFailureWithStack mf
-- | Function to change amount of remaining steps stored in State monad.
-runInstr :: EvalM' ext m => InstrRunner m
+runInstr :: forall ext meta m. (StkElMeta meta m, EvalM' ext m) => InstrRunner meta 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
@@ -470,14 +593,20 @@
modifyInterpreterState (\s -> s {isRemainingSteps = rs - 1})
runInstrImpl runInstr i r
-runInstrNoGas :: EvalM m => InstrRunner m
+runInstrNoGas :: EvalM m => InstrRunner NoStkElMeta m
runInstrNoGas = runInstrImpl runInstrNoGas
+(<:&>) :: Functor f => f (a r) -> Rec a rs -> f (Rec a (r : rs))
+m <:&> r = fmap (:& r) m
+infixr 7 <:&>
+
-- | Function to interpret Michelson instruction(s) against given stack.
-- The @ext@ type variable specifies additional exceptions that can be thrown from the inner
-- runner function (via 'MichelsonExt'). In Morley, it's set to 'Void', but downstream consumers
-- may use other type here.
-runInstrImpl :: forall ext m. EvalM' ext m => InstrRunner m -> InstrRunner m
+runInstrImpl
+ :: forall ext meta m. (EvalM' ext m, StkElMeta meta m)
+ => InstrRunner meta m -> InstrRunner meta m
runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'
runInstrImpl runner (WithLoc ics i) r = do
-- Add wrapper which will be used later on in loop-like instr.
@@ -508,15 +637,15 @@
-- by a natural number like 'DIPN'.
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
+ duplicateStkEl <- seValueL assignBigMapIds' =<< mkDuplicateStkEl stkEl
pure $ duplicateStkEl :& stkEl :& r
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)
+ => PeanoNatural n -> Rec (StkEl meta) inp -> m (Rec (StkEl meta) 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
+ duplicateStkEl <- seValueL assignBigMapIds' =<< mkDuplicateStkEl stkEl
pure $ duplicateStkEl :& stk
go (Succ n@(Succ _)) (b :& r) =
go n r <&> \case
@@ -526,7 +655,7 @@
pure $ go s input0
where
go :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a
- => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out
+ => PeanoNatural n -> Rec (StkEl meta) inp -> Rec (StkEl meta) out
go Zero stack = stack
go (Succ n') (b :& r) =
case go n' r of
@@ -535,94 +664,102 @@
pure $ go s input0
where
go :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a
- => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out
+ => PeanoNatural n -> Rec (StkEl meta) inp -> Rec (StkEl meta) out
go Zero stack = stack
go (Succ n') (a :& b :& r) = b :& go n' (a :& r)
runInstrImpl _ AnnSOME{} ((seValue -> a) :& r) =
withValueTypeSanity a $
- 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
+ mkStkEl (VOption (Just a)) <:&> r
+runInstrImpl _ (AnnPUSH _ v) r = mkStkEl v <:&> r
+runInstrImpl _ AnnNONE{} r = mkStkEl (VOption Nothing) <:&> r
+runInstrImpl _ AnnUNIT{} r = mkStkEl VUnit <:&> r
runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) :& r) =
- runner bJust (StkEl a :& r)
+ runner bJust =<< mkStkEl 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 $ 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
+ mkStkEl (VPair (a, b)) <:&> r
+runInstrImpl _ (AnnUNPAIR{}) ((StkEl (VPair (a, b))) :& r) = do
+ el1 <- mkStkEl a
+ el2 <- mkStkEl b
+ pure $ el1 :& el2 :& r
+runInstrImpl _ (AnnPAIRN _ s) stack = go s stack
where
- go :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Rec StkEl inp -> Rec StkEl (PairN n inp)
+ go :: forall n inp. ConstraintPairN n inp
+ => PeanoNatural n
+ -> Rec (StkEl meta) inp
+ -> m (Rec (StkEl meta) (PairN n inp))
go (Succ (Succ Zero)) (StkEl a :& StkEl b :& r) =
-- if n=2
- StkEl (VPair (a, b)) :& r
+ mkStkEl (VPair (a, b)) <:&> r
go (Succ n@(Succ (Succ _))) (StkEl a :& r@(_ :& _ :& _)) =
-- if n>2
- case go n r of
+ go n r >>= \case
StkEl combed :& r' ->
- StkEl (VPair (a, combed)) :& r'
+ mkStkEl (VPair (a, combed)) <:&> r'
runInstrImpl _ (UNPAIRN s) (StkEl pair0 :& r) = do
- pure $ go s pair0 <+> r
+ r' <- go s pair0
+ pure $ r' <+> r
where
go
:: forall n pair. ConstraintUnpairN n pair
=> PeanoNatural n -> Value pair
- -> Rec StkEl (UnpairN n pair)
+ -> m (Rec (StkEl meta) (UnpairN n pair))
go n pair =
case (n, pair) of
-- if n=2
- (Succ (Succ Zero), VPair (a, b)) ->
- StkEl a
- :& StkEl b
- :& RNil
+ (Succ (Succ Zero), VPair (a, b)) -> do
+ el1 <- mkStkEl a
+ el2 <- mkStkEl b
+ pure $ el1 :& el2 :& RNil
-- if n>2
(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
+ liftA2 (:&) (mkStkEl a) (go n' b)
+runInstrImpl _ AnnCAR{} (StkEl (VPair (a, _b)) :& r) = mkStkEl a <:&> r
+runInstrImpl _ AnnCDR{} (StkEl (VPair (_a, b)) :& r) = mkStkEl b <:&> r
runInstrImpl _ AnnLEFT{} ((StkEl a) :& r) =
withValueTypeSanity a $
- pure $ StkEl (VOr $ Left a) :& r
+ mkStkEl (VOr $ Left a) <:&> r
runInstrImpl _ AnnRIGHT{} ((StkEl b) :& r) =
withValueTypeSanity b $
- pure $ StkEl (VOr $ Right b) :& r
+ mkStkEl (VOr $ Right b) <:&> r
runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) :& r) =
- runner bLeft (StkEl a :& r)
+ runner bLeft =<< mkStkEl 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
+ runner bRight =<< mkStkEl a <:&> r
+runInstrImpl _ AnnNIL{} r = mkStkEl (VList []) <:&> r
+runInstrImpl _ AnnCONS{} (a :& StkEl (VList l) :& r) = mkStkEl (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 runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) :& r) = do
+ el1 <- mkStkEl lh
+ el2 <- mkStkEl (VList lr)
+ runner bCons $ el1 :& el2 :& r
+runInstrImpl _ AnnSIZE{} (a :& r) =
+ mkStkEl (VNat $ Unsafe.fromIntegral @Int @Natural $ evalSize $ seValue a) <:&> r
+runInstrImpl _ AnnEMPTY_SET{} r = mkStkEl (VSet Set.empty) <:&> r
+runInstrImpl _ AnnEMPTY_MAP{} r = mkStkEl (VMap Map.empty) <:&> r
runInstrImpl _ AnnEMPTY_BIG_MAP{} r = do
bigMap <- assignBigMapIds' $ VBigMap Nothing Map.empty
- pure $ StkEl bigMap :& r
+ mkStkEl 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
+ (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl meta (MapOpInp c)) -> do
res <- runner code (val :& curStack)
case res of
((seValue -> nextVal :: Value b) :& nextStack) -> pure (nextStack, nextVal : curList))
- (r, []) ((\el -> StkEl el) <$> mapOpToList @c a)
- pure $ StkEl (mapOpFromList a (reverse newList)) :& newStack
+ (r, []) =<< traverse mkStkEl (mapOpToList @c a)
+ mkStkEl (mapOpFromList a (reverse newList)) <:&> newStack
runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a :& r) =
case iterOpDetachOne @c a of
(Just x, xs) -> do
- res <- runner code (StkEl x :& r)
- withMetaWrapper runner (ITER code) (StkEl xs :& res)
+ res <- runner code =<< mkStkEl x <:&> r
+ withMetaWrapper runner (ITER code) =<< mkStkEl xs <:&> res
(Nothing, _) -> pure r
-runInstrImpl _ AnnMEM{} (a :& b :& r) = pure $ StkEl (VBool (evalMem (seValue a) (seValue b))) :& r
-runInstrImpl _ AnnGET{} (a :& b :& r) = pure $ StkEl (VOption (evalGet (seValue a) (seValue b))) :& r
+runInstrImpl _ AnnMEM{} (a :& b :& r) = mkStkEl (VBool (evalMem (seValue a) (seValue b))) <:&> r
+runInstrImpl _ AnnGET{} (a :& b :& r) = mkStkEl (VOption (evalGet (seValue a) (seValue b))) <:&> r
runInstrImpl _ (AnnGETN _ s) (StkEl pair :& r) = do
- pure $ StkEl (go s pair) :& r
+ mkStkEl (go s pair) <:&> r
where
go
:: forall ix a. ConstraintGetN ix a
@@ -632,9 +769,9 @@
go (Succ Zero) (VPair (left, _)) = left
go (Succ (Succ n')) (VPair (_, right)) = go n' right
runInstrImpl _ AnnUPDATE{} (a :& b :& StkEl c :& r) =
- pure $ StkEl (evalUpd (seValue a) (seValue b) c) :& r
+ mkStkEl (evalUpd (seValue a) (seValue b) c) <:&> r
runInstrImpl _ (AnnUPDATEN _ s) (StkEl (val :: Value val) :& StkEl pair :& r) = do
- pure $ StkEl (go s pair) :& r
+ mkStkEl (go s pair) <:&> r
where
go
:: forall ix pair. ConstraintUpdateN ix pair
@@ -642,23 +779,22 @@
go Zero _ = val
go (Succ Zero) (VPair (_, right)) = VPair (val, right)
go (Succ (Succ n')) (VPair (left, right)) = VPair (left, go n' right)
-runInstrImpl _ AnnGET_AND_UPDATE{} (StkEl key :& StkEl valMb :& StkEl collection :& r) =
- pure $
- StkEl (VOption (evalGet key collection))
- :& StkEl (evalUpd key valMb collection)
- :& r
+runInstrImpl _ AnnGET_AND_UPDATE{} (StkEl key :& StkEl valMb :& StkEl collection :& r) = do
+ el1 <- mkStkEl (VOption (evalGet key collection))
+ el2 <- mkStkEl (evalUpd key valMb collection)
+ pure $ el1 :& el2 :& 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
res <- runner ops r
withMetaWrapper runner (LOOP ops) res
-runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) :& r) = pure $ StkEl a :& r
+runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) :& r) = mkStkEl a <:&> r
runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) :& r) = do
- res <- runner ops (StkEl a :& r)
+ res <- runner ops =<< mkStkEl a <:&> r
withMetaWrapper runner (LOOP_LEFT ops) res
-runInstrImpl _ (AnnLAMBDA _ lam) r = pure $ StkEl (mkVLam lam) :& r
-runInstrImpl _ (AnnLAMBDA_REC _ lam) r = pure $ StkEl (mkVLamRec lam) :& r
+runInstrImpl _ (AnnLAMBDA _ lam) r = mkStkEl (mkVLam lam) <:&> r
+runInstrImpl _ (AnnLAMBDA_REC _ lam) r = mkStkEl (mkVLamRec lam) <:&> r
runInstrImpl runner AnnEXEC{} (a :& self@(StkEl (VLam code)) :& r) =
case code of
LambdaCode (rfAnyInstr -> lBody) -> do
@@ -671,10 +807,10 @@
| _ :: Instr (a : 'TLambda ('TPair a b) c : s) ('TLambda b c : s) <- i
, _ :: LambdaCode' Instr ('TPair a b) c <- code
= case code of
- LambdaCode lBody -> pure $ StkEl (VLam $ LambdaCode (rfMapAnyInstr doApply lBody)) :& r
+ LambdaCode lBody -> mkStkEl (VLam $ LambdaCode (rfMapAnyInstr doApply lBody)) <:&> r
LambdaCodeRec lBody ->
let res = RfNormal $ PUSH a `Seq` PAIR `Seq` LAMBDA_REC lBody `Seq` SWAP `Seq` EXEC
- in pure $ StkEl (VLam $ LambdaCode res) :& r
+ in mkStkEl (VLam $ LambdaCode res) <:&> r
where
doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o
doApply b = PUSH a `Seq` PAIR `Seq` Nested b
@@ -689,53 +825,53 @@
runInstrImpl _ FAILWITH (a :& _) = throwMichelson $ MichelsonFailedWith (seValue a)
runInstrImpl _ AnnCAST{} s = pure s
runInstrImpl _ AnnRENAME{} s = pure s
-runInstrImpl _ AnnPACK{} ((seValue -> a) :& r) = pure $ StkEl (VBytes $ packValue' a) :& r
+runInstrImpl _ AnnPACK{} ((seValue -> a) :& r) = mkStkEl (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
+ mkStkEl (VOption . rightToMaybe $ runUnpack a) <:&> r
+runInstrImpl _ AnnCONCAT{} (a :& b :& r) = mkStkEl (evalConcat (seValue a) (seValue b)) <:&> r
+runInstrImpl _ AnnCONCAT'{} (StkEl (VList a) :& r) = mkStkEl (evalConcat' a) <:&> r
runInstrImpl _ AnnSLICE{} (StkEl (VNat o) :& StkEl (VNat l) :& StkEl s :& r) =
- pure $ StkEl (VOption (evalSlice o l s)) :& r
+ mkStkEl (VOption (evalSlice o l s)) <:&> r
runInstrImpl _ AnnISNAT{} (StkEl (VInt i) :& r) =
if i < 0
- 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
+ then mkStkEl (VOption Nothing) <:&> r
+ else mkStkEl (VOption (Just (VNat $ fromInteger i))) <:&> r
+runInstrImpl _ AnnADD{} (l :& r :& rest) = runArithOp (Proxy @Add) l r <:&> rest
+runInstrImpl _ AnnSUB{} (l :& r :& rest) = runArithOp (Proxy @Sub) l r <:&> rest
+runInstrImpl _ AnnSUB_MUTEZ{} (l :& r :& rest) = runArithOp (Proxy @SubMutez) l r <:&> rest
+runInstrImpl _ AnnMUL{} (l :& r :& rest) = runArithOp (Proxy @Mul) l r <:&> rest
+runInstrImpl _ AnnEDIV{} (l :& r :& rest) = runArithOp (Proxy @EDiv) l r <:&> rest
runInstrImpl _ AnnABS{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest
+ mkStkEl (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
+ mkStkEl (evalUnaryArithOp (Proxy @Neg) a) <:&> rest
+runInstrImpl _ AnnLSL{} (x :& s :& rest) = runArithOp (Proxy @Lsl) x s <:&> rest
+runInstrImpl _ AnnLSR{} (x :& s :& rest) = runArithOp (Proxy @Lsr) x s <:&> rest
+runInstrImpl _ AnnOR{} (l :& r :& rest) = runArithOp (Proxy @Or) l r <:&> rest
+runInstrImpl _ AnnAND{} (l :& r :& rest) = runArithOp (Proxy @And) l r <:&> rest
+runInstrImpl _ AnnXOR{} (l :& r :& rest) = runArithOp (Proxy @Xor) l r <:&> rest
runInstrImpl _ AnnNOT{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Not) a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Not) a) <:&> rest
runInstrImpl _ AnnCOMPARE{} ((seValue -> l) :& (seValue -> r) :& rest) =
- pure $ StkEl (VInt (compareOp l r)) :& rest
+ mkStkEl (VInt (compareOp l r)) <:&> rest
runInstrImpl _ AnnEQ{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Eq') a) <:&> rest
runInstrImpl _ AnnNEQ{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Neq) a) <:&> rest
runInstrImpl _ AnnLT{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Lt) a) <:&> rest
runInstrImpl _ AnnGT{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Gt) a) <:&> rest
runInstrImpl _ AnnLE{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Le) a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Le) a) <:&> rest
runInstrImpl _ AnnGE{} ((seValue -> a) :& rest) =
- pure $ StkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest
+ mkStkEl (evalUnaryArithOp (Proxy @Ge) a) <:&> rest
runInstrImpl _ AnnINT{} (StkEl a :& r) =
- pure $ StkEl (evalToIntOp a) :& r
+ mkStkEl (evalToIntOp a) <:&> r
runInstrImpl _ AnnNAT{} (StkEl a :& r) =
- pure $ StkEl (evalToNatOp a) :& r
+ mkStkEl (evalToNatOp a) <:&> r
runInstrImpl _ AnnBYTES{} (StkEl a :& r) =
- pure $ StkEl (evalToBytesOp a) :& r
+ mkStkEl (evalToBytesOp a) <:&> r
runInstrImpl runner (AnnVIEW (Anns2' _ (_ :: Notes ret)) name)
(StkEl (viewArg :: Value arg) :& StkEl (VAddress epAddr) :& r) = do
res :: Value ('TOption ret) <- VOption <$> runMaybeT do
@@ -754,13 +890,13 @@
, ..
}
lift $ interpretView' runner viewEnv view' viewedContractStorage viewArg
- pure (StkEl res :& r)
+ mkStkEl res <:&> r
runInstrImpl _ (AnnSELF _ sepc :: Instr inp out) r = do
ContractEnv{..} <- ask
case Proxy @out of
(_ :: Proxy ('TContract cp ': s)) -> do
- pure $ StkEl (VContract (MkAddress ceSelf) sepc) :& r
+ mkStkEl (VContract (MkAddress ceSelf) sepc) <:&> r
runInstrImpl _ (AnnCONTRACT (Anns2' _ (_ :: Notes a)) instrEpName) (StkEl (VAddress epAddr) :& r) = do
ContractEnv{..} <- ask
EpAddress' (Constrained addr) addrEpName <- pure epAddr
@@ -771,8 +907,8 @@
(en, DefEpName) -> Just en
_ -> Nothing
- let withNotes v = StkEl v :& r
- withNotes . VOption <$> case mepName of
+ let withNotes v = mkStkEl v <:&> r
+ withNotes . VOption =<< case mepName of
Nothing -> pure Nothing
Just epName -> case addr of
ImplicitAddress{} -> pure $ case sing @a of
@@ -798,13 +934,13 @@
(StkEl p :& StkEl (VMutez mutez) :& StkEl contract :& r) = do
incrementCounter
globalCounter <- isGlobalCounter <$> getInterpreterState
- pure $ StkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract globalCounter)) :& r
+ mkStkEl (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 $ StkEl (VOp (OpSetDelegate $ SetDelegate (Just k) globalCounter)) :& r
- Nothing -> pure $ StkEl (VOp (OpSetDelegate $ SetDelegate Nothing globalCounter)) :& r
+ Just (VKeyHash k) -> mkStkEl (VOp (OpSetDelegate $ SetDelegate (Just k) globalCounter)) <:&> r
+ Nothing -> mkStkEl (VOp (OpSetDelegate $ SetDelegate Nothing globalCounter)) <:&> r
runInstrImpl _ (AnnCREATE_CONTRACT _ contract)
(StkEl (VOption mbKeyHash) :& StkEl (VMutez m) :& StkEl g :& r) = do
originator <- ceSelf <$> ask
@@ -826,89 +962,88 @@
let resEpAddr = EpAddress resAddr DefEpName
let resOp = CreateContract
(Constrained originator) (unwrapMbKeyHash mbKeyHash) m g contract globalCounter
- pure $ StkEl (VOp (OpCreateContract resOp))
- :& StkEl (VAddress resEpAddr)
- :& r
+ el1 <- mkStkEl (VOp (OpCreateContract resOp))
+ el2 <- mkStkEl (VAddress resEpAddr)
+ pure $ el1 :& el2 :& r
runInstrImpl _ AnnIMPLICIT_ACCOUNT{} (StkEl (VKeyHash k) :& r) =
- pure $ (StkEl (VContract (MkAddress $ ImplicitAddress k) sepcPrimitive)) :& r
+ mkStkEl (VContract (MkAddress $ ImplicitAddress k) sepcPrimitive) <:&> r
runInstrImpl _ AnnNOW{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VTimestamp ceNow) :& r
+ mkStkEl (VTimestamp ceNow) <:&> r
runInstrImpl _ AnnAMOUNT{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VMutez ceAmount) :& r
+ mkStkEl (VMutez ceAmount) <:&> r
runInstrImpl _ AnnBALANCE{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VMutez ceBalance) :& r
+ mkStkEl (VMutez ceBalance) <:&> r
runInstrImpl _ AnnVOTING_POWER{} (StkEl (VKeyHash k) :& r) = do
ContractEnv{..} <- ask
- pure $ StkEl (VNat $ vpPick k ceVotingPowers) :& r
+ mkStkEl (VNat $ vpPick k ceVotingPowers) <:&> r
runInstrImpl _ AnnTOTAL_VOTING_POWER{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VNat $ vpTotal ceVotingPowers) :& r
+ mkStkEl (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
+ mkStkEl (VBool $ checkSignature k v b) <:&> r
runInstrImpl _ AnnSHA256{} (StkEl (VBytes b) :& r) =
- pure $ StkEl (VBytes $ sha256 b) :& r
+ mkStkEl (VBytes $ sha256 b) <:&> r
runInstrImpl _ AnnSHA512{} (StkEl (VBytes b) :& r) =
- pure $ StkEl (VBytes $ sha512 b) :& r
+ mkStkEl (VBytes $ sha512 b) <:&> r
runInstrImpl _ AnnBLAKE2B{} (StkEl (VBytes b) :& r) =
- pure $ StkEl (VBytes $ blake2b b) :& r
+ mkStkEl (VBytes $ blake2b b) <:&> r
runInstrImpl _ AnnSHA3{} (StkEl (VBytes b) :& r) =
- pure $ StkEl (VBytes $ sha3 b) :& r
+ mkStkEl (VBytes $ sha3 b) <:&> r
runInstrImpl _ AnnKECCAK{} (StkEl (VBytes b) :& r) =
- pure $ StkEl (VBytes $ keccak b) :& r
+ mkStkEl (VBytes $ keccak b) <:&> r
runInstrImpl _ AnnHASH_KEY{} (StkEl (VKey k) :& r) =
- pure $ StkEl (VKeyHash $ hashKey k) :& r
+ mkStkEl (VKeyHash $ hashKey k) <:&> r
runInstrImpl _ AnnPAIRING_CHECK{} (StkEl (VList pairs) :& r) = do
let pairs' = [ (g1, g2) | VPair (VBls12381G1 g1, VBls12381G2 g2) <- pairs ]
- pure $ StkEl (VBool $ checkPairing pairs') :& r
+ mkStkEl (VBool $ checkPairing pairs') <:&> r
runInstrImpl _ AnnSOURCE{} r = do
ContractEnv{ceSource=Constrained ceSource} <- ask
- pure $ StkEl (VAddress $ EpAddress ceSource DefEpName) :& r
+ mkStkEl (VAddress $ EpAddress ceSource DefEpName) <:&> r
runInstrImpl _ AnnSENDER{} r = do
ContractEnv{ceSender=Constrained ceSender} <- ask
- pure $ StkEl (VAddress $ EpAddress ceSender DefEpName) :& r
+ mkStkEl (VAddress $ EpAddress ceSender DefEpName) <:&> r
runInstrImpl _ AnnADDRESS{} (StkEl (VContract a sepc) :& r) =
- pure $ StkEl (VAddress $ EpAddress' a (sepcName sepc)) :& r
+ mkStkEl (VAddress $ EpAddress' a (sepcName sepc)) <:&> r
runInstrImpl _ AnnCHAIN_ID{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VChainId ceChainId) :& r
+ mkStkEl (VChainId ceChainId) <:&> r
runInstrImpl _ AnnLEVEL{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VNat ceLevel) :& r
+ mkStkEl (VNat ceLevel) <:&> r
runInstrImpl _ AnnSELF_ADDRESS{} r = do
ContractEnv{..} <- ask
- pure $ StkEl (VAddress $ EpAddress ceSelf DefEpName) :& r
+ mkStkEl (VAddress $ EpAddress ceSelf DefEpName) <:&> r
runInstrImpl _ AnnTICKET{} (StkEl dat :& StkEl (VNat am) :& r) = do
ContractEnv{..} <- ask
let result = VOption do
guard (am /= 0)
pure $ VTicket (MkAddress ceSelf) dat am
- pure $ StkEl (result) :& r
+ mkStkEl result <:&> r
runInstrImpl _ AnnTICKET_DEPRECATED{} (StkEl dat :& StkEl (VNat am) :& r) = do
ContractEnv{..} <- ask
- pure $ StkEl (VTicket (MkAddress ceSelf) dat am) :& r
+ mkStkEl (VTicket (MkAddress ceSelf) dat am) <:&> r
runInstrImpl _ AnnREAD_TICKET{} (te@(StkEl (VTicket addr dat am)) :& r) = do
- pure $
- StkEl
+ mkStkEl
(VPair (VAddress (EpAddress' addr DefEpName), (VPair (dat, VNat am))))
- :& te :& r
+ <:&> te :& r
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 $ StkEl result :& r
+ mkStkEl 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 $ StkEl result :& r
+ mkStkEl result <:&> r
runInstrImpl _ AnnOPEN_CHEST{}
(StkEl (VChestKey ck) :& StkEl (VChest c) :& StkEl (VNat nat) :& r) = do
let result = case mkTLTime nat of
@@ -917,28 +1052,28 @@
BogusOpening -> VOr (Right (VBool True))
BogusCipher -> VOr (Right (VBool False))
Left _ -> VOr (Right (VBool True))
- pure $ StkEl result :& r
+ mkStkEl 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
+ mkStkEl (VNat ceMinBlockTime) <:&> r
runInstrImpl _ (AnnEMIT _ (unAnnotation -> emTag) mNotes) ((StkEl emValue) :& r) = do
incrementCounter
emCounter <- isGlobalCounter <$> getInterpreterState
let emNotes = fromMaybe starNotes mNotes
- pure $ StkEl (VOp (OpEmit Emit{..})) :& r
+ mkStkEl (VOp (OpEmit Emit{..})) <:&> r
-- | Evaluates an arithmetic operation and either fails or proceeds.
runArithOp
- :: (ArithOp aop n m, EvalM' ext monad)
+ :: (ArithOp aop n m, StkElMeta meta monad, EvalM' ext monad)
=> proxy aop
- -> StkEl n
- -> StkEl m
- -> monad (StkEl (ArithRes aop n m))
+ -> StkEl meta n
+ -> StkEl meta m
+ -> monad (StkEl meta (ArithRes aop n m))
runArithOp op l r = case evalOp op (seValue l) (seValue r) of
Left err -> throwMichelson $ MichelsonArithError err
- Right res -> pure $ StkEl res
+ Right res -> mkStkEl res
-- | Unpacks given raw data into a typed value.
runUnpack
@@ -960,8 +1095,8 @@
instance Buildable ViewLookupError where
build = \case
ViewNotFound name -> "View '" +| name |+ "' not found"
- ViewArgMismatch err -> "View argument type mismatch: " +| err |+ ""
- ViewRetMismatch err -> "View return type mismatch: " +| err |+ ""
+ ViewArgMismatch err -> nameF "View argument type mismatch" err
+ ViewRetMismatch err -> nameF "View return type mismatch" err
-- | Interpret a contract's view for given t'ContractEnv' and initial
-- 'InterpreterState'. It is assumed t'ContractEnv' is suitable for the view
@@ -973,7 +1108,8 @@
-> ContractEnv
-> InterpreterState
-> InterpretReturn ret
-interpretView view' st argument = runEvalOp $ interpretView' runInstr id view' st argument
+interpretView view' st argument = runEvalOp $
+ interpretView' (runInstr @_ @NoStkElMeta) id view' st argument
-- | Attempt to find a view with a given name and given type in a given
-- contract.
@@ -997,16 +1133,16 @@
-- | 'EvalM' view interpretation helper.
interpretView'
- :: forall ret st m arg ext. EvalM' ext m
- => (forall inp out. Instr inp out -> Rec StkEl inp -> m (Rec StkEl out))
+ :: forall ret st m arg ext meta. (StkElMeta meta m, EvalM' ext m)
+ => (forall inp out. Instr inp out -> Rec (StkEl meta) inp -> m (Rec (StkEl meta) out))
-> (ContractEnv' m -> ContractEnv' m)
-> View arg st ret
-> Value st
-> Value arg
-> m (Value ret)
interpretView' runner env View{vCode} storage argument = do
- resSt <- local env $ runInstrImpl runner vCode $
- StkEl (VPair (argument, storage)) :& RNil
+ resSt <- local env $ runInstrImpl runner vCode =<<
+ mkStkEl @meta (VPair (argument, storage)) <:&> RNil
let StkEl res :& RNil = resSt
pure res
@@ -1034,7 +1170,9 @@
unwrapMbKeyHash :: Maybe (Value 'TKeyHash) -> Maybe KeyHash
unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash
-interpretExt :: EvalM' ext m => InstrRunner m -> SomeItStack -> m ()
+interpretExt
+ :: forall ext meta m. (StkElMeta meta m, EvalM' ext m)
+ => InstrRunner meta m -> SomeItStack meta -> m ()
interpretExt _ (SomeItStack (PRINT (PrintComment pc)) st) = do
let getEl (Left l) = l
getEl (Right str) = withStackElem str st (pretty . seValue)
@@ -1053,22 +1191,22 @@
-- | Access given stack reference (in CPS style).
withStackElem
- :: forall st a.
+ :: forall st meta a.
StackRef st
- -> Rec StkEl st
- -> (forall t. StkEl t -> a)
+ -> Rec (StkEl meta) st
+ -> (forall t. StkEl meta t -> a)
-> a
withStackElem (StackRef sn) vals cont =
loop (vals, sn)
where
loop
:: forall s (n :: Peano). (LongerThan s n)
- => (Rec StkEl s, PeanoNatural n) -> a
+ => (Rec (StkEl meta) s, PeanoNatural n) -> a
loop = \case
(e :& _, Zero) -> cont e
(_ :& es, Succ n) -> loop (es, n)
-assignBigMapIds' :: EvalM' ext m => Value t -> m (Value t)
+assignBigMapIds' :: forall ext m t. EvalM' ext m => Value t -> m (Value t)
assignBigMapIds' val = do
bigMapCounter0 <- view isBigMapCounterL <$> getInterpreterState
let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds True val) bigMapCounter0
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
@@ -15,6 +15,7 @@
-- * Morley Parsed instruction types
, ParsedInstr
, ParsedOp (..)
+ , ParsedSeq (..)
, ParsedUExtInstr
-- * For utilities
@@ -26,7 +27,7 @@
-- * Internals exported for tests
, expand
- , expandList
+ , expandSeq
, expandMacro
, expandPapair
, expandUnpapair
@@ -37,18 +38,20 @@
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
-import Fmt (Buildable(build), GenericBuildable(..), (+|), (|+))
+import Data.Default (def)
+import Fmt (Buildable(build), blockListF, (+|), (|+))
import Morley.Michelson.ErrorPos
import Morley.Michelson.Printer (RenderDoc(..))
import Morley.Michelson.Untyped
+import Morley.Michelson.Untyped.HoistInstr
import Morley.Util.Aeson
data PairStruct
= F FieldAnn
| P PairStruct PairStruct
deriving stock (Eq, Show, Data, Generic)
- deriving Buildable via GenericBuildable PairStruct
+ deriving anyclass Buildable
instance NFData PairStruct
@@ -56,7 +59,7 @@
= UF
| UP UnpairStruct UnpairStruct
deriving stock (Eq, Show, Data, Generic)
- deriving Buildable via GenericBuildable UnpairStruct
+ deriving anyclass Buildable
instance NFData UnpairStruct
@@ -64,7 +67,7 @@
= A
| D
deriving stock (Eq, Show, Data, Generic)
- deriving Buildable via GenericBuildable CadrStruct
+ deriving anyclass Buildable
instance NFData CadrStruct
@@ -91,17 +94,23 @@
-- Types produced by parser
-------------------------------------
-type ParsedUExtInstr = ExtInstrAbstract ParsedOp
+data ParsedSeq op
+ = PSSingleMacro SrcPos Macro
+ | PSSequence [op]
+ deriving stock (Eq, Show, Data, Generic, Functor, Foldable)
+ deriving anyclass NFData
-type ParsedInstr = InstrAbstract ParsedOp
+type ParsedUExtInstr = ExtInstrAbstract ParsedSeq ParsedOp
-type ParsedValue = Value' ParsedOp
+type ParsedInstr = InstrAbstract ParsedSeq ParsedOp
+type ParsedValue = Value' ParsedSeq ParsedOp
+
-- | Built-in Michelson Macros defined by the specification
data Macro
- = CMP ParsedInstr VarAnn
- | IFX ParsedInstr [ParsedOp] [ParsedOp]
- | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]
+ = CMP ParsedInstr
+ | IFX ParsedInstr (ParsedSeq ParsedOp) (ParsedSeq ParsedOp)
+ | IFCMP ParsedInstr (ParsedSeq ParsedOp) (ParsedSeq ParsedOp)
| FAIL
| PAPAIR PairStruct TypeAnn VarAnn
| UNPAPAIR UnpairStruct
@@ -109,8 +118,8 @@
| CARN VarAnn Word
| CDRN VarAnn Word
| SET_CADR [CadrStruct] VarAnn FieldAnn
- | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]
- | DIIP Word [ParsedOp]
+ | MAP_CADR [CadrStruct] VarAnn FieldAnn (ParsedSeq ParsedOp)
+ | DIIP Word (ParsedSeq ParsedOp)
| DUUP Word VarAnn
| ASSERT
| ASSERTX ParsedInstr
@@ -119,15 +128,20 @@
| ASSERT_SOME
| ASSERT_LEFT
| ASSERT_RIGHT
- | IF_SOME [ParsedOp] [ParsedOp]
- | IF_RIGHT [ParsedOp] [ParsedOp]
+ | IF_SOME (ParsedSeq ParsedOp) (ParsedSeq ParsedOp)
+ | IF_RIGHT (ParsedSeq ParsedOp) (ParsedSeq ParsedOp)
deriving stock (Eq, Show, Data, Generic)
+instance Buildable op => Buildable (ParsedSeq op) where
+ build = \case
+ PSSingleMacro _ mac -> build mac
+ PSSequence xs -> blockListF xs
+
instance Buildable Macro where
build = \case
- CMP parsedInstr carAnn -> ""
+ CMP parsedInstr -> ""
IFX parsedInstr parsedOps1 parsedOps2 -> ""
- IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> ""
+ IFCMP parsedInstr parsedOps1 parsedOps2 -> ""
FAIL -> "FAIL"
PAPAIR pairStruct typeAnn varAnn -> ""
UNPAPAIR pairStruct -> ""
@@ -150,51 +164,50 @@
instance NFData Macro
-expandList :: [ParsedOp] -> [ExpandedOp]
-expandList = fmap expand
-{-# DEPRECATED expandList "Use 'map expand' instead" #-}
-
-- | Expand all macros in parsed contract.
expandContract :: Contract' ParsedOp -> Contract
expandContract = fmap expand
-- | Expand all macros in parsed value.
expandValue :: ParsedValue -> Value
-expandValue = fmap expand
+expandValue = hoistInstr expandSeq . fmap expand
+expandSeq :: ParsedSeq ExpandedOp -> [ExpandedOp]
+expandSeq = \case
+ PSSingleMacro pos macro -> expandMacro (ErrorSrcPos pos) macro
+ PSSequence xs -> xs
+
expand :: ParsedOp -> ExpandedOp
expand = let ics pos = ErrorSrcPos pos in \case
(Mac m pos) -> WithSrcEx (ics pos) $ either PrimEx SeqEx $ expandMacro' (ics pos) m
- (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand <$> i
+ (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ hoistInstr expandSeq $ expand <$> i
(Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand <$> s
expandMacro' :: ErrorSrcPos -> Macro -> Either ExpandedInstr [ExpandedOp]
expandMacro' p@ErrorSrcPos{unErrorSrcPos=macroPos} = \case
-- special cases
- -- We handle this case specially, because it's essentially just PAIR.
- -- It's needed because we have a hack in parser: we parse PAIR as PAPAIR.
- -- We need to do something better eventually.
- PAPAIR (P (F a) (F b)) t v -> Left $ PAIR t v a b
-- DIIP is now always represented as a single instruction.
- DIIP n ops -> Left $ DIPN n (expand <$> ops)
+ DIIP n ops -> Left $ DIPN n $ expandSeq $ expand <$> ops
-- Similarly to above, DUUP is now always represented as a single instruction.
DUUP n v -> Left $ DUPN v n
-- regular cases
- CMP i v -> Right $ [PrimEx (COMPARE v), xo i]
+ CMP i -> Right $ [PrimEx (COMPARE def), xo i]
IFX i bt bf -> Right $ [xo i, PrimEx $ IF (xp bt) (xp bf)]
- IFCMP i v bt bf -> Right $ PrimEx <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)]
+ IFCMP i bt bf -> Right $ PrimEx <$> [COMPARE def, ex i, IF (xp bt) (xp bf)]
IF_SOME bt bf -> Right $ [PrimEx (IF_NONE (xp bf) (xp bt))]
IF_RIGHT bt bf -> Right $ [PrimEx (IF_LEFT (xp bf) (xp bt))]
FAIL -> Right $ PrimEx <$> [UNIT noAnn noAnn, FAILWITH]
ASSERT -> Right $ oprimEx $ IF [] fail'
- ASSERTX i -> Right $ [expand $ mac $ IFX i [] [mac FAIL]]
- ASSERT_CMP i -> Right $ [expand $ mac $ IFCMP i noAnn [] [mac FAIL]]
+ ASSERTX i -> Right $ [expand $ mac $ IFX i (PSSequence []) (PSSequence [mac FAIL])]
+ ASSERT_CMP i -> Right $
+ -- reference has weirdly inconsistent nesting between this and IFCMP
+ [expand (Mac (CMP i) macroPos), PrimEx $ IF [] fail']
ASSERT_NONE -> Right $ oprimEx $ IF_NONE [] fail'
ASSERT_SOME -> Right $ oprimEx $ IF_NONE fail' []
ASSERT_LEFT -> Right $ oprimEx $ IF_LEFT [] fail'
ASSERT_RIGHT -> Right $ oprimEx $ IF_LEFT fail' []
- PAPAIR ps t v -> Right $ expandPapair p ps t v
+ PAPAIR ps t v -> expandPapair p ps t v
UNPAPAIR ps -> Right $ expandUnpapair p ps
CADR c v f -> Right $ expandCadr p c v f
CARN v idx -> Right $ [PrimEx (GETN v (2 * idx + 1))]
@@ -203,11 +216,12 @@
MAP_CADR c v f ops -> Right $ expandMapCadr p c v f ops
where
- fail' = expandMacro p FAIL
+ fail' = one . expand $ mac FAIL
mac = flip Mac macroPos
oprimEx = one . PrimEx
- xo = PrimEx . fmap expand
- xp = fmap expand
+ xo = PrimEx . ex
+ ex = hoistInstr expandSeq . fmap expand
+ xp = expandSeq . fmap expand
expandMacro :: ErrorSrcPos -> Macro -> [ExpandedOp]
expandMacro = either (pure . PrimEx) id ... expandMacro'
@@ -216,27 +230,49 @@
--
-- The correctness of type-annotation expansion is currently untested, as these
-- expansions are not explicitly documented in the Michelson Specification.
-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]
+expandPapair
+ :: ErrorSrcPos
+ -> PairStruct
+ -> TypeAnn
+ -> VarAnn
+ -> Either ExpandedInstr [ExpandedOp]
+expandPapair ics@(ErrorSrcPos pos) ps t v = case ps of
+ -- 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.
+ P (F a) (F b) -> Left $ PAIR t v a b
-- > PA(\right)R / S => DIP ((\right)R) ; PAIR / S
- P (F a) r -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)
- , PAIR t v a noAnn]
+ -- docs lie a bit, reference actually does something weird, which we try to match
+ -- to the best of our ability
+ P (F a) r -> Right $
+ concatMap papairDips (expandMacro ics (PAPAIR r noAnn noAnn))
+ <> [PrimEx $ PAIR t v a noAnn]
-- > P(\left)IR / S => (\left)R ; PAIR / S
- P l (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) ++
- [PrimEx $ PAIR t v noAnn b]
+ P l (F b) -> Right [ expand $ Mac (PAPAIR l noAnn noAnn) pos, PrimEx $ PAIR t v noAnn b ]
-- > P(\left)(\right)R => (\left)R ; DIP ((\right)R) ; PAIR / S
- P l r -> expandMacro ics (PAPAIR l noAnn noAnn) ++
- [ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)
- , PrimEx $ PAIR t v noAnn noAnn]
+ -- docs lie a bit, reference actually does something weird, which we try to match
+ -- to the best of our ability
+ P l r -> Right $
+ (expand $ Mac (PAPAIR l noAnn noAnn) pos)
+ : concatMap papairDips (expandMacro ics (PAPAIR r noAnn noAnn))
+ <> [PrimEx $ PAIR t v noAnn noAnn]
-- It's impossible from the structure of PairStruct and considered cases above,
-- but if it accidentally happened let's just do nothing.
- F _ -> []
+ F _ -> Right []
+-- | Mimic the weirdness that is the reference implementation
+papairDips :: ExpandedOp -> [ExpandedOp]
+papairDips = \case
+ PrimEx (DIP xs) -> [PrimEx $ DIPN 2 xs]
+ PrimEx (DIPN n xs) -> [PrimEx $ DIPN (succ n) xs]
+ SeqEx xs -> concatMap papairDips xs
+ PrimEx x -> [PrimEx $ DIP [PrimEx x]]
+ WithSrcEx s x -> WithSrcEx s <$> papairDips x
+
-- | The macro expansion rules below were taken from: https://tezos.gitlab.io/active/michelson.html#syntactic-conveniences
expandUnpapair :: ErrorSrcPos -> UnpairStruct -> [ExpandedOp]
expandUnpapair ics = \case
@@ -244,10 +280,11 @@
[ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) ]
-- > UNPA(\right)R / S => UNPAIR ; DIP (UN(\right)R) / S
+ -- docs lie a bit, reference actually does something weird, which we try to match
+ -- to the best of our ability
UP UF r ->
- PrimEx <$> [ UNPAIR noAnn noAnn noAnn noAnn
- , DIP (expandMacro ics (UNPAPAIR r))
- ]
+ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
+ : concatMap papairDips (expandMacro ics (UNPAPAIR r))
-- > UNP(\left)IR / S => UNPAIR ; UN(\left)R / S
UP l UF ->
@@ -255,11 +292,12 @@
: expandMacro ics (UNPAPAIR l)
-- > UNP(\left)(\right)R => UNPAIR ; DIP (UN(\right)R) ; UN(\left)R / S
+ -- docs lie a bit, reference actually does something weird, which we try to match
+ -- to the best of our ability
UP l r ->
- [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
- , PrimEx $ DIP $ expandMacro ics $ UNPAPAIR r
- ] ++
- expandMacro ics (UNPAPAIR l)
+ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
+ : concatMap papairDips (expandMacro ics $ UNPAPAIR r)
+ <> expandMacro ics (UNPAPAIR l)
-- It's impossible from the structure of UnpairStruct and considered cases above,
-- but if it accidentally happened let's just do nothing.
@@ -273,34 +311,40 @@
A:css -> PrimEx (CAR noAnn noAnn) : expandMacro ics (CADR css v f)
D:css -> PrimEx (CDR noAnn noAnn) : expandMacro ics (CADR css v f)
-carNoAnn :: InstrAbstract op
+carNoAnn :: InstrAbstract f op
carNoAnn = CAR [annQ|%%|] noAnn
-cdrNoAnn :: InstrAbstract op
+cdrNoAnn :: InstrAbstract f op
cdrNoAnn = CDR [annQ|%%|] noAnn
-pairNoAnn :: VarAnn -> InstrAbstract op
+pairNoAnn :: VarAnn -> InstrAbstract f op
pairNoAnn v = PAIR noAnn v [annQ|@|] [annQ|@|]
expandSetCadr :: ErrorSrcPos -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]
-expandSetCadr ics cs v f = PrimEx <$> case cs of
+expandSetCadr (ErrorSrcPos ps) cs v f = PrimEx <$> case cs of
[] -> []
- [A] -> [DUP noAnn, CAR noAnn f, DROP,
- -- ↑ These operations just check that the left element of pair has %f
- cdrNoAnn, SWAP, PAIR noAnn v f [annQ|@|]]
- [D] -> [DUP noAnn, CDR noAnn f, DROP,
- -- ↑ These operations just check that the right element of pair has %f
- carNoAnn, PAIR noAnn v [annQ|@|] f]
- 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]
+ [A] -> [cdrNoAnn, SWAP, PAIR noAnn v f [annQ|@|]]
+ [D] -> [carNoAnn, PAIR noAnn v [annQ|@|] f]
+ A:css -> [DUP noAnn, DIP [PrimEx carNoAnn, expand $ Mac (SET_CADR css noAnn f) ps], cdrNoAnn, SWAP, pairNoAnn v]
+ D:css -> [DUP noAnn, DIP [PrimEx cdrNoAnn, expand $ Mac (SET_CADR css noAnn f) ps], carNoAnn, pairNoAnn v]
-expandMapCadr :: ErrorSrcPos -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]
-expandMapCadr ics cs v f ops = case cs of
+expandMapCadr :: ErrorSrcPos -> [CadrStruct] -> VarAnn -> FieldAnn -> ParsedSeq ParsedOp -> [ExpandedOp]
+expandMapCadr (ErrorSrcPos pos) cs v f ops = case cs of
[] -> []
- [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]
+ -- > MAP_CAR code => DUP ; CDR ; DIP { CAR ; code } ; SWAP ; PAIR
+ [A] -> PrimEx <$>
+ [ DUP noAnn
+ , cdrNoAnn
+ , DIP [PrimEx (CAR noAnn f), SeqEx $ expandSeq $ expand <$> ops]
+ , SWAP
+ , PAIR noAnn v f [annQ|@|]]
+ -- > MAP_CDR code => DUP ; CDR ; code ; SWAP ; CAR ; PAIR
+ [D] -> (PrimEx <$> [DUP noAnn, CDR noAnn f]) <>
+ (SeqEx (expandSeq $ expand <$> ops) : (PrimEx <$> [SWAP, carNoAnn, PAIR noAnn v [annQ|@|] f]))
+ -- > MAP_CA(\rest=[AD]+)R code / S =>
+ -- { DUP ; DIP { CAR ; MAP_C(\rest)R code } ; CDR ; SWAP ; PAIR } / S
+ A:css -> PrimEx <$> [DUP noAnn, DIP [PrimEx carNoAnn, expand $ Mac (MAP_CADR css noAnn f ops) pos], cdrNoAnn, SWAP, pairNoAnn v]
+ D:css -> PrimEx <$> [DUP noAnn, DIP [PrimEx cdrNoAnn, expand $ Mac (MAP_CADR css noAnn f ops) pos], carNoAnn, pairNoAnn v]
mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct
mapPairLeaves fs p = evalState (pairLeavesST p) fs
@@ -325,4 +369,5 @@
$(mconcat
[ deriveJSON morleyAesonOptions ''Macro
, deriveJSON morleyAesonOptions ''ParsedOp
+ , deriveJSON morleyAesonOptions ''ParsedSeq
])
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
@@ -1,16 +1,9 @@
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
--- NOTE this pragmas.
--- We disable some warnings for the sake of speed up.
--- Write code with care.
-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-
-- | Optimizer for typed instructions.
--
-- It's quite experimental and incomplete.
-
module Morley.Michelson.Optimizer
( optimize
, optimizeWithConf
@@ -18,8 +11,6 @@
, defaultOptimizerConf
, defaultRules
, defaultRulesAndPushPack
- , orRule
- , orSimpleRule
, Rule (..)
, OptimizerConf (..)
, ocGotoValuesL
@@ -36,95 +27,16 @@
import Prelude hiding (EQ, GT, LT)
import Control.Lens (makeLensesFor)
-import Data.Constraint (Dict(..), (\\))
import Data.Default (Default(def))
-import Data.Map qualified as Map
-import Data.Singletons (sing)
-import Data.Type.Equality ((:~:)(Refl))
import Fmt (Buildable(..), (+|), (|+))
-import Morley.Michelson.Interpret.Pack (packValue')
-import Morley.Michelson.Optimizer.Internal.Proofs
-import Morley.Michelson.Typed.Aliases (Value)
-import Morley.Michelson.Typed.Arith
+import Morley.Michelson.Optimizer.Internal.Rules
+import Morley.Michelson.Optimizer.Internal.Ruleset
+import Morley.Michelson.Optimizer.Utils
import Morley.Michelson.Typed.ClassifiedInstr
import Morley.Michelson.Typed.Instr hiding ((:#))
-import Morley.Michelson.Typed.Scope (ConstantScope, PackedValScope, checkScope)
-import Morley.Michelson.Typed.Sing
-import Morley.Michelson.Typed.T
import Morley.Michelson.Typed.Util (DfsSettings(..), dfsFoldInstr, dfsTraverseInstr)
-import Morley.Michelson.Typed.Value
-import Morley.Util.Peano
-import Morley.Util.PeanoNatural
-pattern (:#) :: Instr inp b -> Instr b out -> Instr inp out
-pattern l :# r <- (maybeSeq -> Seq l r)
- where l :# Nop = l
- Nop :# r = r
- l :# r = Seq l r
-infixr 8 :#
-
-maybeSeq :: Instr inp out -> Instr inp out
-maybeSeq = \case
- x@Seq{} -> x
- x -> Seq x Nop
-
-----------------------------------------------------------------------------
--- High level
-----------------------------------------------------------------------------
-
--- | Optimization stages. Stages are run in first to last order, each stage has
--- an 'Int' argument, which allows splitting each stage into sub-stages, which
--- will run lowest index to highest. All default rules use sub-stage @0@.
-data OptimizationStage
- = OptimizationStagePrepare Int
- | OptimizationStageMain Int
- -- ^ Main optimisation stage, except rules that would interfere with other
- -- rules.
- | OptimizationStageMainExtended Int
- -- ^ All main stage rules.
- | OptimizationStageRollAdjacent Int
- -- ^ Main stage rules unroll @DROP n@, @PAIR n@, etc into their primitive
- -- counterparts to simplify some optimisations. This stages coalesces them
- -- back.
- deriving stock (Eq, Ord)
-
-instance Buildable OptimizationStage where
- build = \case
- OptimizationStagePrepare n -> "prepare " +| n |+ ""
- OptimizationStageMain n -> "main " +| n |+ ""
- OptimizationStageMainExtended n -> "main extended " +| n |+ ""
- OptimizationStageRollAdjacent n -> "roll adjacent " +| n |+ ""
-
--- | A set of optimization stages. Rules at the same sub-stage are applied in
--- arbitrary order. See 'OptimizationStage' for explanation of sub-stages.
---
--- 'Default' ruleset is empty.
-newtype Ruleset = Ruleset { unRuleset :: Map OptimizationStage (NonEmpty Rule) }
- deriving newtype Default
-
-instance Semigroup Ruleset where
- Ruleset l <> Ruleset r = Ruleset $ Map.unionWith (<>) l r
-
-instance Monoid Ruleset where
- mempty = def
-
--- | Get rules for a given priority as a list.
-rulesAtPrio :: OptimizationStage -> Ruleset -> [Rule]
-rulesAtPrio prio = maybe [] toList . Map.lookup prio . unRuleset
-
--- | Insert a single rule at a given priority without touching other rules.
-insertRuleAtPrio :: OptimizationStage -> Rule -> Ruleset -> Ruleset
-insertRuleAtPrio = flip $ alterRulesAtPrio . (:)
-
--- | Remove the stage with the given priority.
-clearRulesAtPrio :: OptimizationStage -> Ruleset -> Ruleset
-clearRulesAtPrio = alterRulesAtPrio (const [])
-
--- | Alter all stage rules for a given priority.
-alterRulesAtPrio :: ([Rule] -> [Rule]) -> OptimizationStage -> Ruleset -> Ruleset
-alterRulesAtPrio f prio = Ruleset . Map.alter (nonEmpty . f . maybe [] toList) prio . unRuleset
-
data OptimizerConf = OptimizerConf
{ ocGotoValues :: Bool
, ocRuleset :: Ruleset
@@ -190,545 +102,5 @@
(getAny -> changed, res) =
dfsTraverseInstr def{ dsGoToValues = ocGotoValues, dsInstrStep = applyOnce stageRule } i
instrRHS = snd $ applyOnce (fixpoint flattenSeqLHS) instr
-
-----------------------------------------------------------------------------
--- Rewrite rules
-----------------------------------------------------------------------------
-
-{-
-Note [Writing optimizer rules]
-------------------------------
-
-We locally redefine (:#) to simplify handling instruction sequence tails.
-Consider that a given instruction sequence can appear in the middle, and then @a
-:# b :# tail@ will match, or at the end of the sequence, and then @a :# b@ will
-match.
-
-Local definition of (:#) makes it so we can always assume there's a tail.
-However, we don't need it when matching on single instructions.
-
-Thus, the rule of thumb is this: if you're matching on a single instruction,
-everything is fine. If you're matching on a sequence, i.e. using (:#), then
-always match on tail.
--}
-
--- Type of a single rewrite rule, wrapped in `newtype`. It takes an instruction
--- and tries to optimize its head (first few instructions). If optimization
--- succeeds, it returns `Just` the optimized instruction, otherwise it returns `Nothing`.
-newtype Rule = Rule {unRule :: forall inp out. Instr inp out -> Maybe (Instr inp out)}
-
--- | Default optimization rules.
-defaultRules :: Ruleset
-defaultRules = foldr ($) def $ uncurry (alterRulesAtPrio . const) <$>
- -- NB: if adding more main stages, remember to check if
- -- 'defaultRulesAndPushPack' needs updating.
- [ (mainStageRules , OptimizationStageMain 0)
- , (dipDrop2swapDropStageRules , OptimizationStageMainExtended 0)
- , (glueAdjacentInstrsStageRules, OptimizationStageRollAdjacent 0)
- ]
- where
- dipDrop2swapDropStageRules = dipDrop2swapDrop : mainStageRules
- glueAdjacentInstrsStageRules =
- [ adjacentDrops
- , rollPairN
- , rollUnpairN
- , rollDips
- ]
-
--- | We do not enable 'pushPack' rule by default because it is potentially
--- dangerous. There are various code processing functions that may depend on
--- constants, e. g. string transformations.
-defaultRulesAndPushPack :: Ruleset
-defaultRulesAndPushPack = defaultRules
- & insertRuleAtPrio (OptimizationStageMainExtended 0) pushPack
-
-mainStageRules :: [Rule]
-mainStageRules =
- [ removeNesting
- , removeExtStackType
- , ifNopNop2Drop
- , nopIsNeutralForSeq
- , variousNops
- , dupSwap2dup
- , noDipNeeded
- , branchShortCut
- , compareWithZero
- , internalNop
- , simpleDups
- , adjacentDips
- , isSomeOnIf
- , redundantIf
- , emptyDip
- , digDug
- , specificPush
- , pairUnpair
- , pairMisc
- , unpairMisc
- , swapBeforeCommutative
- , justDrops
- , justDoubleDrops
- , dig1AndDug1AreSwap
- , notIf
- , dropMeta
- -- strictly speaking, these rules below are de-optimisations, but they
- -- expose opportunities for other optimisations, and they are undone in the
- -- last stage.
- , unrollPairN
- , unrollUnpairN
- , unrollDropN
- , unrollDips
- ]
-
-flattenSeqLHS :: Rule -> Rule
-flattenSeqLHS toplevel = Rule $ \case
- it@(Seq (Seq _ _) _) -> Just $ linearizeAndReapply toplevel it
- _ -> Nothing
-
-dropMeta :: Rule
-dropMeta = Rule $ \case
- Meta _ i -> Just i
- WithLoc _ i -> Just i
- _ -> Nothing
-
-removeNesting :: Rule
-removeNesting = Rule $ \case
- Nested i -> Just i
- _ -> Nothing
-
--- | STACKTYPE is currently a Nop and may safely be removed.
-removeExtStackType :: Rule
-removeExtStackType = Rule $ \case
- Ext (STACKTYPE{}) -> Just Nop
- _ -> Nothing
-
-dipDrop2swapDrop :: Rule
-dipDrop2swapDrop = Rule $ \case
- DIP DROP -> Just $ SWAP :# DROP
- _ -> Nothing
-
-ifNopNop2Drop :: Rule
-ifNopNop2Drop = Rule $ \case
- IF Nop Nop -> Just DROP
- _ -> Nothing
-
-nopIsNeutralForSeq :: Rule
-nopIsNeutralForSeq = Rule $ \case
- -- NB: we're not using (:#) here because it'll always match when rhs is Nop
- Seq Nop i -> Just i
- Seq i Nop -> Just i
- _ -> Nothing
-
-variousNops :: Rule
-variousNops = Rule $ \case
- DUP :# DROP :# c -> Just c
- DUPN _ :# DROP :# c -> Just c
- SWAP :# SWAP :# c -> Just c
- PUSH _ :# DROP :# c -> Just c
- NONE :# DROP :# c -> Just c
- UNIT :# DROP :# c -> Just c
- NIL :# DROP :# c -> Just c
- EMPTY_SET :# DROP :# c -> Just c
- EMPTY_MAP :# DROP :# c -> Just c
- EMPTY_BIG_MAP :# DROP :# c -> Just c
- LAMBDA _ :# DROP :# c -> Just c
- SELF _ :# DROP :# c -> Just c
- NOW :# DROP :# c -> Just c
- AMOUNT :# DROP :# c -> Just c
- BALANCE :# DROP :# c -> Just c
- TOTAL_VOTING_POWER :# DROP :# c -> Just c
- SOURCE :# DROP :# c -> Just c
- SENDER :# DROP :# c -> Just c
- CHAIN_ID :# DROP :# c -> Just c
- LEVEL :# DROP :# c -> Just c
- SELF_ADDRESS :# DROP :# c -> Just c
- READ_TICKET :# DROP :# c -> Just c
- _ -> Nothing
-
-dupSwap2dup :: Rule
-dupSwap2dup = Rule $ \case
- DUP :# SWAP :# c -> Just $ DUP :# c
- _ -> Nothing
-
-noDipNeeded :: Rule
-noDipNeeded = Rule $ \case
- -- If we put a constant value on stack and then do something under it,
- -- we can do this "something" on original stack and then put that constant.
- PUSH x :# DIP f :# c -> Just $ f :# PUSH x :# c
- UNIT :# DIP f :# c -> Just $ f :# UNIT :# c
- NOW :# DIP f :# c -> Just $ f :# NOW :# c
- SENDER :# DIP f :# c -> Just $ f :# SENDER :# c
- EMPTY_MAP :# DIP f :# c -> Just $ f :# EMPTY_MAP :# c
- EMPTY_SET :# DIP f :# c -> Just $ f :# EMPTY_SET :# c
-
- -- If we do something ignoring top of the stack and then immediately
- -- drop top of the stack, we can drop that item in advance and
- -- not use 'DIP' at all.
- DIP f :# DROP :# c -> Just $ DROP :# f :# c
-
- _ -> Nothing
-
-unrollDips :: Rule
-unrollDips = Rule go
- where
- go :: Instr inp out -> Maybe (Instr inp out)
- go = \case
- DIPN Zero c -> Just $ c
- DIPN One c -> Just $ DIP c
- DIPN (Succ n) c -> DIP <$> go (DIPN n c)
- _ -> Nothing
-
-rollDips :: Rule
-rollDips = Rule $ \case
- DIP (DIP c) -> Just $ DIPN Two c
- DIP (DIPN n c) -> Just $ DIPN (Succ n) c
- _ -> Nothing
-
-branchShortCut :: Rule
-branchShortCut = Rule $ \case
- LEFT :# IF_LEFT f _ :# c -> Just $ f :# c
- RIGHT :# IF_LEFT _ f :# c -> Just $ f :# c
- CONS :# IF_CONS f _ :# c -> Just $ f :# c
- NIL :# IF_CONS _ f :# c -> Just $ f :# c
- NONE :# IF_NONE f _ :# c -> Just $ f :# c
- SOME :# IF_NONE _ f :# c -> Just $ f :# c
-
- PUSH vOr@(VOr eitherVal) :# IF_LEFT f g :# c -> case vOr of
- (_ :: Value ('TOr l r)) -> case eitherVal of
- Left val -> case checkScope @(ConstantScope l) of
- Right Dict -> Just $ PUSH val :# f :# c
- _ -> Nothing
- Right val -> case checkScope @(ConstantScope r) of
- Right Dict -> Just $ PUSH val :# g :# c
- _ -> Nothing
- PUSH (VList (x : xs)) :# IF_CONS f _ :# c -> Just $ PUSH (VList xs) :# PUSH x :# f :# c
- PUSH (VList _) :# IF_CONS _ f :# c -> Just $ f :# c
- PUSH (VOption Nothing) :# IF_NONE f _ :# c -> Just $ f :# c
- PUSH (VOption (Just val)) :# IF_NONE _ f :# c -> Just $ PUSH val :# f :# c
- PUSH (VBool True) :# IF f _ :# c -> Just $ f :# c
- PUSH (VBool False) :# IF _ f :# c -> Just $ f :# c
- _ -> Nothing
-
-compareWithZero :: Rule
-compareWithZero = Rule $ \case
- PUSH (VInt 0) :# COMPARE :# EQ :# c -> Just $ EQ :# c
- PUSH (VNat 0) :# COMPARE :# EQ :# c -> Just $ INT :# EQ :# c
- _ -> Nothing
-
--- If an instruction takes another instruction as an argument and that
--- internal instruction is 'Nop', sometimes the whole instruction is
--- 'Nop'.
--- For now we do it only for 'DIP', but ideally we should do it for
--- 'MAP' as well (which is harder).
-internalNop :: Rule
-internalNop = Rule $ \case
- DIP Nop -> Just Nop
-
- _ -> Nothing
-
-simpleDups :: Rule
-simpleDups = Rule $ \case
- -- DUP 1 is just DUP
- DUPN One -> Just DUP
-
- _ -> Nothing
-
-adjacentDips :: Rule
-adjacentDips = Rule $ \case
- DIP f :# DIP g :# c -> Just $ DIP (f :# g) :# c
-
- _ -> Nothing
-
-redundantIf :: Rule
-redundantIf = Rule \case
- IF x y
- | x == y
- -> Just $ DROP :# x
- _ -> Nothing
-
-emptyDip :: Rule
-emptyDip = Rule \case
- DIP Nop -> Just Nop
- DIPN _ Nop -> Just Nop
- _ -> Nothing
-
-digDug :: Rule
-digDug = Rule \case
- DIG x :# DUG y :# c | Just Refl <- eqPeanoNat x y -> Just c
- _ -> Nothing
-
--- | Sequences of @DROP@s can be turned into single @DROP n@.
--- When @n@ is greater than 2 it saves size and gas.
--- When @n@ is 2 it saves gas only.
-adjacentDrops :: Rule
-adjacentDrops = Rule $ \case
- DROP :# DROP :# c -> Just $ DROPN Two :# c
-
- (DROPN n :: Instr inp out) :# (DROP :: Instr inp' out') :# c
- -> Just $ DROPN (Succ n) :# c \\ dropNDropNProof @inp @out @out' n One
- \\ commutativity (singPeanoNat n) (singPeanoNat One)
-
- (DROP :: Instr inp out) :# (DROPN n :: Instr inp' out') :# c
- -> Just $ DROPN (Succ n) :# c \\ dropNDropNProof @inp @out @out' One n
-
- (DROPN n :: Instr inp out) :# (DROPN m :: Instr inp' out') :# c
- -> Just $ DROPN (addPeanoNat n m) :# c \\ dropNDropNProof @inp @out @out' n m
-
- _ -> Nothing
-
-specificPush :: Rule
-specificPush = Rule $ \case
- push@PUSH{} :# c -> (:# c) <$> optimizePush push
-
- _ -> Nothing
- where
- optimizePush :: Instr inp out -> Maybe (Instr inp out)
- optimizePush = \case
- PUSH v | _ :: Value v <- v -> case v of
- VUnit -> Just UNIT
- VMap m
- | null m -> case sing @v of STMap{} -> Just EMPTY_MAP
- VSet m
- | null m -> case sing @v of STSet{} -> Just EMPTY_SET
- _ -> Nothing
-
- _ -> Nothing
-
-
-isSomeOnIf :: Rule
-isSomeOnIf = Rule $ \case
- IF (PUSH (VOption Just{})) (PUSH (VOption Nothing))
- :# IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True))
- :# c
- -> Just c
- _ -> Nothing
-
-pairUnpair :: Rule
-pairUnpair = Rule $ \case
- PAIR :# UNPAIR :# c -> Just c
-
- UNPAIR :# PAIR :# c -> Just c
-
- _ -> Nothing
-
-pairMisc :: Rule
-pairMisc = Rule $ \case
- PAIR :# CDR :# c -> Just $ DROP :# c
-
- PAIR :# CAR :# c -> Just $ (DIP DROP) :# c
-
- _ -> Nothing
-
-unpairMisc :: Rule
-unpairMisc = Rule $ \case
- DUP :# CAR :# DIP CDR :# c -> Just $ UNPAIR :# c
-
- DUP :# CDR :# DIP CAR :# c -> Just $ UNPAIR :# SWAP :# c
-
- UNPAIR :# DROP :# c -> Just $ CDR :# c
- _ -> Nothing
-
-unrollDropN :: Rule
-unrollDropN = Rule go
- where
- go :: forall inp out. Instr inp out -> Maybe (Instr inp out)
- go = \case
- DROPN Zero -> Just Nop
- DROPN (Succ n) -> do
- dropn <- go $ DROPN n
- Just $ DROP :# dropn
- \\ unconsListProof @inp n
- _ -> Nothing
-
-unrollPairN :: Rule
-unrollPairN = Rule go
- where
- go :: forall inp out. Instr inp out -> Maybe (Instr inp out)
- go = \case
- PAIRN Two -> Just PAIR \\ pairN2isPairProof @inp
- PAIRN (Succ n@(Succ Succ{}) ) -> do
- pairn <- go $ PAIRN n
- Just $ DIP pairn :# PAIR
- \\ unconsListProof @inp n
- _ -> Nothing
-
-unrollUnpairN :: Rule
-unrollUnpairN = Rule go
- where
- go :: forall inp out. Instr inp out -> Maybe (Instr inp out)
- go = \case
- UNPAIRN Two -> Just UNPAIR \\ unpairN2isUnpairProof @inp @out
- UNPAIRN (Succ n@(Succ Succ{})) -> do
- unpairn <- go $ UNPAIRN n
- Just $ UNPAIR :# DIP unpairn
- \\ unpairNisUnpairDipUnpairNProof @inp @out n
- _ -> Nothing
-
-rollPairN :: Rule
-rollPairN = Rule $ \case
- DIP PAIR :# PAIR :# c -> Just $ PAIRN (Succ Two) :# c
-
- (DIP (PAIRN n@(Succ Succ{})) :: Instr inp out) :# PAIR :# c -> Just $ PAIRN (Succ n) :# c
- \\ dipPairNPairIsPairNProof @inp n
-
- _ -> Nothing
-
-rollUnpairN :: Rule
-rollUnpairN = Rule $ \case
- UNPAIR :# DIP UNPAIR :# c -> Just $ UNPAIRN (Succ Two) :# c
- UNPAIR :# DIP (UNPAIRN n@(Succ Succ{})) :# c -> Just $ UNPAIRN (Succ n) :# c
- _ -> Nothing
-
-commuteArith ::
- forall n m s out. Instr (n ': m ': s) out -> Maybe (Instr (m ': n ': s) out)
-commuteArith = \case
- ADD -> do Dict <- commutativityProof @Add @n @m; Just ADD
- MUL -> do Dict <- commutativityProof @Mul @n @m; Just MUL
- OR -> do Dict <- commutativityProof @Or @n @m; Just OR
- AND -> do Dict <- commutativityProof @And @n @m; Just AND
- XOR -> do Dict <- commutativityProof @Xor @n @m; Just XOR
- _ -> Nothing
-
-swapBeforeCommutative :: Rule
-swapBeforeCommutative = Rule $ \case
- SWAP :# i :# c -> (:# c) <$> commuteArith i
-
- _ -> Nothing
-
-pushPack :: Rule
-pushPack = Rule $ \case
- PUSH x :# PACK :# c -> Just $ pushPacked x :# c
-
- _ -> Nothing
- where
- pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)
- pushPacked = PUSH . VBytes . packValue'
-
-justDrops :: Rule
-justDrops = Rule $ \case
- CAR :# DROP :# c -> Just $ DROP :# c
- CDR :# DROP :# c -> Just $ DROP :# c
- SOME :# DROP :# c -> Just $ DROP :# c
- LEFT :# DROP :# c -> Just $ DROP :# c
- RIGHT :# DROP :# c -> Just $ DROP :# c
- SIZE :# DROP :# c -> Just $ DROP :# c
- GETN _ :# DROP :# c -> Just $ DROP :# c
- CAST :# DROP :# c -> Just $ DROP :# c
- RENAME :# DROP :# c -> Just $ DROP :# c
- PACK :# DROP :# c -> Just $ DROP :# c
- UNPACK :# DROP :# c -> Just $ DROP :# c
- CONCAT' :# DROP :# c -> Just $ DROP :# c
- ISNAT :# DROP :# c -> Just $ DROP :# c
- ABS :# DROP :# c -> Just $ DROP :# c
- NEG :# DROP :# c -> Just $ DROP :# c
- NOT :# DROP :# c -> Just $ DROP :# c
- EQ :# DROP :# c -> Just $ DROP :# c
- NEQ :# DROP :# c -> Just $ DROP :# c
- LT :# DROP :# c -> Just $ DROP :# c
- GT :# DROP :# c -> Just $ DROP :# c
- LE :# DROP :# c -> Just $ DROP :# c
- GE :# DROP :# c -> Just $ DROP :# c
- INT :# 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
- SHA256 :# DROP :# c -> Just $ DROP :# c
- SHA512 :# DROP :# c -> Just $ DROP :# c
- BLAKE2B :# DROP :# c -> Just $ DROP :# c
- SHA3 :# DROP :# c -> Just $ DROP :# c
- KECCAK :# DROP :# c -> Just $ DROP :# c
- HASH_KEY :# DROP :# c -> Just $ DROP :# c
- PAIRING_CHECK :# DROP :# c -> Just $ DROP :# c
- ADDRESS :# DROP :# c -> Just $ DROP :# c
- JOIN_TICKETS :# DROP :# c -> Just $ DROP :# c
- _ -> Nothing
-
-justDoubleDrops :: Rule
-justDoubleDrops = Rule $ \case
- PAIR :# DROP :# c -> Just $ DROP :# DROP :# c
- MEM :# DROP :# c -> Just $ DROP :# DROP :# c
- GET :# DROP :# c -> Just $ DROP :# DROP :# c
- APPLY :# DROP :# c -> Just $ DROP :# DROP :# c
- CONCAT :# DROP :# c -> Just $ DROP :# DROP :# c
- ADD :# DROP :# c -> Just $ DROP :# DROP :# c
- SUB :# DROP :# c -> Just $ DROP :# DROP :# c
- SUB_MUTEZ :# DROP :# c -> Just $ DROP :# DROP :# c
- MUL :# DROP :# c -> Just $ DROP :# DROP :# c
- EDIV :# DROP :# c -> Just $ DROP :# DROP :# c
- OR :# DROP :# c -> Just $ DROP :# DROP :# c
- AND :# DROP :# c -> Just $ DROP :# DROP :# c
- XOR :# DROP :# c -> Just $ DROP :# DROP :# c
- COMPARE :# DROP :# c -> Just $ DROP :# DROP :# c
- TICKET :# DROP :# c -> Just $ DROP :# DROP :# c
- SPLIT_TICKET :# DROP :# c -> Just $ DROP :# DROP :# c
- SWAP :# DROP :# DROP :# c -> Just $ DROP :# DROP :# c
- _ -> Nothing
-
-dig1AndDug1AreSwap :: Rule
-dig1AndDug1AreSwap = Rule \case
- DUG One -> Just SWAP
- DIG One -> Just SWAP
- _ -> Nothing
-
-notIf :: Rule
-notIf = Rule \case
- (NOT :: Instr inp out) :# IF a b :# c | STBool <- sing @(Head inp) -> Just $ IF b a :# c
- _ -> Nothing
-
--- | Append LHS of v'Seq' to RHS and re-run pointwise ocRuleset at each point.
--- That might cause reinvocation of this function (see 'defaultRules'),
--- but effectively this ensures it will flatten any v'Seq'-tree right-to-left,
--- while evaling no more than once on each node.
---
--- The reason this function invokes ocRuleset is when you append an instr
--- to already-optimised RHS of v'Seq', you might get an optimisable tree.
---
--- The argument is a local, non-structurally-recursive ocRuleset.
-linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out
-linearizeAndReapply restart = snd . \case
- Seq (Seq a b) c ->
- applyOnce restart $ Seq a (linearizeAndReapply restart (Seq b c))
-
- other -> applyOnce restart other
-
-----------------------------------------------------------------------------
--- Generic functions working with rules
-----------------------------------------------------------------------------
-
--- | Combine two rule fixpoints.
-orRule :: (Rule -> Rule) -> (Rule -> Rule) -> (Rule -> Rule)
-orRule l r topl = Rule $ \instr ->
- (unRule (l topl) $ instr) <|> (unRule (r topl) $ instr)
-
--- | Combine a rule fixpoint and a simple rule.
-orSimpleRule :: (Rule -> Rule) -> Rule -> (Rule -> Rule)
-orSimpleRule l r topl = Rule $ \instr ->
- (unRule (l topl) $ instr) <|> (unRule r $ instr)
-
--- | Turn rule fixpoint into rule.
-fixpoint :: (Rule -> Rule) -> Rule
-fixpoint r = go
- where
- go :: Rule
- go = whileApplies (r go)
-
--- | Apply the rule once, if it fails, return the instruction unmodified.
---
--- Also returns a flag showing whether the rule succeeded or not.
-applyOnce :: Rule -> Instr inp out -> (Any Bool, Instr inp out)
-applyOnce r i = maybe (pure i) (Any True,) (unRule r $ i)
-
--- | Apply a rule to the same code, until it fails.
-whileApplies :: Rule -> Rule
-whileApplies r = Rule $ go <=< unRule r
- -- NB: if the rule doesn't apply even once, we want to return Nothing here,
- -- hence it's first applied above and only if successful goes into recursion.
- where
- go :: Instr inp out -> Maybe (Instr inp out)
- go i = maybe (Just i) go (unRule r i)
-
-----------------------------------------------------------------------------
--- TH
-----------------------------------------------------------------------------
makeLensesFor [("ocGotoValues", "ocGotoValuesL")] ''OptimizerConf
diff --git a/src/Morley/Michelson/Optimizer/Internal/Rules.hs b/src/Morley/Michelson/Optimizer/Internal/Rules.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Optimizer/Internal/Rules.hs
@@ -0,0 +1,526 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- NOTE this pragmas.
+-- We disable some warnings for the sake of speed up.
+-- Write code with care.
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+
+-- | Optimizer rewrite rules
+module Morley.Michelson.Optimizer.Internal.Rules
+ ( module Morley.Michelson.Optimizer.Internal.Rules
+ ) where
+
+import Prelude hiding (EQ, GT, LT)
+
+import Data.Constraint (Dict(..), (\\))
+import Data.Default (Default(def))
+import Data.Singletons (sing)
+import Data.Type.Equality ((:~:)(Refl))
+
+import Morley.Michelson.Interpret.Pack (packValue')
+import Morley.Michelson.Optimizer.Internal.Proofs
+import Morley.Michelson.Optimizer.Internal.Ruleset
+import Morley.Michelson.Optimizer.Utils
+import Morley.Michelson.Typed.Aliases (Value)
+import Morley.Michelson.Typed.Arith
+import Morley.Michelson.Typed.Instr hiding ((:#))
+import Morley.Michelson.Typed.Scope (ConstantScope, PackedValScope, checkScope)
+import Morley.Michelson.Typed.Sing
+import Morley.Michelson.Typed.T
+import Morley.Michelson.Typed.Value
+import Morley.Util.Peano
+import Morley.Util.PeanoNatural
+
+{-
+Note [Writing optimizer rules]
+------------------------------
+
+We locally redefine (:#) to simplify handling instruction sequence tails.
+Consider that a given instruction sequence can appear in the middle, and then @a
+:# b :# tail@ will match, or at the end of the sequence, and then @a :# b@ will
+match.
+
+Local definition of (:#) makes it so we can always assume there's a tail.
+However, we don't need it when matching on single instructions.
+
+Thus, the rule of thumb is this: if you're matching on a single instruction,
+everything is fine. If you're matching on a sequence, i.e. using (:#), then
+always match on tail.
+-}
+
+-- | Default optimization rules.
+defaultRules :: Ruleset
+defaultRules = foldr ($) def $ uncurry (alterRulesAtPrio . const) <$>
+ -- NB: if adding more main stages, remember to check if
+ -- 'defaultRulesAndPushPack' needs updating.
+ [ (mainStageRules , OptimizationStageMain 0)
+ , (dipDrop2swapDropStageRules , OptimizationStageMainExtended 0)
+ , (fixupStageRules , OptimizationStageFixup 0)
+ , (glueAdjacentInstrsStageRules, OptimizationStageRollAdjacent 0)
+ ]
+ where
+ dipDrop2swapDropStageRules = dipDrop2swapDrop : mainStageRules
+ fixupStageRules = [dipSwapDrop]
+ glueAdjacentInstrsStageRules =
+ [ adjacentDrops
+ , rollPairN
+ , rollUnpairN
+ , rollDips
+ ]
+
+-- | We do not enable 'pushPack' rule by default because it is potentially
+-- dangerous. There are various code processing functions that may depend on
+-- constants, e. g. string transformations.
+defaultRulesAndPushPack :: Ruleset
+defaultRulesAndPushPack = defaultRules
+ & insertRuleAtPrio (OptimizationStageMainExtended 0) pushPack
+
+mainStageRules :: [Rule]
+mainStageRules =
+ [ removeNesting
+ , removeExtStackType
+ , ifNopNop2Drop
+ , nopIsNeutralForSeq
+ , variousNops
+ , dupSwap2dup
+ , noDipNeeded
+ , branchShortCut
+ , compareWithZero
+ , internalNop
+ , simpleDups
+ , adjacentDips
+ , isSomeOnIf
+ , redundantIf
+ , emptyDip
+ , digDug
+ , specificPush
+ , pairUnpair
+ , pairMisc
+ , unpairMisc
+ , swapBeforeCommutative
+ , justDrops
+ , justDoubleDrops
+ , dig1AndDug1AreSwap
+ , notIf
+ , dropMeta
+ , dupDugDrop
+ -- strictly speaking, these rules below are de-optimisations, but they
+ -- expose opportunities for other optimisations, and they are undone in the
+ -- last stage.
+ , unrollPairN
+ , unrollUnpairN
+ , unrollDropN
+ , unrollDips
+ ]
+
+flattenSeqLHS :: Rule -> Rule
+flattenSeqLHS toplevel = Rule $ \case
+ it@(Seq (Seq _ _) _) -> Just $ linearizeAndReapply toplevel it
+ _ -> Nothing
+
+dropMeta :: Rule
+dropMeta = Rule $ \case
+ Meta _ i -> Just i
+ WithLoc _ i -> Just i
+ _ -> Nothing
+
+removeNesting :: Rule
+removeNesting = Rule $ \case
+ Nested i -> Just i
+ _ -> Nothing
+
+-- | STACKTYPE is currently a Nop and may safely be removed.
+removeExtStackType :: Rule
+removeExtStackType = Rule $ \case
+ Ext (STACKTYPE{}) -> Just Nop
+ _ -> Nothing
+
+dipDrop2swapDrop :: Rule
+dipDrop2swapDrop = Rule $ \case
+ DIP DROP -> Just $ SWAP :# DROP
+ _ -> Nothing
+
+ifNopNop2Drop :: Rule
+ifNopNop2Drop = Rule $ \case
+ IF Nop Nop -> Just DROP
+ _ -> Nothing
+
+nopIsNeutralForSeq :: Rule
+nopIsNeutralForSeq = Rule $ \case
+ -- NB: we're not using (:#) here because it'll always match when rhs is Nop
+ Seq Nop i -> Just i
+ Seq i Nop -> Just i
+ _ -> Nothing
+
+variousNops :: Rule
+variousNops = Rule $ \case
+ DUP :# DROP :# c -> Just c
+ DUPN _ :# DROP :# c -> Just c
+ SWAP :# SWAP :# c -> Just c
+ PUSH _ :# DROP :# c -> Just c
+ NONE :# DROP :# c -> Just c
+ UNIT :# DROP :# c -> Just c
+ NIL :# DROP :# c -> Just c
+ EMPTY_SET :# DROP :# c -> Just c
+ EMPTY_MAP :# DROP :# c -> Just c
+ EMPTY_BIG_MAP :# DROP :# c -> Just c
+ LAMBDA _ :# DROP :# c -> Just c
+ SELF _ :# DROP :# c -> Just c
+ NOW :# DROP :# c -> Just c
+ AMOUNT :# DROP :# c -> Just c
+ BALANCE :# DROP :# c -> Just c
+ TOTAL_VOTING_POWER :# DROP :# c -> Just c
+ SOURCE :# DROP :# c -> Just c
+ SENDER :# DROP :# c -> Just c
+ CHAIN_ID :# DROP :# c -> Just c
+ LEVEL :# DROP :# c -> Just c
+ SELF_ADDRESS :# DROP :# c -> Just c
+ READ_TICKET :# DROP :# c -> Just c
+ _ -> Nothing
+
+dupSwap2dup :: Rule
+dupSwap2dup = Rule $ \case
+ DUP :# SWAP :# c -> Just $ DUP :# c
+ _ -> Nothing
+
+noDipNeeded :: Rule
+noDipNeeded = Rule $ \case
+ -- If we put a constant value on stack and then do something under it,
+ -- we can do this "something" on original stack and then put that constant.
+ PUSH x :# DIP f :# c -> Just $ f :# PUSH x :# c
+ UNIT :# DIP f :# c -> Just $ f :# UNIT :# c
+ NOW :# DIP f :# c -> Just $ f :# NOW :# c
+ SENDER :# DIP f :# c -> Just $ f :# SENDER :# c
+ EMPTY_MAP :# DIP f :# c -> Just $ f :# EMPTY_MAP :# c
+ EMPTY_SET :# DIP f :# c -> Just $ f :# EMPTY_SET :# c
+
+ -- If we do something ignoring top of the stack and then immediately
+ -- drop top of the stack, we can drop that item in advance and
+ -- not use 'DIP' at all.
+ DIP f :# DROP :# c -> Just $ DROP :# f :# c
+
+ _ -> Nothing
+
+unrollDips :: Rule
+unrollDips = Rule go
+ where
+ go :: Instr inp out -> Maybe (Instr inp out)
+ go = \case
+ DIPN Zero c -> Just $ c
+ DIPN One c -> Just $ DIP c
+ DIPN (Succ n) c -> DIP <$> go (DIPN n c)
+ _ -> Nothing
+
+rollDips :: Rule
+rollDips = Rule $ \case
+ DIP (DIP c) -> Just $ DIPN Two c
+ DIP (DIPN n c) -> Just $ DIPN (Succ n) c
+ _ -> Nothing
+
+branchShortCut :: Rule
+branchShortCut = Rule $ \case
+ LEFT :# IF_LEFT f _ :# c -> Just $ f :# c
+ RIGHT :# IF_LEFT _ f :# c -> Just $ f :# c
+ CONS :# IF_CONS f _ :# c -> Just $ f :# c
+ NIL :# IF_CONS _ f :# c -> Just $ f :# c
+ NONE :# IF_NONE f _ :# c -> Just $ f :# c
+ SOME :# IF_NONE _ f :# c -> Just $ f :# c
+
+ PUSH vOr@(VOr eitherVal) :# IF_LEFT f g :# c -> case vOr of
+ (_ :: Value ('TOr l r)) -> case eitherVal of
+ Left val -> case checkScope @(ConstantScope l) of
+ Right Dict -> Just $ PUSH val :# f :# c
+ _ -> Nothing
+ Right val -> case checkScope @(ConstantScope r) of
+ Right Dict -> Just $ PUSH val :# g :# c
+ _ -> Nothing
+ PUSH (VList (x : xs)) :# IF_CONS f _ :# c -> Just $ PUSH (VList xs) :# PUSH x :# f :# c
+ PUSH (VList _) :# IF_CONS _ f :# c -> Just $ f :# c
+ PUSH (VOption Nothing) :# IF_NONE f _ :# c -> Just $ f :# c
+ PUSH (VOption (Just val)) :# IF_NONE _ f :# c -> Just $ PUSH val :# f :# c
+ PUSH (VBool True) :# IF f _ :# c -> Just $ f :# c
+ PUSH (VBool False) :# IF _ f :# c -> Just $ f :# c
+ _ -> Nothing
+
+compareWithZero :: Rule
+compareWithZero = Rule $ \case
+ PUSH (VInt 0) :# COMPARE :# EQ :# c -> Just $ EQ :# c
+ PUSH (VNat 0) :# COMPARE :# EQ :# c -> Just $ INT :# EQ :# c
+ _ -> Nothing
+
+-- If an instruction takes another instruction as an argument and that
+-- internal instruction is 'Nop', sometimes the whole instruction is
+-- 'Nop'.
+-- For now we do it only for 'DIP', but ideally we should do it for
+-- 'MAP' as well (which is harder).
+internalNop :: Rule
+internalNop = Rule $ \case
+ DIP Nop -> Just Nop
+
+ _ -> Nothing
+
+simpleDups :: Rule
+simpleDups = Rule $ \case
+ -- DUP 1 is just DUP
+ DUPN One -> Just DUP
+
+ _ -> Nothing
+
+adjacentDips :: Rule
+adjacentDips = Rule $ \case
+ DIP f :# DIP g :# c -> Just $ DIP (f :# g) :# c
+
+ _ -> Nothing
+
+redundantIf :: Rule
+redundantIf = Rule \case
+ IF x y
+ | x == y
+ -> Just $ DROP :# x
+ _ -> Nothing
+
+emptyDip :: Rule
+emptyDip = Rule \case
+ DIP Nop -> Just Nop
+ DIPN _ Nop -> Just Nop
+ _ -> Nothing
+
+digDug :: Rule
+digDug = Rule \case
+ DIG x :# DUG y :# c | Just Refl <- eqPeanoNat x y -> Just c
+ _ -> Nothing
+
+-- | Sequences of @DROP@s can be turned into single @DROP n@.
+-- When @n@ is greater than 2 it saves size and gas.
+-- When @n@ is 2 it saves gas only.
+adjacentDrops :: Rule
+adjacentDrops = Rule $ \case
+ DROP :# DROP :# c -> Just $ DROPN Two :# c
+
+ (DROPN n :: Instr inp out) :# (DROP :: Instr inp' out') :# c
+ -> Just $ DROPN (Succ n) :# c \\ dropNDropNProof @inp @out @out' n One
+ \\ commutativity (singPeanoNat n) (singPeanoNat One)
+
+ (DROP :: Instr inp out) :# (DROPN n :: Instr inp' out') :# c
+ -> Just $ DROPN (Succ n) :# c \\ dropNDropNProof @inp @out @out' One n
+
+ (DROPN n :: Instr inp out) :# (DROPN m :: Instr inp' out') :# c
+ -> Just $ DROPN (addPeanoNat n m) :# c \\ dropNDropNProof @inp @out @out' n m
+
+ _ -> Nothing
+
+specificPush :: Rule
+specificPush = Rule $ \case
+ push@PUSH{} :# c -> (:# c) <$> optimizePush push
+
+ _ -> Nothing
+ where
+ optimizePush :: Instr inp out -> Maybe (Instr inp out)
+ optimizePush = \case
+ PUSH v | _ :: Value v <- v -> case v of
+ VUnit -> Just UNIT
+ VMap m
+ | null m -> case sing @v of STMap{} -> Just EMPTY_MAP
+ VSet m
+ | null m -> case sing @v of STSet{} -> Just EMPTY_SET
+ _ -> Nothing
+
+ _ -> Nothing
+
+
+isSomeOnIf :: Rule
+isSomeOnIf = Rule $ \case
+ IF (PUSH (VOption Just{})) (PUSH (VOption Nothing))
+ :# IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True))
+ :# c
+ -> Just c
+ _ -> Nothing
+
+pairUnpair :: Rule
+pairUnpair = Rule $ \case
+ PAIR :# UNPAIR :# c -> Just c
+
+ UNPAIR :# PAIR :# c -> Just c
+
+ _ -> Nothing
+
+pairMisc :: Rule
+pairMisc = Rule $ \case
+ PAIR :# CDR :# c -> Just $ DROP :# c
+
+ PAIR :# CAR :# c -> Just $ (DIP DROP) :# c
+
+ _ -> Nothing
+
+unpairMisc :: Rule
+unpairMisc = Rule $ \case
+ DUP :# CAR :# DIP CDR :# c -> Just $ UNPAIR :# c
+
+ DUP :# CDR :# DIP CAR :# c -> Just $ UNPAIR :# SWAP :# c
+
+ UNPAIR :# DROP :# c -> Just $ CDR :# c
+ _ -> Nothing
+
+unrollDropN :: Rule
+unrollDropN = Rule go
+ where
+ go :: forall inp out. Instr inp out -> Maybe (Instr inp out)
+ go = \case
+ DROPN Zero -> Just Nop
+ DROPN (Succ n) -> do
+ dropn <- go $ DROPN n
+ Just $ DROP :# dropn
+ \\ unconsListProof @inp n
+ _ -> Nothing
+
+unrollPairN :: Rule
+unrollPairN = Rule go
+ where
+ go :: forall inp out. Instr inp out -> Maybe (Instr inp out)
+ go = \case
+ PAIRN Two -> Just PAIR \\ pairN2isPairProof @inp
+ PAIRN (Succ n@(Succ Succ{}) ) -> do
+ pairn <- go $ PAIRN n
+ Just $ DIP pairn :# PAIR
+ \\ unconsListProof @inp n
+ _ -> Nothing
+
+unrollUnpairN :: Rule
+unrollUnpairN = Rule go
+ where
+ go :: forall inp out. Instr inp out -> Maybe (Instr inp out)
+ go = \case
+ UNPAIRN Two -> Just UNPAIR \\ unpairN2isUnpairProof @inp @out
+ UNPAIRN (Succ n@(Succ Succ{})) -> do
+ unpairn <- go $ UNPAIRN n
+ Just $ UNPAIR :# DIP unpairn
+ \\ unpairNisUnpairDipUnpairNProof @inp @out n
+ _ -> Nothing
+
+rollPairN :: Rule
+rollPairN = Rule $ \case
+ DIP PAIR :# PAIR :# c -> Just $ PAIRN (Succ Two) :# c
+
+ (DIP (PAIRN n@(Succ Succ{})) :: Instr inp out) :# PAIR :# c -> Just $ PAIRN (Succ n) :# c
+ \\ dipPairNPairIsPairNProof @inp n
+
+ _ -> Nothing
+
+rollUnpairN :: Rule
+rollUnpairN = Rule $ \case
+ UNPAIR :# DIP UNPAIR :# c -> Just $ UNPAIRN (Succ Two) :# c
+ UNPAIR :# DIP (UNPAIRN n@(Succ Succ{})) :# c -> Just $ UNPAIRN (Succ n) :# c
+ _ -> Nothing
+
+commuteArith ::
+ forall n m s out. Instr (n ': m ': s) out -> Maybe (Instr (m ': n ': s) out)
+commuteArith = \case
+ ADD -> do Dict <- commutativityProof @Add @n @m; Just ADD
+ MUL -> do Dict <- commutativityProof @Mul @n @m; Just MUL
+ OR -> do Dict <- commutativityProof @Or @n @m; Just OR
+ AND -> do Dict <- commutativityProof @And @n @m; Just AND
+ XOR -> do Dict <- commutativityProof @Xor @n @m; Just XOR
+ _ -> Nothing
+
+swapBeforeCommutative :: Rule
+swapBeforeCommutative = Rule $ \case
+ SWAP :# i :# c -> (:# c) <$> commuteArith i
+
+ _ -> Nothing
+
+pushPack :: Rule
+pushPack = Rule $ \case
+ PUSH x :# PACK :# c -> Just $ pushPacked x :# c
+
+ _ -> Nothing
+ where
+ pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)
+ pushPacked = PUSH . VBytes . packValue'
+
+justDrops :: Rule
+justDrops = Rule $ \case
+ CAR :# DROP :# c -> Just $ DROP :# c
+ CDR :# DROP :# c -> Just $ DROP :# c
+ SOME :# DROP :# c -> Just $ DROP :# c
+ LEFT :# DROP :# c -> Just $ DROP :# c
+ RIGHT :# DROP :# c -> Just $ DROP :# c
+ SIZE :# DROP :# c -> Just $ DROP :# c
+ GETN _ :# DROP :# c -> Just $ DROP :# c
+ CAST :# DROP :# c -> Just $ DROP :# c
+ RENAME :# DROP :# c -> Just $ DROP :# c
+ PACK :# DROP :# c -> Just $ DROP :# c
+ UNPACK :# DROP :# c -> Just $ DROP :# c
+ CONCAT' :# DROP :# c -> Just $ DROP :# c
+ ISNAT :# DROP :# c -> Just $ DROP :# c
+ ABS :# DROP :# c -> Just $ DROP :# c
+ NEG :# DROP :# c -> Just $ DROP :# c
+ NOT :# DROP :# c -> Just $ DROP :# c
+ EQ :# DROP :# c -> Just $ DROP :# c
+ NEQ :# DROP :# c -> Just $ DROP :# c
+ LT :# DROP :# c -> Just $ DROP :# c
+ GT :# DROP :# c -> Just $ DROP :# c
+ LE :# DROP :# c -> Just $ DROP :# c
+ GE :# DROP :# c -> Just $ DROP :# c
+ INT :# 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
+ SHA256 :# DROP :# c -> Just $ DROP :# c
+ SHA512 :# DROP :# c -> Just $ DROP :# c
+ BLAKE2B :# DROP :# c -> Just $ DROP :# c
+ SHA3 :# DROP :# c -> Just $ DROP :# c
+ KECCAK :# DROP :# c -> Just $ DROP :# c
+ HASH_KEY :# DROP :# c -> Just $ DROP :# c
+ PAIRING_CHECK :# DROP :# c -> Just $ DROP :# c
+ ADDRESS :# DROP :# c -> Just $ DROP :# c
+ JOIN_TICKETS :# DROP :# c -> Just $ DROP :# c
+ _ -> Nothing
+
+justDoubleDrops :: Rule
+justDoubleDrops = Rule $ \case
+ PAIR :# DROP :# c -> Just $ DROP :# DROP :# c
+ MEM :# DROP :# c -> Just $ DROP :# DROP :# c
+ GET :# DROP :# c -> Just $ DROP :# DROP :# c
+ APPLY :# DROP :# c -> Just $ DROP :# DROP :# c
+ CONCAT :# DROP :# c -> Just $ DROP :# DROP :# c
+ ADD :# DROP :# c -> Just $ DROP :# DROP :# c
+ SUB :# DROP :# c -> Just $ DROP :# DROP :# c
+ SUB_MUTEZ :# DROP :# c -> Just $ DROP :# DROP :# c
+ MUL :# DROP :# c -> Just $ DROP :# DROP :# c
+ EDIV :# DROP :# c -> Just $ DROP :# DROP :# c
+ OR :# DROP :# c -> Just $ DROP :# DROP :# c
+ AND :# DROP :# c -> Just $ DROP :# DROP :# c
+ XOR :# DROP :# c -> Just $ DROP :# DROP :# c
+ COMPARE :# DROP :# c -> Just $ DROP :# DROP :# c
+ TICKET :# DROP :# c -> Just $ DROP :# DROP :# c
+ SPLIT_TICKET :# DROP :# c -> Just $ DROP :# DROP :# c
+ SWAP :# DROP :# DROP :# c -> Just $ DROP :# DROP :# c
+ _ -> Nothing
+
+dig1AndDug1AreSwap :: Rule
+dig1AndDug1AreSwap = Rule \case
+ DUG One -> Just SWAP
+ DIG One -> Just SWAP
+ _ -> Nothing
+
+notIf :: Rule
+notIf = Rule \case
+ (NOT :: Instr inp out) :# IF a b :# c | STBool <- sing @(Head inp) -> Just $ IF b a :# c
+ _ -> Nothing
+
+-- | NB: This rule MUST be applied AFTER all main stages, but BEFORE nested dips
+-- are rolled up
+dipSwapDrop :: Rule
+dipSwapDrop = Rule \case
+ DIP (SWAP :# DROP) -> Just $ DIPN Two DROP
+ _ -> Nothing
+
+dupDugDrop :: Rule
+dupDugDrop = Rule \case
+ DUP :# DUG (Succ m) :# DROP :# xs -> Just $ DUG m :# xs
+ _ -> Nothing
diff --git a/src/Morley/Michelson/Optimizer/Internal/Ruleset.hs b/src/Morley/Michelson/Optimizer/Internal/Ruleset.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Optimizer/Internal/Ruleset.hs
@@ -0,0 +1,78 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Optimizer rule and ruleset definitions.
+module Morley.Michelson.Optimizer.Internal.Ruleset
+ ( module Morley.Michelson.Optimizer.Internal.Ruleset
+ ) where
+
+import Prelude
+
+import Data.Default (Default(def))
+import Data.Map qualified as Map
+import Fmt (Buildable(..), (+|), (|+))
+
+import Morley.Michelson.Typed.Instr
+
+-- | Type of a single rewrite rule, wrapped in `newtype`. It takes an
+-- instruction and tries to optimize its head (first few instructions). If
+-- optimization succeeds, it returns `Just` the optimized instruction, otherwise
+-- it returns `Nothing`.
+newtype Rule = Rule {unRule :: forall inp out. Instr inp out -> Maybe (Instr inp out)}
+
+-- | Optimization stages. Stages are run in first to last order, each stage has
+-- an 'Int' argument, which allows splitting each stage into sub-stages, which
+-- will run lowest index to highest. All default rules use sub-stage @0@.
+data OptimizationStage
+ = OptimizationStagePrepare Int
+ | OptimizationStageMain Int
+ -- ^ Main optimisation stage, except rules that would interfere with other
+ -- rules.
+ | OptimizationStageMainExtended Int
+ -- ^ All main stage rules.
+ | OptimizationStageFixup Int
+ -- ^ Post main stage fixups.
+ | OptimizationStageRollAdjacent Int
+ -- ^ Main stage rules unroll @DROP n@, @PAIR n@, etc into their primitive
+ -- counterparts to simplify some optimisations. This stages coalesces them
+ -- back.
+ deriving stock (Eq, Ord)
+
+instance Buildable OptimizationStage where
+ build = \case
+ OptimizationStagePrepare n -> "prepare " +| n |+ ""
+ OptimizationStageMain n -> "main " +| n |+ ""
+ OptimizationStageMainExtended n -> "main extended " +| n |+ ""
+ OptimizationStageFixup n -> "fixup " +| n |+ ""
+ OptimizationStageRollAdjacent n -> "roll adjacent " +| n |+ ""
+
+-- | A set of optimization stages. Rules at the same sub-stage are applied in
+-- arbitrary order. See 'OptimizationStage' for explanation of sub-stages.
+--
+-- 'Default' ruleset is empty.
+newtype Ruleset = Ruleset { unRuleset :: Map OptimizationStage (NonEmpty Rule) }
+ deriving newtype Default
+
+instance Semigroup Ruleset where
+ Ruleset l <> Ruleset r = Ruleset $ Map.unionWith (<>) l r
+
+instance Monoid Ruleset where
+ mempty = def
+
+-- | Get rules for a given priority as a list.
+rulesAtPrio :: OptimizationStage -> Ruleset -> [Rule]
+rulesAtPrio prio = maybe [] toList . Map.lookup prio . unRuleset
+
+-- | Insert a single rule at a given priority without touching other rules.
+insertRuleAtPrio :: OptimizationStage -> Rule -> Ruleset -> Ruleset
+insertRuleAtPrio = flip $ alterRulesAtPrio . (:)
+
+-- | Remove the stage with the given priority.
+clearRulesAtPrio :: OptimizationStage -> Ruleset -> Ruleset
+clearRulesAtPrio = alterRulesAtPrio (const [])
+
+-- | Alter all stage rules for a given priority.
+alterRulesAtPrio :: ([Rule] -> [Rule]) -> OptimizationStage -> Ruleset -> Ruleset
+alterRulesAtPrio f prio = Ruleset . Map.alter (nonEmpty . f . maybe [] toList) prio . unRuleset
diff --git a/src/Morley/Michelson/Optimizer/Utils.hs b/src/Morley/Michelson/Optimizer/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Optimizer/Utils.hs
@@ -0,0 +1,107 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+-- | Utilities for writing optimizer rules.
+module Morley.Michelson.Optimizer.Utils
+ ( pattern (:#)
+ , orRule
+ , orSimpleRule
+ , fixpoint
+ , applyOnce
+ , whileApplies
+ , linearizeAndReapply
+ ) where
+
+import Morley.Michelson.Optimizer.Internal.Ruleset (Rule(..))
+import Morley.Michelson.Typed.Instr hiding ((:#))
+
+{- | This is a redefinition of @(:#)@ from "Morley.Michelson.Typed.Instr" that
+is particularly useful for writing optimizer rules. When matching on an
+instruction @x@ that isn't v'Seq', it behaves as if it matched on @x :# Nop@.
+
+When constructing instructions using this pattern, @Nop@ is automatically
+removed.
+
+To understand why this is useful, consider that a given instruction sequence can
+appear in the middle of a sequence, and then @a :# b :# tail@ will match, or at
+the end of the sequence, and then @a :# b@ will match. Thus, to cover all cases
+one would have to duplicate most rules.
+
+This definition of @(:#)@ makes it so we can always assume there's a @tail@.
+However, we don't need it when matching on single instructions.
+
+Thus, the rule of thumb is this: if you're matching on a single instruction,
+everything is fine. If you're matching on a sequence, i.e. using (:#), then
+always match on tail, e.g.
+
+@
+dupSwap2dup :: Rule
+dupSwap2dup = Rule $ \case
+ DUP :# SWAP :# c -> Just $ DUP :# c
+ _ -> Nothing
+@
+
+But this works, too:
+
+@
+ifNopNop2Drop :: Rule
+ifNopNop2Drop = Rule $ \case
+ IF Nop Nop -> Just DROP
+ _ -> Nothing
+@
+
+-}
+pattern (:#) :: Instr inp b -> Instr b out -> Instr inp out
+pattern l :# r <- (\case { x@Seq{} -> x; x -> Seq x Nop } -> Seq l r)
+ where l :# Nop = l
+ Nop :# r = r
+ l :# r = Seq l r
+infixr 8 :#
+
+-- | Combine two rule fixpoints.
+orRule :: (Rule -> Rule) -> (Rule -> Rule) -> (Rule -> Rule)
+orRule l r topl = Rule $ \instr ->
+ (unRule (l topl) $ instr) <|> (unRule (r topl) $ instr)
+
+-- | Combine a rule fixpoint and a simple rule.
+orSimpleRule :: (Rule -> Rule) -> Rule -> (Rule -> Rule)
+orSimpleRule l r topl = Rule $ \instr ->
+ (unRule (l topl) $ instr) <|> (unRule r $ instr)
+
+-- | Turn rule fixpoint into rule.
+fixpoint :: (Rule -> Rule) -> Rule
+fixpoint r = go
+ where
+ go :: Rule
+ go = whileApplies (r go)
+
+-- | Apply the rule once, if it fails, return the instruction unmodified.
+--
+-- Also returns a flag showing whether the rule succeeded or not.
+applyOnce :: Rule -> Instr inp out -> (Any Bool, Instr inp out)
+applyOnce r i = maybe (pure i) (Any True,) (unRule r $ i)
+
+-- | Apply a rule to the same code, until it fails.
+whileApplies :: Rule -> Rule
+whileApplies r = Rule $ go <=< unRule r
+ -- NB: if the rule doesn't apply even once, we want to return Nothing here,
+ -- hence it's first applied above and only if successful goes into recursion.
+ where
+ go :: Instr inp out -> Maybe (Instr inp out)
+ go i = maybe (Just i) go (unRule r i)
+
+-- | Append LHS of v'Seq' to RHS and re-run pointwise ocRuleset at each point.
+-- That might cause reinvocation of this function (see @defaultRule@'),
+-- but effectively this ensures it will flatten any v'Seq'-tree right-to-left,
+-- while evaling no more than once on each node.
+--
+-- The reason this function invokes ocRuleset is when you append an instr
+-- to already-optimised RHS of v'Seq', you might get an optimisable tree.
+--
+-- The argument is a local, non-structurally-recursive ocRuleset.
+linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out
+linearizeAndReapply restart = snd . \case
+ Seq (Seq a b) c ->
+ applyOnce restart $ Seq a (linearizeAndReapply restart (Seq b c))
+
+ other -> applyOnce restart other
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
@@ -22,6 +22,7 @@
, parseValue
, parseExpandValue
, parseType
+ , rawOpsSequence
-- * For tests
, codeEntry
@@ -44,17 +45,17 @@
import Prelude hiding (try)
-import Fmt (pretty, (+|), (|+))
+import Data.Default (def)
+import Fmt (nameF, pretty, unlinesF, (+|), (|+))
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, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead, parse,
- sepEndBy, try)
+ (Parsec, choice, eitherP, eof, errorBundlePretty, getSourcePos, hidden, 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.Macro
import Morley.Michelson.Parser.Common
import Morley.Michelson.Parser.Error
import Morley.Michelson.Parser.Instr
@@ -67,6 +68,11 @@
import Morley.Michelson.Untyped
import Morley.Michelson.Untyped qualified as U
+{- $setup
+>>> import Morley.Michelson.Parser.Lexer
+>>> import Text.Megaparsec (sepEndBy)
+-}
+
----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------
@@ -102,7 +108,7 @@
cbStorage :: Parser Ty
cbStorage = symbol1 "storage" *> type_
-cbCode :: Parser [ParsedOp]
+cbCode :: Parser ParsedOp
cbCode = symbol "code" *> codeEntry
cbView :: Parser (View' ParsedOp)
@@ -111,7 +117,7 @@
viewName <- viewName_
viewArgument <- type_
viewReturn <- type_
- viewCode <- ops
+ viewCode <- codeEntry
return View{..}
contractBlock :: Parser (ContractBlock ParsedOp)
@@ -142,11 +148,8 @@
contract = do
mSpace
result <- braces contractTuple <|> contractTuple
- case orderContractBlock result of
- Just contract' ->
- return contract'
- Nothing ->
- fail $ "Duplicate contract field: " <> pretty result
+ either (fail . pretty . nameF "Contract parsing error" . unlinesF) pure $
+ orderContractBlock result
where
-- @ensureNotDuplicate@ provides a better message and point to the correct line
-- when the parser fails.
@@ -160,7 +163,7 @@
------------------
value :: Parser ParsedValue
-value = value' parsedOp
+value = value' ops
-- | Parse untyped value from text which comes from something that is
-- not a file (which is often the case). So we assume it does not need
@@ -188,36 +191,82 @@
------------------
prim :: Parser ParsedInstr
-prim = primInstr contract parsedOp
+prim = primInstr contract ops
-- Parsed operations (primitive instructions, macros, extras, etc.)
------------------
--- | Parses code block after "code" keyword of a contract.
---
--- This function is part of the module API, its semantics should not change.
-codeEntry :: Parser [ParsedOp]
-codeEntry = bracewrappedOps
+-- | Parses code block after "code" keyword of a contract, or code in a view
+-- block.
+codeEntry :: Parser ParsedOp
+codeEntry = flip Seq <$> getSrcPos <*> bracewrappedOps <|> parsedOp
bracewrappedOps :: Parser [ParsedOp]
-bracewrappedOps = lookAhead (symbol "{") *> ops
+bracewrappedOps = symbol "{" *> rawOpsSequence (symbol "}")
--- |
--- >>> parseNoEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())
--- 1:2:
--- |
--- 1 | {a}
--- | ^
--- unexpected 'a'
--- expecting '{', '}', macro, or primitive instruction
---
+{-| Michelson sequence of instructions, separated with a semicolon. Last
+semicolon is optional, semicolon after @}@ is optional.
+
+The first argument is the sequence terminator, that is to say, usually @}@. This
+might look mysterious, until one considers the alternatives. For example:
+
+>>> let fmt = either (putStrLn . displayException . ParserException) (const $ pure ())
+>>> parseNoEnv (braces (sepEndBy parsedOp semicolon)) "" "{ DIIIP CMPEQ }" & fmt
+...
+1 | { DIIIP CMPEQ }
+ | ^
+unexpected 'D'
+expecting '}'
+...
+>>> parseNoEnv (symbol "{" *> rawOpsSequence (symbol "}")) "" "{ DIIIP CMPEQ }" & fmt
+...
+1 | { DIIIP CMPEQ }
+ | ^
+unexpected 'C'
+...
+
+This happens because @braces . sepEndBy@ backtracks a bit too far.
+
+Note that @braces . sepEndBy@ doesn't match Michelson syntax exactly, it's used
+as an example only.
+-}
+rawOpsSequence :: Parser a -> Parser [ParsedOp]
+rawOpsSequence endP = inner <|> end
+ where
+ end = [] <$ endP
+ inner = do
+ op <- parsedOp
+ let sep = case op of
+ Seq{} -> void $ optional semicolon -- semicolon optional after }
+ _ -> semicolon
+ (op :) <$> ((sep *> rawOpsSequence endP) <|> end)
+
+{- |
+>>> let fmt = either (putStrLn . displayException . ParserException) (const $ pure ())
+>>> parseNoEnv parsedOp "" "{a}" & fmt
+1:2:
+ |
+1 | {a}
+ | ^^
+unexpected "a}"
+expecting '{', '}', macro, or primitive instruction
+
+
+>>> parseNoEnv parsedOp "" "{ UNIT; DIIIP CMPEQ }" & fmt
+1:15:
+ |
+1 | { UNIT; DIIIP CMPEQ }
+ | ^
+unexpected 'C'
+
+-}
parsedOp :: Parser ParsedOp
parsedOp = do
pos <- getSrcPos
choice
[ flip Prim pos <$> prim
- , flip Mac pos <$> macro parsedOp
- , primOrMac
+ , flip Mac pos <$> macro ops
+ , hidden primOrMac
, flip Seq pos <$> bracewrappedOps
]
@@ -239,8 +288,13 @@
srcPos <- getSrcPos
flip Mac srcPos <$> act
-ops :: Parser [ParsedOp]
-ops = ops' parsedOp
+ops :: Parser (ParsedSeq ParsedOp)
+ops = do
+ pos <- getSrcPos
+ choice
+ [ PSSequence <$> bracewrappedOps
+ , PSSingleMacro pos <$> ( parens (allMacros ops) <|> allSingleTokenMacros )
+ ]
-------------------------------------------------------------------------------
-- Mixed parsers
@@ -251,20 +305,24 @@
ifOrIfX = do
pos <- getSrcPos
symbol "IF"
- a <- eitherP cmpOp ops
+ a <- eitherP (try $ cmpOp $ pure def) ops
case a of
Left cmp -> flip Mac pos <$> (IFX cmp <$> ops <*> ops)
- Right op -> flip Prim pos <$> (IF op <$> ops)
+ Right op -> flip Prim pos . IF op <$> ops
-- Some of the operations and macros have the same prefixes in their names
-- So this case should be handled separately
primOrMac :: Parser ParsedOp
-primOrMac = hidden
- $ (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)
- <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))
- <|> (try (primWithPos pairOp) <|> try (primWithPos pairNOp) <|> macWithPos pairMac)
- <|> (try (macWithPos duupMac) <|> primWithPos dupOp)
- <|> (try (macWithPos carnMac) <|> try (macWithPos cdrnMac) <|> try (macWithPos cadrMac) <|> primWithPos carOp <|> primWithPos cdrOp)
+primOrMac = choice
+ [ macWithPos (ifCmpMac ops), ifOrIfX
+ , macWithPos (mapCadrMac ops), primWithPos (mapOp ops)
+ , try (primWithPos pairOp), try (primWithPos pairNOp), macWithPos pairMac
+ , try (macWithPos duupMac), primWithPos dupOp
+ , try (macWithPos (diipMac bracewrappedOps)), primWithPos (dipOp ops)
+ , try (macWithPos carnMac), try (macWithPos cdrnMac), try (macWithPos cadrMac)
+ , primWithPos carOp
+ , primWithPos cdrOp
+ ]
-------------------------------------------------------------------------------
-- Safe construction of Haskell values
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
@@ -5,7 +5,6 @@
module Morley.Michelson.Parser.Instr
( primInstr
- , ops'
-- * These are handled separately to have better error messages
, mapOp
, pairOp
@@ -13,6 +12,7 @@
, pairNOp
, cmpOp
, dupOp
+ , dipOp
, carOp
, cdrOp
, viewOp
@@ -23,7 +23,7 @@
import Text.Megaparsec (choice, label, many, notFollowedBy, try)
import Text.Megaparsec.Char.Lexer qualified as L
-import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..))
+import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..), ParsedSeq(..))
import Morley.Michelson.Parser.Annotations
import Morley.Michelson.Parser.Common
import Morley.Michelson.Parser.Lexer
@@ -33,16 +33,16 @@
import Morley.Michelson.Untyped
-- | Parser for primitive Michelson instruction (no macros and extensions).
-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
- , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser
- , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opParser, loopOp opParser
- , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp
+primInstr :: Parser (Contract' ParsedOp) -> Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+primInstr contractParser opsParser = label "primitive instruction" $ choice
+ [ dropOp, swapOp, digOp, dugOp, pushOp opsParser, someOp, noneOp, unitOp
+ , ifNoneOp opsParser, leftOp, rightOp, ifLeftOp opsParser, nilOp
+ , consOp, ifConsOp opsParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opsParser
+ , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opsParser, loopOp opsParser
+ , lambdaOp opsParser, execOp, applyOp, dipOp opsParser, failWithOp, castOp, renameOp, levelOp
, concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, selfAddressOp, addOp, subOp
, subMutezOp, mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp
- , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, viewOp, selfOp, contractOp
+ , compareOp, cmpOp noteDef, intOp, viewOp, selfOp, contractOp
, transferTokensOp, setDelegateOp
, createContractOp contractParser, implicitAccountOp, nowOp, amountOp
, balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp, pairingCheckOp
@@ -53,38 +53,20 @@
, openChestOp
, saplingEmptyStateOp, saplingVerifyUpdateOp, minBlockTimeOp
, emitOp
- , lambdaRecOp opParser
+ , lambdaRecOp opsParser
, natOp, bytesOp
]
--- | Parse a sequence of instructions.
-ops' :: Parser ParsedOp -> Parser [ParsedOp]
-ops' opParser = (braces $ parseSeq) <|> (pure <$> opParser)
- where
- parseSeq =
- do{ op <- opParser
- ; let separator = case op of
- Seq _ _ -> void (optional semicolon)
- _ -> semicolon
- ; do{ _ <- separator
- ; ops <- parseSeq
- ; return (op:ops)
- }
- <|> return [op]
- }
- <|> return []
-
-
-- Control Structures
failWithOp :: Parser ParsedInstr
failWithOp = word "FAILWITH" FAILWITH
-loopOp :: Parser ParsedOp -> Parser ParsedInstr
-loopOp opParser = word "LOOP" LOOP <*> ops' opParser
+loopOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+loopOp opsParser = word "LOOP" LOOP <*> opsParser
-loopLOp :: Parser ParsedOp -> Parser ParsedInstr
-loopLOp opParser = word "LOOP_LEFT" LOOP_LEFT <*> ops' opParser
+loopLOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+loopLOp opsParser = word "LOOP_LEFT" LOOP_LEFT <*> opsParser
execOp :: Parser ParsedInstr
execOp = word "EXEC" EXEC <*> noteDef
@@ -93,8 +75,8 @@
applyOp = word "APPLY" APPLY <*> noteDef
-- Parses both `DIP` and `DIP n`.
-dipOp :: Parser ParsedOp -> Parser ParsedInstr
-dipOp opParser = parseWithOptionalParameter "DIP" DIPN DIP <*> ops' opParser
+dipOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+dipOp opsParser = parseWithOptionalParameter "DIP" DIPN DIP <*> opsParser
-- Helper for instructions which have optional numeric non-negative parameter.
parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser instr
@@ -123,50 +105,50 @@
dugOp :: Parser ParsedInstr
dugOp = word "DUG" DUG <*> lexeme L.decimal
-pushOp :: Parser ParsedOp -> Parser ParsedInstr
-pushOp opParser = do
+pushOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+pushOp opsParser = do
symbol1 "PUSH"
v <- noteDef
push' v
where
push' :: VarAnn -> Parser ParsedInstr
- push' v = PUSH v <$> type_ <*> value' opParser
+ push' v = PUSH v <$> type_ <*> value' opsParser
unitOp :: Parser ParsedInstr
unitOp = do symbol1 "UNIT"; (t, v) <- notesTV; return $ UNIT t v
-lambdaOp :: Parser ParsedOp -> Parser ParsedInstr
-lambdaOp opParser =
- word "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser
+lambdaOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+lambdaOp opsParser =
+ word "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> opsParser
-lambdaRecOp :: Parser ParsedOp -> Parser ParsedInstr
-lambdaRecOp opParser =
- word "LAMBDA_REC" LAMBDA_REC <*> noteDef <*> type_ <*> type_ <*> ops' opParser
+lambdaRecOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+lambdaRecOp opsParser =
+ word "LAMBDA_REC" LAMBDA_REC <*> noteDef <*> type_ <*> type_ <*> opsParser
neverOp :: Parser ParsedInstr
neverOp = word "NEVER" NEVER
-- Generic comparison
-cmpOp :: Parser ParsedInstr
-cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp
+cmpOp :: Parser VarAnn -> Parser ParsedInstr
+cmpOp ann = (eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp) <*> ann
-eqOp :: Parser ParsedInstr
-eqOp = word "EQ" EQ <*> noteDef
+eqOp :: Parser (VarAnn -> ParsedInstr)
+eqOp = word "EQ" EQ
-neqOp :: Parser ParsedInstr
-neqOp = word "NEQ" NEQ <*> noteDef
+neqOp :: Parser (VarAnn -> ParsedInstr)
+neqOp = word "NEQ" NEQ
-ltOp :: Parser ParsedInstr
-ltOp = word "LT" LT <*> noteDef
+ltOp :: Parser (VarAnn -> ParsedInstr)
+ltOp = word "LT" LT
-gtOp :: Parser ParsedInstr
-gtOp = word "GT" GT <*> noteDef
+gtOp :: Parser (VarAnn -> ParsedInstr)
+gtOp = word "GT" GT
-leOp :: Parser ParsedInstr
-leOp = word "LE" LE <*> noteDef
+leOp :: Parser (VarAnn -> ParsedInstr)
+leOp = word "LE" LE
-geOp :: Parser ParsedInstr
-geOp = word "GE" GE <*> noteDef
+geOp :: Parser (VarAnn -> ParsedInstr)
+geOp = word "GE" GE
-- ad-hoc comparison
@@ -302,14 +284,14 @@
getAndUpdateOp :: Parser ParsedInstr
getAndUpdateOp = word "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef
-iterOp :: Parser ParsedOp -> Parser ParsedInstr
-iterOp opParser = word "ITER" ITER <*> ops' opParser
+iterOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+iterOp opsParser = word "ITER" ITER <*> opsParser
sizeOp :: Parser ParsedInstr
sizeOp = word "SIZE" SIZE <*> noteDef
-mapOp :: Parser ParsedOp -> Parser ParsedInstr
-mapOp opParser = word "MAP" MAP <*> noteDef <*> ops' opParser
+mapOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+mapOp opsParser = word "MAP" MAP <*> noteDef <*> opsParser
getOp :: Parser ParsedInstr
getOp = do
@@ -324,8 +306,8 @@
consOp :: Parser ParsedInstr
consOp = word "CONS" CONS <*> noteDef
-ifConsOp :: Parser ParsedOp -> Parser ParsedInstr
-ifConsOp opParser = word "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser
+ifConsOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+ifConsOp opsParser = word "IF_CONS" IF_CONS <*> opsParser <*> opsParser
-- Operations on options
@@ -335,8 +317,8 @@
noneOp :: Parser ParsedInstr
noneOp = do symbol1 "NONE"; (t, v) <- notesTV; NONE t v <$> type_
-ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr
-ifNoneOp opParser = word "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser
+ifNoneOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+ifNoneOp opsParser = word "IF_NONE" IF_NONE <*> opsParser <*> opsParser
-- Operations on unions
@@ -348,8 +330,8 @@
rightOp = do symbol1 "RIGHT"; (t, v, (f, f')) <- notesTVF2Def;
RIGHT t v f f' <$> type_
-ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr
-ifLeftOp opParser = word "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser
+ifLeftOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
+ifLeftOp opsParser = word "IF_LEFT" IF_LEFT <*> opsParser <*> opsParser
-- Operations on contracts
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
@@ -5,8 +5,11 @@
module Morley.Michelson.Parser.Macro
( macro
+ , allMacros
+ , allSingleTokenMacros
-- * These are handled separately to have better error messages
, duupMac
+ , diipMac
, pairMac
, ifCmpMac
, mapCadrMac
@@ -17,45 +20,101 @@
import Prelude hiding (note, try)
-import Text.Megaparsec (label, notFollowedBy, skipMany, try)
+import Data.Default (Default(..))
+import Text.Megaparsec (choice, label, skipMany)
import Text.Megaparsec.Char (string)
import Text.Megaparsec.Char.Lexer (decimal)
-import Unsafe qualified (fromIntegral)
import Morley.Michelson.Macro
- (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))
+ (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), ParsedSeq, UnpairStruct(..))
import Morley.Michelson.Macro qualified as Macro
import Morley.Michelson.Parser.Annotations
-import Morley.Michelson.Parser.Instr
+import Morley.Michelson.Parser.Instr qualified as Instr
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Types (Parser)
import Morley.Michelson.Untyped (noAnn)
-macro :: Parser ParsedOp -> Parser Macro
-macro opParser = label "macro"
- $ setCadrMac
- <|> (string "CMP" >> return CMP <*> cmpOp <*> noteDef)
+data AllowAnnotations = ForbidAnnotations | AllowAnnotations
+
+annWithDef :: Default a => AllowAnnotations -> Parser a -> Parser a
+annWithDef allow p = case allow of
+ AllowAnnotations -> p
+ ForbidAnnotations -> pure def
+
+cmpOp :: AllowAnnotations -> Parser Macro.ParsedInstr
+cmpOp = Instr.cmpOp . flip annWithDef noteDef
+
+-- | Macros consisting of a single token are allowed in more contexts than other
+-- macros.
+singleTokenMacro
+ :: AllowAnnotations
+ -- ^ Whether we allow annotations. When used for parsing a single token, this
+ -- is obviously disabled. Enabled when reused in the general context, e.g. in 'macro'.
+ -> Parser Macro
+singleTokenMacro allowAnns = choice
+ [ setCadrMac allowAnns
+ , string "CMP" *> (CMP <$> cmpOp allowAnns)
+ , word "FAIL" FAIL
+ , string "ASSERT_CMP" *> (ASSERT_CMP <$> cmpOp allowAnns)
+ , word "ASSERT_NONE" ASSERT_NONE
+ , word "ASSERT_SOME" ASSERT_SOME
+ , word "ASSERT_LEFT" ASSERT_LEFT
+ , word "ASSERT_RIGHT" ASSERT_RIGHT
+ , string "ASSERT_" *> (ASSERTX <$> cmpOp allowAnns)
+ , word "ASSERT" ASSERT
+ , unpairMac allowAnns
+ ]
+
+-- | This includes all macros consisting of a single token, i.e. also the
+-- specially-handled ones, like @PAIIR@, @CADR@, etc, but not @DUUP@, as it's
+-- always represented as @DUPN@ and thus behaves like a primitive.
+allSingleTokenMacros :: Parser Macro
+allSingleTokenMacros = label "single-token macro" $ choice
+ [ singleTokenMacro ForbidAnnotations
+ , pairMac' ForbidAnnotations
+ , cadrMac' ForbidAnnotations
+ ]
+
+-- | Includes all macros, also the specially-handled ones. Macros are allowed in
+-- more contexts than instructions, so sometimes it's unambiguous.
+--
+-- Notably @DUUP@ and @DIIP@ are excluded, as they're always represented by a
+-- single instruction and thus behave more like a primitive.
+allMacros :: Parser (ParsedSeq ParsedOp) -> Parser Macro
+allMacros ops = label "macro" $ choice
+ [ macro ops
+ , pairMac
+ , carnMac
+ , cdrnMac
+ , cadrMac
+ , ifCmpMac ops
+ , mapCadrMac ops
+ , ifX ops
+ ]
+
+macro :: Parser (ParsedSeq ParsedOp) -> Parser Macro
+macro ops = label "macro"
+ $ singleTokenMacro AllowAnnotations
<|> 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)
+-- | This might look strange, but at the time of writing, reference
+-- implementation requires braced argument to @DIIP@, even if the argument is a
+-- macro. Thus, @DIP 2 FAIL@ is fine, but @DIIP FAIL@ is a syntax error.
+diipMac :: Parser [ParsedOp] -> Parser Macro
+diipMac ops =
+ (string "DI" *> (DIIP . succ <$> num "I") <* symbol1 "P") <*> (Macro.PSSequence <$> ops)
+
+num :: Text -> Parser Word
+num str = length <$> some (string str)
+
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)
+duupMac = duupMac' AllowAnnotations
+duupMac' :: AllowAnnotations -> Parser Macro
+duupMac' allowAnns =
+ (string "DU" *> (DUUP . succ <$> num "U") <* symbol1 "P") <*> annWithDef allowAnns noteDef
+
pairMacInner :: Parser PairStruct
pairMacInner = do
string "P"
@@ -64,10 +123,13 @@
return $ P l r
pairMac :: Parser Macro
-pairMac = do
+pairMac = pairMac' AllowAnnotations
+
+pairMac' :: AllowAnnotations -> Parser Macro
+pairMac' allowAnns = do
a <- pairMacInner
symbol1 "R"
- (tn, vn, fns) <- permute3Def noteDef note (some note)
+ (tn, vn, fns) <- annWithDef allowAnns $ permute3Def noteDef note (some note)
let ps = Macro.mapPairLeaves fns a
return $ PAPAIR ps tn vn
@@ -78,22 +140,21 @@
r <- (string "I" $> UF) <|> unpairMacInner
return $ UP l r
-unpairMac :: Parser Macro
-unpairMac = do
- string "UN"
- a <- unpairMacInner
- symbol1 "R"
- skipMany $ (void noteF) <|> (void noteV)
- return $ UNPAPAIR a
+unpairMac :: AllowAnnotations -> Parser Macro
+unpairMac allowAnns =
+ string "UN" *> (UNPAPAIR <$> unpairMacInner) <* symbol1 "R" <*
+ annWithDef allowAnns (skipMany $ void noteF <|> void noteV)
cadrMac :: Parser Macro
-cadrMac = lexeme $ do
+cadrMac = cadrMac' AllowAnnotations
+
+cadrMac' :: AllowAnnotations -> Parser Macro
+cadrMac' allowAnns = do
string "C"
- a <- some $ try $ cadrInner <* notFollowedBy (string "R")
- b <- cadrInner
+ as <- (:) <$> cadrInner <*> some cadrInner
symbol1 "R"
- (vn, fn) <- notesVF
- return $ CADR (a ++ pure b) vn fn
+ (vn, fn) <- annWithDef allowAnns notesVF
+ return $ CADR as vn fn
cadrInner :: Parser CadrStruct
cadrInner = (string "A" $> A) <|> (string "D" $> D)
@@ -105,22 +166,24 @@
cdrnMac = symbol1 "CDR" *> (CDRN <$> noteDef <*> lexeme decimal)
{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}
-setCadrMac :: Parser Macro
-setCadrMac = do
+setCadrMac :: AllowAnnotations -> Parser Macro
+setCadrMac allowAnns = do
string "SET_C"
a <- some cadrInner
symbol1 "R"
- (v, f) <- notesVF
+ (v, f) <- annWithDef allowAnns notesVF
return $ SET_CADR a v f
-mapCadrMac :: Parser ParsedOp -> Parser Macro
-mapCadrMac opParser = do
+mapCadrMac :: Parser (ParsedSeq ParsedOp) -> Parser Macro
+mapCadrMac ops = do
string "MAP_C"
a <- some cadrInner
symbol1 "R"
(v, f) <- notesVF
- MAP_CADR a v f <$> ops' opParser
+ MAP_CADR a v f <$> ops
-ifCmpMac :: Parser ParsedOp -> Parser Macro
-ifCmpMac opParser = string "IFCMP" >> return
- IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser
+ifCmpMac :: Parser (ParsedSeq ParsedOp) -> Parser Macro
+ifCmpMac ops = string "IFCMP" $> IFCMP <*> cmpOp ForbidAnnotations <*> ops <*> ops
+
+ifX :: Parser (ParsedSeq ParsedOp) -> Parser Macro
+ifX ops = symbol "IF" $> IFX <*> cmpOp ForbidAnnotations <*> ops <*> ops
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
@@ -21,7 +21,7 @@
import Text.Megaparsec.Char (char, string)
import Text.Megaparsec.Char.Lexer qualified as L
-import Morley.Michelson.Macro (ParsedOp, ParsedValue)
+import Morley.Michelson.Macro (ParsedOp, ParsedSeq(..), ParsedValue)
import Morley.Michelson.Parser.Error
import Morley.Michelson.Parser.Helpers
import Morley.Michelson.Parser.Lexer
@@ -31,22 +31,22 @@
-- | Parse untyped 'ParsedValue'. Take instruction parser as argument
-- to avoid cyclic dependencies between modules, hence ' in its name.
-value' :: Parser ParsedOp -> Parser ParsedValue
-value' opParser = parensOrTuple opParser <|> valueInnerWithoutParens opParser
+value' :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+value' opsParser = parensOrTuple opsParser <|> valueInnerWithoutParens opsParser
-parensOrTuple :: Parser ParsedOp -> Parser ParsedValue
-parensOrTuple opParser = parens $ value' opParser
+parensOrTuple :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+parensOrTuple opsParser = parens $ value' opsParser
-valueInnerWithoutParens :: Parser ParsedOp -> Parser ParsedValue
-valueInnerWithoutParens opParser = label "value" $ choice $
+valueInnerWithoutParens :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+valueInnerWithoutParens opsParser = label "value" $ choice $
[ stringLiteral, bytesLiteral, intLiteral, unitValue
- , trueValue, falseValue, pairValueCore opParser, leftValue opParser
- , rightValue opParser, someValue opParser, noneValue, nilValue
- , seqOrLambda opParser, mapValue opParser, lambdaRecValue opParser
+ , trueValue, falseValue, pairValueCore opsParser, leftValue opsParser
+ , rightValue opsParser, someValue opsParser, noneValue, nilValue
+ , seqOrLambda opsParser, mapValue opsParser, lambdaRecValue opsParser
]
-seqOrLambda :: Parser ParsedOp -> Parser ParsedValue
-seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser
+seqOrLambda :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+seqOrLambda opsParser = try (lambdaValue opsParser) <|> seqValue opsParser
stringLiteral :: Parser ParsedValue
stringLiteral = lexeme $ U.ValueString . unsafe . mkMText . toText <$> do
@@ -73,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 (U.Value' op)
+bytesLiteral :: Parser (U.Value' f op)
bytesLiteral = lexeme $ do
string "0x"
hexdigits <- takeWhileP Nothing Char.isHexDigit
@@ -83,7 +83,7 @@
(return . U.ValueBytes . U.InternalByteString)
mBytes
-intLiteral :: Parser (U.Value' op)
+intLiteral :: Parser (U.Value' f op)
intLiteral = lexeme $ try $ U.ValueInt <$> L.signed pass L.decimal
unitValue :: Parser ParsedValue
@@ -95,21 +95,21 @@
falseValue :: Parser ParsedValue
falseValue = word "False" U.ValueFalse
-pairValueCore :: Parser ParsedOp -> Parser ParsedValue
-pairValueCore opParser = symbol1 "Pair" *> pairInner
+pairValueCore :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+pairValueCore opsParser = symbol1 "Pair" *> pairInner
where
pairInner = U.ValuePair
- <$> value' opParser
- <*> (foldr1 U.ValuePair <$> some' (value' opParser))
+ <$> value' opsParser
+ <*> (foldr1 U.ValuePair <$> some' (value' opsParser))
-leftValue :: Parser ParsedOp -> Parser ParsedValue
-leftValue opParser = word "Left" U.ValueLeft <*> value' opParser
+leftValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+leftValue opsParser = word "Left" U.ValueLeft <*> value' opsParser
-rightValue :: Parser ParsedOp -> Parser ParsedValue
-rightValue opParser = word "Right" U.ValueRight <*> value' opParser
+rightValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+rightValue opsParser = word "Right" U.ValueRight <*> value' opsParser
-someValue :: Parser ParsedOp -> Parser ParsedValue
-someValue opParser = word "Some" U.ValueSome <*> value' opParser
+someValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+someValue opsParser = word "Some" U.ValueSome <*> value' opsParser
noneValue :: Parser ParsedValue
noneValue = word "None" U.ValueNone
@@ -117,25 +117,21 @@
nilValue :: Parser ParsedValue
nilValue = U.ValueNil <$ (try $ braces pass)
-lambdaValue :: Parser ParsedOp -> Parser ParsedValue
-lambdaValue opParser = U.ValueLambda <$> ops1
- where
- ops1 :: Parser (NonEmpty ParsedOp)
- ops1 = braces $ sepEndBy1 opParser semicolon
+lambdaValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+lambdaValue opsParser = opsParser <&> \case
+ PSSequence [] -> U.ValueNil
+ ops -> U.ValueLambda ops
-lambdaRecValue :: Parser ParsedOp -> Parser ParsedValue
-lambdaRecValue opParser = word "Lambda_rec" U.ValueLamRec <*> ops1
- where
- ops1 :: Parser (NonEmpty ParsedOp)
- ops1 = braces $ sepEndBy1 opParser semicolon
+lambdaRecValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+lambdaRecValue opsParser = word "Lambda_rec" U.ValueLamRec <*> opsParser
-seqValue :: Parser ParsedOp -> Parser ParsedValue
-seqValue opParser =
- U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon)
+seqValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+seqValue opsParser =
+ U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opsParser) semicolon)
-eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)
-eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser
+eltValue :: Parser (ParsedSeq ParsedOp) -> Parser (U.Elt ParsedSeq ParsedOp)
+eltValue opsParser = word "Elt" U.Elt <*> value' opsParser <*> value' opsParser
-mapValue :: Parser ParsedOp -> Parser ParsedValue
-mapValue opParser =
- U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)
+mapValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
+mapValue opsParser =
+ U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opsParser) semicolon)
diff --git a/src/Morley/Michelson/Printer.hs b/src/Morley/Michelson/Printer.hs
--- a/src/Morley/Michelson/Printer.hs
+++ b/src/Morley/Michelson/Printer.hs
@@ -16,14 +16,14 @@
import Data.Singletons (SingI)
import Data.Text.Lazy qualified as TL
-import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, printDoc, renderAnyBuildable)
+import Morley.Michelson.Printer.Util
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
-- | Convert an untyped contract into a textual representation which
-- will be accepted by the OCaml reference client: @octez-client@.
printUntypedContract :: (RenderDoc op) => Bool -> U.Contract' op -> TL.Text
-printUntypedContract forceSingleLine = printDoc forceSingleLine . renderDoc doesntNeedParens
+printUntypedContract = printRenderDoc
-- | Convert a typed contract into a textual representation which
-- will be accepted by the OCaml reference client: @octez-client@.
@@ -40,17 +40,15 @@
-- | Convert typed value into a textual representation which
-- will be accepted by the OCaml reference client: @octez-client@.
printTypedValue
- :: forall t.
- (T.ProperUntypedValBetterErrors t)
+ :: forall t. (T.UntypedValScope t)
=> Bool -> T.Value t -> TL.Text
printTypedValue forceSingleLine =
printUntypedValue forceSingleLine . T.untypeValue
-- | Convert untyped value into a textual representation which
-- will be accepted by the OCaml reference client: @octez-client@.
-printUntypedValue :: (RenderDoc op) => Bool -> U.Value' op -> TL.Text
-printUntypedValue forceSingleLine =
- printDoc forceSingleLine . renderDoc doesntNeedParens
+printUntypedValue :: (Foldable f, RenderDoc op) => Bool -> U.Value' f op -> TL.Text
+printUntypedValue = printRenderDoc
-- | Convert 'T.SomeContract' into a textual representation which
-- will be accepted by the OCaml reference client: @octez-client@.
diff --git a/src/Morley/Michelson/Printer/Util.hs b/src/Morley/Michelson/Printer/Util.hs
--- a/src/Morley/Michelson/Printer/Util.hs
+++ b/src/Morley/Michelson/Printer/Util.hs
@@ -1,6 +1,8 @@
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
+{-# OPTIONS_GHC -Wno-orphans #-}
+
-- | Utilities for rendering Michelson code in a format compatible with
-- Octez software (e.g @octez-client@)
module Morley.Michelson.Printer.Util
@@ -9,6 +11,7 @@
, printDoc
, printDocB
, printDocS
+ , printRenderDoc
, renderOps
, renderOpsList
, renderOpsListNoBraces
@@ -30,13 +33,14 @@
import Prelude hiding (group)
import Control.Exception (assert)
-import Data.Text.Lazy qualified as LT
+import Data.Foldable qualified as Foldable
import Data.Text.Lazy.Builder (Builder)
-import Fmt (Buildable, pretty)
-import Text.PrettyPrint.Leijen.Text
- (Doc, SimpleDoc, align, braces, displayB, displayT, enclose, encloseSep, hsep, isEmpty, lbracket,
- parens, punctuate, rbracket, renderOneLine, renderPretty, semi, sep, space, text, textStrict,
- (<+>), ())
+import Fmt (Buildable(build), FromSimpleDoc(..))
+import Fmt.Operators ((<+>), ())
+import Fmt.Utils (Doc, SimpleDoc, isEmpty, mkLayoutOptions, renderOneLine)
+import Prettyprinter
+ (align, braces, enclose, encloseSep, group, hsep, layoutPretty, lbracket, parens, punctuate,
+ rbracket, semi, sep, space)
-- | Environment carried during recursive rendering.
newtype RenderContext = RenderContext
@@ -47,9 +51,8 @@
-- parentheses.
}
--- | Generalize converting a type into a
--- Text.PrettyPrint.Leijen.Text.Doc. Used to pretty print Michelson code
--- and define Fmt.Buildable instances.
+-- | Generalize converting a type into a 'Doc'. Used to pretty print Michelson
+-- code and define 'Buildable' instances.
class RenderDoc a where
renderDoc :: RenderContext -> a -> Doc
@@ -64,49 +67,64 @@
isRenderable _ = True
instance RenderDoc Text where
- renderDoc _ = textStrict
+ renderDoc _ = build
+instance RenderDoc Doc where
+ renderDoc = addParens
+
-- | Renders a list of 'RenderDoc' elements surrounded with square brackets,
-- separated by a comma and a space.
renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc
-renderDocList context = encloseSep lbracket rbracket ", " . fmap (renderDoc context)
+renderDocList context = align . encloseSep lbracket rbracket ", " . fmap (renderDoc context)
renderAnyBuildable :: Buildable a => a -> Doc
-renderAnyBuildable = text . pretty
+renderAnyBuildable = build
+{-# DEPRECATED renderAnyBuildable "Use build instead" #-}
-- | A new type that can wrap values so that the RenderDoc
-- instances of the combined value can have a different
-- behavior for the pretty printer.
newtype Prettier a = Prettier a
deriving stock Functor
+{-# DEPRECATED Prettier "This has no actual effect nowadays" #-}
--- | Convert 'Doc' to 'Text' with a line width of 80.
-printDoc :: Bool -> Doc -> LT.Text
-printDoc oneLine = displayT . doRender oneLine
+instance RenderDoc a => RenderDoc (Prettier a) where
+ renderDoc ctx (Prettier a) = renderDoc ctx a
+-- | Convert anything renderable to some text format with line width of 80.
+printRenderDoc :: (RenderDoc a, FromSimpleDoc b) => Bool -> a -> b
+printRenderDoc oneLine = fmtSimple . doRender oneLine . renderDoc doesntNeedParens
+
+-- | Convert 'Doc' to 'LText' with a line width of 80.
+printDoc :: Bool -> Doc -> LText
+printDoc = printRenderDoc
+
-- | Convert 'Doc' to 'Builder' in the same manner as 'printDoc'.
printDocB :: Bool -> Doc -> Builder
-printDocB oneLine = displayB . doRender oneLine
+printDocB = printRenderDoc
-- | Convert 'Doc' to 'String' in the same manner as 'printDoc'.
printDocS :: Bool -> Doc -> String
-printDocS oneLine = toString . printDoc oneLine
+printDocS = printRenderDoc
+{-# DEPRECATED printDoc, printDocB, printDocS "Use printRenderDoc instead" #-}
+
-- | Generic way to render the different op types that get passed
-- to a contract.
renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc
-renderOps oneLine = renderOpsList oneLine . toList
+renderOps = renderOpsList
+{-# DEPRECATED renderOps "Use renderOpsList instead" #-}
-- | Render a comma-separated list of items in braces
-renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc
+renderOpsList :: (RenderDoc op, Foldable f) => Bool -> f op -> Doc
renderOpsList oneLine ops =
braces $ enclose space space $ renderOpsListNoBraces oneLine ops
-- | Render a semi-colon-separated list of items without braces
-renderOpsListNoBraces :: RenderDoc op => Bool -> [op] -> Doc
+renderOpsListNoBraces :: (RenderDoc op, Foldable f) => Bool -> f op -> Doc
renderOpsListNoBraces oneLine =
align . (if oneLine then hsep else sep) . punctuate semi .
- fmap (renderDoc doesntNeedParens) . filter isRenderable
+ fmap (renderDoc doesntNeedParens) . filter isRenderable . Foldable.toList
-- | Wrap documents in parentheses if there are two or more in the list.
wrapInParens :: RenderContext -> NonEmpty Doc -> Doc
@@ -115,19 +133,24 @@
in addParens (RenderContext (pn && moreThanOne)) $
foldr (<+>) mempty ds
--- | Turn something that is instance of `RenderDoc` into a `Builder`.
--- It's formatted the same way as `printDoc` formats docs.
-buildRenderDoc :: RenderDoc a => a -> Builder
-buildRenderDoc = printDocB True . renderDoc doesntNeedParens
+-- | 'renderDoc', then 'group' and 'align'. Generally, this is the same as
+-- 'build'.
+buildRenderDoc :: RenderDoc a => a -> Doc
+buildRenderDoc = align . group . renderDoc doesntNeedParens
--- | Works as 'buildRenderDoc' above, but doesn't force the doc to be printed in one line
-buildRenderDocExtended :: RenderDoc a => a -> Builder
-buildRenderDocExtended = printDocB False . renderDoc doesntNeedParens
+-- | Works as 'buildRenderDoc' above, but doesn't 'group'.
+buildRenderDocExtended :: RenderDoc a => a -> Doc
+buildRenderDocExtended = align . renderDoc doesntNeedParens
+{-# DEPRECATED buildRenderDoc, buildRenderDocExtended
+ "`RenderDoc` already implies `Buildable`, use `build` if you can" #-}
+instance {-# overlappable #-} RenderDoc a => Buildable a where
+ build = align . group . renderDoc doesntNeedParens
+
-- | Here using a page width of 80 and a ribbon width of 1.0
-- https://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html
doRender :: Bool -> Doc -> SimpleDoc
-doRender oneLine = if oneLine then renderOneLine else renderPretty 1.0 80
+doRender oneLine = if oneLine then renderOneLine else layoutPretty $ mkLayoutOptions 1.0 80
-- Smart parentheses
----------------------------------------------------------------------------
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
@@ -41,6 +41,7 @@
, erInterpretResults
, erRemainingSteps
, ExecutorError' (..)
+ , ExecutorErrorPrim (..)
, ExecutorError
, ExecutorM
, runExecutorM
@@ -64,6 +65,7 @@
import Control.Lens (assign, at, each, ix, makeLenses, to, (.=), (<>=))
import Control.Monad.Except (Except, liftEither, runExcept, throwError)
+import Data.Coerce (coerce)
import Data.Constraint (Dict(..), (\\))
import Data.Default (Default(..))
import Data.HashSet qualified as HS
@@ -72,7 +74,8 @@
import Data.Text.IO (getContents)
import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Data.Type.Equality (pattern Refl)
-import Fmt (Buildable(build), blockListF, fmt, fmtLn, indentF, nameF, pretty, (+|), (|+))
+import Data.Typeable (cast)
+import Fmt (Buildable(build), blockListF, fmt, indentF, nameF, pretty, unlinesF, (+|), (|+))
import Text.Megaparsec (parse)
import Morley.Michelson.Interpret
@@ -125,20 +128,10 @@
instance Buildable ExecutorOp where
build = \case
- TransferOp (TransferOperation addr TxData{..} _)->
- "Transfer " +| tdAmount |+ " tokens from " +| tdSenderAddress |+ " to " +| addr |+ ""
- OriginateOp OriginationOperation{..} ->
- "Originate a contract with" <>
- " delegate " +| maybe "" build ooDelegate |+
- " and balance = " +| ooBalance |+ ""
- SetDelegateOp SetDelegateOperation{..} ->
- "Set delegate of contract " +| sdoContract |+
- " to " +| maybe "" build sdoDelegate |+ ""
- EmitOp (EmitOperation source T.Emit{..}) ->
- "Emit event " +| emTag |+
- " from contract " +| source |+
- " with type " +| emNotes |+
- " and value " +| emValue |+ ""
+ TransferOp op -> build op
+ OriginateOp op -> build op
+ SetDelegateOp op -> build op
+ EmitOp op -> build op
data SomeInterpretResult = forall st. SomeInterpretResult
{ unSomeInterpretResult :: InterpretResult st
@@ -165,6 +158,7 @@
, _eeLevel :: Natural
, _eeMinBlockTime :: Natural
, _eeTcOpts :: TypeCheckOptions
+ , _eeCallChain :: [ExecutorOp]
}
deriving stock (Generic)
@@ -190,10 +184,17 @@
makeLenses ''ExecutorState
makeLenses ''ExecutorLog
+-- | 'ExecutorErrorPrim', enriched by the list of operations that succeeded
+-- before the error.
+data ExecutorError' a = ExecutorError
+ { eeCallStack :: [ExecutorOp]
+ , eeError :: ExecutorErrorPrim a
+ } deriving stock (Show, Functor, Foldable, Traversable)
+
-- | Errors that can happen during contract interpreting.
-- Type parameter @a@ determines how contracts will be represented
-- in these errors, e.g. 'Address'.
-data ExecutorError' a
+data ExecutorErrorPrim a
= EEUnknownContract a
-- ^ The interpreted contract hasn't been originated.
| EEInterpreterFailed a (InterpretError Void)
@@ -245,7 +246,7 @@
-- ^ Trying to run emit operation as a global operation, which should be impossible.
deriving stock (Show, Functor, Foldable, Traversable)
-instance (Buildable a) => Buildable (ExecutorError' a) where
+instance (Buildable a) => Buildable (ExecutorErrorPrim a) where
build =
\case
EEUnknownAddressAlias (SomeAlias (alias :: Alias kind)) ->
@@ -295,6 +296,18 @@
EEGlobalEmitOp ->
"Attempted to run emit event as a global operation, this should be impossible."
+-- | To reduce friction between 'ExecutorError'' and 'ExecutorErrorPrim', this
+-- instance will try to run 'fromException' for both.
+instance (Typeable a, Show a, Buildable a) => Exception (ExecutorErrorPrim a) where
+ displayException = pretty
+ fromException (SomeException exc) = cast exc <|> fmap eeError (cast exc)
+
+instance (Buildable a) => Buildable (ExecutorError' a) where
+ build ExecutorError{..} = unlinesF
+ [ build eeError
+ , nameF "While running" $ unlinesF $ build <$> eeCallStack
+ ]
+
type ExecutorError = ExecutorError' Address
instance (Typeable a, Show a, Buildable a) => Exception (ExecutorError' a) where
@@ -532,7 +545,7 @@
runExecutorM now level minBlockTime remainingSteps tcOpts gState action =
fmap preResToRes
$ runExcept
- $ runStateT (runReaderT action $ ExecutorEnv now level minBlockTime tcOpts)
+ $ runStateT (runReaderT action $ ExecutorEnv now level minBlockTime tcOpts mempty)
initialState
where
initialOpHash = error "Initial OperationHash touched"
@@ -561,7 +574,7 @@
--
-- If 'croDryRun' is @False@, the final state is written back to the disk.
--
--- If the executor fails with 'ExecutorError' it will be thrown as an exception.
+-- If the executor fails with t'ExecutorError' it will be thrown as an exception.
runExecutorMWithDB
:: CommonRunOptions
-> ExecutorM a
@@ -577,7 +590,7 @@
mapM_ printInterpretResult _erInterpretResults
when (verbose && not (null _erUpdates)) $ do
- fmtLn $ nameF "Updates" (blockListF _erUpdates)
+ putTextLn $ fmt $ nameF "Updates" (blockListF _erUpdates)
putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps <> "."
return (res, a)
@@ -612,10 +625,10 @@
implicitAddrMb <- preuse $ esGState . gsImplicitAddressAliasesL . ix (ImplicitAlias aliasText)
contractAddrMb <- preuse $ esGState . gsContractAddressAliasesL . ix (ContractAlias aliasText)
case (implicitAddrMb, contractAddrMb) of
- (Nothing, Nothing) -> throwError $ EEUnknownL1AddressAlias aliasText
+ (Nothing, Nothing) -> throwEE $ EEUnknownL1AddressAlias aliasText
(Just implicitAddr, Nothing) -> pure $ Constrained implicitAddr
(Nothing, Just contractAddr) -> pure $ Constrained contractAddr
- (Just implicitAddr, Just contractAddr) -> throwError $ EEAmbiguousAlias aliasText implicitAddr contractAddr
+ (Just implicitAddr, Just contractAddr) -> throwEE $ EEAmbiguousAlias aliasText implicitAddr contractAddr
SAOAKindSpecified (AddressResolved (addr@ContractAddress{})) -> pure $ Constrained addr
SAOAKindSpecified (AddressResolved (addr@ImplicitAddress{})) -> pure $ Constrained addr
SAOAKindSpecified (AddressAlias alias) -> do
@@ -625,7 +638,7 @@
ContractAlias{} -> esGState . gsContractAddressAliasesL . ix alias . to Constrained
case addrMb of
Just addr -> pure addr
- Nothing -> throwError $ EEUnknownAddressAlias $ SomeAlias alias
+ Nothing -> throwEE $ EEUnknownAddressAlias $ SomeAlias alias
-- | Resolves 'ContractAddressOrAlias' type to an address.
resolveContractAddress
@@ -637,7 +650,7 @@
AddressAlias alias -> resolveAddress (SAOAKindSpecified ct) >>= \case
Constrained result -> case result of
ContractAddress{} -> pure result
- ImplicitAddress{} -> throwError $ EEUnknownAddressAlias (SomeAlias alias)
+ ImplicitAddress{} -> throwEE $ EEUnknownAddressAlias (SomeAlias alias)
-- | Execute a list of global operations, returning a list of generated events.
executeGlobalOperations
@@ -649,7 +662,7 @@
executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM [EmitOperation]
executeMany isGlobalOp = \case
[] -> pure []
- (op:opsTail) -> do
+ (op:opsTail) -> addStackEntry op do
case op of
OriginateOp origination -> do
void $ executeOrigination isGlobalOp origination
@@ -683,7 +696,7 @@
tcOpts <- view eeTcOpts
when (tcStrict tcOpts) $
- liftEither $ first EEDeprecatedType $ checkContractDeprecations ooContract
+ liftEE $ first EEDeprecatedType $ checkContractDeprecations ooContract
opHash <- use esOperationHash
@@ -698,10 +711,10 @@
let originatorAddress = ooOriginator
originatorBalance <- case lookupBalance originatorAddress gs of
- Nothing -> throwError $ EEUnknownManager $ MkAddress ooOriginator
+ Nothing -> throwEE $ EEUnknownManager $ MkAddress ooOriginator
Just oldBalance
| oldBalance < ooBalance ->
- throwError $ EENotEnoughFunds (MkAddress ooOriginator) oldBalance
+ throwEE $ EENotEnoughFunds (MkAddress ooOriginator) oldBalance
| otherwise ->
-- Subtraction is safe because we have checked its
-- precondition in guard.
@@ -720,7 +733,7 @@
]
case applyUpdates updates gs of
- Left err -> throwError $ EEFailedToApplyUpdates err
+ Left err -> throwEE $ EEFailedToApplyUpdates err
Right newGS -> do
esGState .= newGS
esLog <>= ExecutorLog updates []
@@ -745,7 +758,7 @@
let updates = [GSSetDelegate address sdoDelegate]
case applyUpdates updates gs of
- Left err -> throwError $ EEFailedToApplyUpdates err
+ Left err -> throwEE $ EEFailedToApplyUpdates err
Right newGS -> do
esGState .= newGS
esLog <>= ExecutorLog updates []
@@ -758,7 +771,7 @@
-> EmitOperation
-> ExecutorM EmitOperation
executeEmit (arg #isGlobalOp -> isGlobalOp) op = do
- when isGlobalOp $ throwError EEGlobalEmitOp
+ when isGlobalOp $ throwEE EEGlobalEmitOp
checkOperationReplay $ EmitOp op
pure op
@@ -798,8 +811,8 @@
:: forall arg. T.SingI arg
=> ContractAddress
-> TxParam
- -> "typedParamError" :! (Address -> MismatchError T.T -> ExecutorError)
- -> "untypedParamError" :! (Address -> TcError -> ExecutorError)
+ -> "typedParamError" :! (Address -> MismatchError T.T -> ExecutorErrorPrim Address)
+ -> "untypedParamError" :! (Address -> TcError -> ExecutorErrorPrim Address)
-> ExecutorM (T.Value arg, BigMapCounter)
prepareParameter addr tdParameter
(arg #typedParamError -> tyParErr)
@@ -808,7 +821,7 @@
tcOpts <- view eeTcOpts
gs <- use esGState
let existingContracts = extractAllContracts gs
- when (tcStrict tcOpts) $ liftEither $ first EEDeprecatedType $ checkSingDeprecations (sing @arg)
+ when (tcStrict tcOpts) $ liftEE $ first EEDeprecatedType $ checkSingDeprecations (sing @arg)
-- If the parameter has already been typechecked, simply check if
-- its type matches the contract's entrypoint's type.
-- Otherwise (e.g. if it was parsed from stdin via the CLI),
@@ -817,9 +830,9 @@
case tdParameter of
TxTypedParam (typedVal :: T.Value t) ->
T.castM @t @arg typedVal $
- throwError . tyParErr (MkAddress addr)
+ throwEE . tyParErr (MkAddress addr)
TxUntypedParam untypedVal ->
- liftEither $ first (unTyParErr $ MkAddress addr) $
+ liftEE $ first (unTyParErr $ MkAddress addr) $
typeCheckingWith tcOpts $
typeVerifyParameter @arg existingContracts untypedVal
@@ -864,31 +877,31 @@
case isImplicitAddress senderAddr of
Nothing -> do
when (isGlobalOp && not isZeroTransfer) $
- throwError $ EETransactionFromContract (MkAddress senderAddr) tdAmount
+ throwEE $ EETransactionFromContract (MkAddress senderAddr) tdAmount
Just Refl -> do
case senderBalance of
- Nothing -> throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
+ Nothing -> throwEE $ EEEmptyImplicitContract $ MkAddress senderAddr
Just balance | balance == zeroMutez ->
- throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
+ throwEE $ EEEmptyImplicitContract $ MkAddress senderAddr
_ -> pass
case isImplicitAddress addr of
Nothing -> pass
Just Refl -> do
when (badParamToImplicitAccount tdParameter) $
- throwError $ EEWrongParameterType $ MkAddress addr
+ throwEE $ EEWrongParameterType $ MkAddress addr
-- Transferring 0 XTZ to a key address is prohibited.
when (isZeroTransfer && isUnitParam tdParameter) $
- throwError $ EEZeroTransaction $ MkAddress addr
+ throwEE $ EEZeroTransaction $ MkAddress addr
mDecreaseSenderBalance <- case senderBalance of
_ | isZeroTransfer -> pure Nothing
- Nothing -> throwError $ EEUnknownSender $ MkAddress senderAddr
+ Nothing -> throwEE $ EEUnknownSender $ MkAddress senderAddr
Just balance
| balance < tdAmount ->
- throwError $ EENotEnoughFunds (MkAddress senderAddr) balance
+ throwEE $ EENotEnoughFunds (MkAddress senderAddr) balance
| otherwise -> do
-- Subtraction is safe because we have checked its
-- precondition in guard.
@@ -922,7 +935,7 @@
updates = catMaybes [mDecreaseSenderBalance, mDecreaseSenderTickets] <> otherUpdates
<> [GSIncrementCounter]
- newGState <- liftEither $ first EEFailedToApplyUpdates $ applyUpdates updates gs
+ newGState <- liftEE $ first EEFailedToApplyUpdates $ applyUpdates updates gs
esGState .= newGState
esRemainingSteps .= newRemSteps
@@ -941,7 +954,7 @@
case addr of
SmartRollupAddress{} ->
- throwError $ EEUnknownContract (MkAddress addr)
+ throwEE $ EEUnknownContract (MkAddress addr)
ImplicitAddress{} -> case addresses ^. at addr of
Nothing -> onlyUpdates Dict . one $
GSAddImplicitAddress addr tdAmount $ maybeToList sentTickets
@@ -958,7 +971,7 @@
updTickets = uncurry (GSAddTickets addr) <$> sentTickets
onlyUpdates Dict $ catMaybes [updBalance, updTickets]
ContractAddress{} -> case addresses ^. at addr of
- Nothing -> throwError $ EEUnknownContract (MkAddress addr)
+ Nothing -> throwEE $ EEUnknownContract (MkAddress addr)
Just ContractState{..} -> do
let
-- Calculate the contract's new balance.
@@ -970,7 +983,7 @@
T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)
<- T.mkEntrypointCall epName (T.cParamNotes csContract)
- & maybe (throwError $ EEUnknownEntrypoint epName) pure
+ & maybe (throwEE $ EEUnknownEntrypoint epName) pure
(typedParameterWithIds, bigMapCounter1) <- prepareParameter addr tdParameter
! #typedParamError EEUnexpectedParameterType
@@ -1001,7 +1014,7 @@
{ rslResult = extractValOps -> (sideEffects, newValue)
, rslState = InterpreterState newRemainingSteps globalCounter2 bigMapCounter2
})
- <- liftEither $ first (EEInterpreterFailed (MkAddress addr)) $
+ <- liftEE $ first (EEInterpreterFailed (MkAddress addr)) $
handleReturn $
interpret
csContract
@@ -1044,10 +1057,10 @@
callView sender addr viewName viewArg = do
ContractState{..} <-
use (esGState . gsContractAddressesL . at addr)
- >>= maybe (throwError $ EEUnknownContract (MkAddress addr)) pure
+ >>= maybe (throwEE $ EEUnknownContract (MkAddress addr)) pure
T.SomeView (view'@T.View{} :: T.View viewArg st viewRet)
- <- liftEither $ first (EEViewLookupError (Constrained addr)) $ getViewByName csContract viewName
+ <- liftEE $ first (EEViewLookupError (Constrained addr)) $ getViewByName csContract viewName
(typedParameterWithIds, bigMapCounter1) <- prepareParameter addr viewArg
! #typedParamError (\a -> EEViewLookupError a . ViewArgMismatch)
@@ -1064,7 +1077,7 @@
remainingSteps <- use esRemainingSteps
iur@ResultStateLogs{..} <-
- liftEither $ first (EEInterpreterFailed (MkAddress addr)) $
+ liftEE $ first (EEInterpreterFailed (MkAddress addr)) $
handleReturn $ interpretView
view'
csStorage
@@ -1091,7 +1104,7 @@
EmitOp (EmitOperation _ T.Emit{..}) -> emCounter
prevCounters <- use esPrevCounters
when (opCounter `HS.member` prevCounters) $
- throwError $ EEOperationReplay op
+ throwEE $ EEOperationReplay op
esPrevCounters <>= one opCounter
-- The argument is the address of the contract that generated this operation.
@@ -1132,7 +1145,7 @@
}
OpEmit emit -> case interpretedAddr of
ContractAddress{} -> pure $ EmitOp $ EmitOperation interpretedAddr emit
- _ -> throwError $ EEUnknownContract $ MkAddress interpretedAddr
+ _ -> throwEE $ EEUnknownContract $ MkAddress interpretedAddr
-- | Reset source address before executing a global operation.
beginGlobalOperation :: ExecutorM ()
@@ -1149,3 +1162,17 @@
isUnitParam (TxTypedParam T.VUnit) = True
isUnitParam (TxUntypedParam U.ValueUnit) = True
isUnitParam _ = False
+
+getContractStack :: ExecutorM [ExecutorOp]
+getContractStack = reverse <$> view eeCallChain
+
+throwEE :: ExecutorErrorPrim Address -> ExecutorM r
+throwEE err = throwError . flip ExecutorError err =<< getContractStack
+
+liftEE :: Either (ExecutorErrorPrim Address) r -> ExecutorM r
+liftEE x = do
+ stack <- getContractStack
+ liftEither . first (ExecutorError stack) $ x
+
+addStackEntry :: ExecutorOp -> ExecutorM a -> ExecutorM a
+addStackEntry entry = local (eeCallChain %~ coerce (entry :))
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
@@ -121,10 +121,11 @@
hashWithSalt s = hashWithSalt s . toJSON
-- | Convert a typed ticket value to 'TicketKey' and amount.
-toTicketKey :: forall t. T.HasNoOp t => T.Value ('T.TTicket t) -> (TicketKey, Natural)
+toTicketKey :: forall t. T.Value ('T.TTicket t) -> (TicketKey, Natural)
toTicketKey (T.VTicket ticketer value amount) =
(TicketKey (ticketer, T.untypeValue value, T.mkUType $ T.starNotes @t), amount)
\\ T.valueTypeSanity value
+ \\ T.comparableImplies (Proxy @t)
deriveJSON morleyAesonOptions ''ImplicitState
makeLensesWith postfixLFields ''ImplicitState
diff --git a/src/Morley/Michelson/Runtime/TxData.hs b/src/Morley/Michelson/Runtime/TxData.hs
--- a/src/Morley/Michelson/Runtime/TxData.hs
+++ b/src/Morley/Michelson/Runtime/TxData.hs
@@ -13,6 +13,7 @@
) where
import Control.Lens (makeLensesWith)
+import Fmt (Buildable(..))
import Morley.Michelson.Typed (ParameterScope)
import Morley.Michelson.Typed qualified as T
@@ -28,6 +29,11 @@
TxUntypedParam :: U.Value -> TxParam
deriving stock instance Show TxParam
+
+instance Buildable TxParam where
+ build = \case
+ TxTypedParam val -> build val
+ TxUntypedParam val -> build val
-- | Data associated with a particular transaction.
data TxData = TxData
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
@@ -11,19 +11,21 @@
, TcError' (..)
, ExtError (..)
, StackSize (..)
+ , TCOpSeq (..)
, pairWithNodeIndex
, pairWithElems
) where
-import Fmt (Buildable(..), pretty, (+|), (|+))
import Prelude hiding (empty, (<$>))
-import Text.PrettyPrint.Leijen.Text
- (Doc, cat, enclose, indent, line, list, punctuate, textStrict, (<$$>), (<$>), (<+>))
+import Fmt (Buildable(..), Doc, isEmpty, nameF, pretty, (+|), (<$>), (<+>), (), (), (|+))
+import Fmt.Utils qualified as PP
+import Prettyprinter (flatAlt, hardline)
+import Prettyprinter qualified as PP
+import Prettyprinter.Util (reflow)
+
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
@@ -59,8 +61,8 @@
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
-instance RenderDoc TypeContext where
- renderDoc _ = \case
+instance Buildable TypeContext where
+ build = \case
LambdaArgument -> "argument to some lambda"
LambdaCodeCtx -> "code in LAMBDA"
DipCode -> "code in DIP"
@@ -90,16 +92,10 @@
deriving anyclass (NFData)
instance Buildable TopLevelType where
- build = buildRenderDoc
-
-instance RenderDoc TopLevelType where
- renderDoc _ = \case
+ build = \case
TltParameterType -> "parameter"
TltStorageType -> "storage"
-instance Buildable TypeContext where
- build = buildRenderDoc
-
-- | Data type that represents various errors
-- which are related to type system.
-- These errors are used to specify info about type check errors
@@ -124,7 +120,7 @@
| UnexpectedTopLevelType TopLevelType (MismatchError T.T)
-- ^ Error that happens when the caller expected one top-level type, but
-- the contract has another type specified.
- | InvalidInstruction (U.InstrAbstract ()) Text
+ | InvalidInstruction (U.InstrAbstract [] ()) Text
-- ^ Some instruction is invalid or used in an invalid way.
-- For example, @PAIR 0@ or @PAIR 1@, or a @SELF@ instruction was used in a @LAMBDA@.
--
@@ -176,131 +172,136 @@
deriving anyclass (NFData)
instance Buildable TcTypeError where
- build = buildRenderDocExtended
-
-instance RenderDoc TcTypeError where
- renderDoc context = \case
- TypeEqError merr ->
- "Types not equal:" <$> renderDoc context merr
- StackEqError merr ->
- "Stacks not equal:" <$> renderDoc context merr
- UnsupportedTypeForScope typ reason ->
- "Type '" <> (renderDoc context typ) <> "' is unsupported here because it"
- <+> (renderDoc context reason)
+ build = \case
+ TypeEqError merr -> nameF "Types not equal" $ build merr
+ StackEqError merr -> nameF "Stacks not equal" $ build merr
+ UnsupportedTypeForScope typ reason -> PP.group
+ ("Type" <$>
+ let res = build typ in flatAlt (PP.indent 2 res) (PP.squotes res) <> PP.line)
+ reflow "is unsupported here because it" build reason
NotNumericTypes t1 t2 ->
- "Some of the types in an arithmetic operation are not numeric:"
- <+> (renderDoc context t1) <+> "and" <+> (renderDoc context t2)
- UnexpectedType (t :| ts) ->
- "Wrong stack type for instruction, expect stack type to begin with " <+>
- (cat $ punctuate "or"
- $ fmap (\(x :| xs) -> list $ fmap (renderAnyBuildable) (x:xs))
- $ (t:ts)
- )
- UnexpectedTopLevelType tyDesc mmerr ->
- "Unexpected" <+> renderDoc context tyDesc <+> "type."
- <$$> renderDoc doesntNeedParens mmerr
- InvalidInstruction instr reason ->
- "Invalid instruction" <+> (renderDoc context (instr $> ("..." :: Text)))
- <$$> "Reason:" <+> textStrict reason
- InvalidValueType t ->
- "Value type is never a valid" <+> enclose "`" "`" (renderDoc context t)
- NotEnoughItemsOnStack ->
- "Not enough items on stack"
- UnknownContract addr ->
- "Contract is not registered:" <+> (renderAnyBuildable addr)
- IllegalEntrypoint err -> renderDoc context err
- EntrypointNotFound ep ->
- "No such entrypoint" <+> enclose "`" "`" (renderAnyBuildable ep)
- IllegalParamDecl err -> renderDoc context err
+ nameF (reflow "Some of the types in an arithmetic operation are not numeric") $
+ PP.sep
+ [ build t1 <+> "and"
+ , build t2
+ ]
+ UnexpectedType stacks -> "Wrong stack type for instruction."
+ nameF "Expected stack type to begin with"
+ (PP.sep $ PP.punctuate " or" (fmap build $ toList stacks))
+ UnexpectedTopLevelType tyDesc mmerr -> nameF
+ ("Unexpected" <+> build tyDesc <+> "type")
+ (build mmerr)
+ InvalidInstruction instr reason -> PP.vsep
+ [ nameF "Invalid instruction" $ build (instr $> ("..." :: Text))
+ , nameF "Reason" $ build reason
+ ]
+ InvalidValueType t -> nameF "Value type is never a valid" $ build t
+ NotEnoughItemsOnStack -> "Not enough items on stack"
+ UnknownContract addr -> nameF "Contract is not registered" $ build addr
+ IllegalEntrypoint err -> build err
+ EntrypointNotFound ep -> nameF "No such entrypoint" $ build ep
+ IllegalParamDecl err -> build err
NegativeNat -> "Natural number cannot be negative"
MutezOverflow -> "Exceeds maximal value for mutez"
- InvalidAddress e -> renderDoc context e
- InvalidKeyHash e -> renderDoc context e
- InvalidBls12381Object e -> renderDoc context e
+ InvalidAddress e -> build e
+ InvalidKeyHash e -> build e
+ InvalidBls12381Object e -> build e
InvalidTimestamp -> "Is not a valid RFC3339 timestamp"
- CodeAlwaysFails ->
- "Cannot use a terminate instruction (like FAILWITH) in this block"
+ CodeAlwaysFails -> "Cannot use a terminate instruction (like FAILWITH) in this block"
EmptyCode -> "Code block is empty"
AnyError -> "Some of the arguments have invalid types"
- InvalidBigMapId bigMapId ->
- "No big_map with ID" <+> renderAnyBuildable bigMapId <+> "was found."
- UnexpectedBigMapType bigMapId mismatchError ->
- "A big_map with the ID" <+> renderAnyBuildable bigMapId <+> "was found, but it does not have the expected type."
- <$$> renderDoc context mismatchError
+ InvalidBigMapId bigMapId -> PP.nest 2 $
+ reflow "No big_map with ID"
+ build bigMapId
+ reflow "was found."
+ UnexpectedBigMapType bigMapId mismatchError -> PP.nest 2 $ PP.vsep
+ [ reflow "A big_map with the ID"
+ build bigMapId
+ reflow "was found, but it does not have the expected type."
+ , build mismatchError
+ ]
instance Exception TcTypeError where
displayException = pretty
-- | Type check error
data TcError' op
- = TcFailedOnInstr (U.InstrAbstract op) SomeHST ErrorSrcPos (Maybe TypeContext) (Maybe TcTypeError)
- | TcFailedOnValue (U.Value' op) T.T Text ErrorSrcPos (Maybe TcTypeError)
+ = TcFailedOnInstr (U.InstrAbstract [] op) SomeHST ErrorSrcPos (Maybe TypeContext) (Maybe TcTypeError)
+ | TcFailedOnValue (U.Value' [] op) T.T Text ErrorSrcPos (Maybe TcTypeError)
| TcContractError Text (Maybe TcTypeError)
| TcViewError Text U.ViewName (Maybe TcTypeError)
| TcUnreachableCode ErrorSrcPos (NonEmpty op)
| TcExtError SomeHST ErrorSrcPos ExtError
- | TcIncompletelyTyped (TcError' op) (U.Contract' (TypeCheckedOp op))
- | TcIncompletelyTypedView (TcError' op) (U.View' (TypeCheckedOp op))
+ | TcIncompletelyTyped (TcError' op) (U.Contract' (TCOpSeq op))
+ | TcIncompletelyTypedView (TcError' op) (U.View' (TCOpSeq op))
| TcDeprecatedType Text T.T
deriving stock (Show, Eq, Generic)
+-- | Used to smooth out the impedance mismatch between instruction arguments,
+-- which must be sequences, and contract/view code which can be a singular
+-- instruction. Only used for error reporting, as in general this isn't valid.
+newtype TCOpSeq op = TCOpSeq [TypeCheckedOp op]
+ deriving newtype (Show, Eq)
+ deriving stock (Functor, Generic)
+ deriving anyclass NFData
+
+instance RenderDoc op => RenderDoc (TCOpSeq op) where
+ renderDoc _ (TCOpSeq ops) = renderOpsListNoBraces False ops
+
type TcError = TcError' U.ExpandedOp
instance (NFData op, NFData (TypeCheckedOp op)) => NFData (TcError' op)
-instance RenderDoc op => Buildable (TcError' op) where
- build = buildRenderDocExtended
-
-instance RenderDoc op => RenderDoc (TcError' op) where
- renderDoc context = \case
- TcFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTcTypeError -> line
- <> "Error checking expression:"
- <> surroundWithNewLines (renderDoc context instr)
- <> "against input stack type:"
- <> surroundWithNewLines (renderDoc context t)
- <> maybe "" (\c -> "Error in" <+> renderDoc context c) mbTCTypeContext
- <> maybe "" (\e -> ":" <+> (renderDoc context e) <> "." <$$> line) mbTcTypeError
- <> (renderDoc context ics)
- TcFailedOnValue v t custom ics mbTcTypeError ->
- "Error checking value"
- <$$> (renderDoc context v) <+> "against type"
- <+> (renderDoc context t) <> (bool (":" <+> (renderAnyBuildable custom)) "." (null custom))
- <+> (maybe "" (\e -> line <> (renderDoc context e) <> line) mbTcTypeError)
- <+> (renderDoc context ics)
- TcContractError msg typeError ->
- "Error occurred during contract typecheck:"
- <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)
- TcViewError msg viewName typeError ->
- "Error occurred during typecheck of view " <> renderDoc context viewName <> ":"
- <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)
- TcUnreachableCode ics instrs ->
- "Unreachable code:" <$$> buildTruncated 3 (toList instrs) <> "."
- <+> (renderDoc context ics)
- TcExtError (SomeHST t) ics e ->
- "Error occurred during Morley extension typecheck:" <>
- (renderAnyBuildable e) <+> "on stack" <+> (renderDoc context t) <> "."
- <+> (renderDoc context ics)
+instance (RenderDoc op, Buildable op) => Buildable (TcError' op) where
+ build = \case
+ TcFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTcTypeError -> PP.vsep
+ [ PP.nest 2 $ "Error checking expression:"
+ <$> surroundWithNewLines (build instr)
+ , PP.nest 2 $ "against input stack type:"
+ <$> surroundWithNewLines (build t)
+ , nameF
+ (maybe mempty (("Error in" <+>) . build) mbTCTypeContext)
+ (build mbTcTypeError)
+ , build ics
+ ]
+ TcFailedOnValue v t custom ics mbTcTypeError -> PP.nest 2 $ PP.vsep $ filter (not . isEmpty)
+ [ nameF "Error checking value" $ build v
+ , nameF "Against type" $ build t
+ , build custom
+ , build mbTcTypeError
+ , build ics
+ ]
+ TcContractError msg typeError -> nameF "Error occurred during contract typecheck" $
+ build msg <$> build typeError
+ TcViewError msg viewName typeError -> nameF
+ ("Error occurred during typecheck of view " <> build viewName) $
+ build msg <$> build typeError
+ TcUnreachableCode ics instrs -> nameF "Unreachable code" $
+ buildTruncated 3 (toList instrs) <> hardline <> build ics
+ TcExtError (SomeHST t) ics e -> nameF
+ "Error occurred during Morley extension typecheck" $ PP.vsep
+ [ build e
+ , "on stack"
+ , build t
+ , build ics
+ ]
TcIncompletelyTyped err contract ->
- line
- <> renderDoc doesntNeedParens contract
- <$> renderDoc context err
- TcIncompletelyTypedView err _view ->
- line
- <> renderDoc context err
+ renderDoc doesntNeedParens contract <> PP.linebreak
+ <$> build err
+ TcIncompletelyTypedView err _view -> build err
TcDeprecatedType err ty ->
- "Found deprecated type:" <+> renderDoc doesntNeedParens ty <$> renderDoc doesntNeedParens err
+ nameF "Found deprecated type" (renderDoc doesntNeedParens ty)
+ <$> renderDoc doesntNeedParens err
where
- buildTruncated k l
- | null (drop k l) = renderDocList context l
- | otherwise = (renderDocList context (take k l)) <> " ..."
+ buildTruncated k =
+ PP.align . renderOpsListNoBraces False . trunc . fmap (renderDoc doesntNeedParens)
+ where
+ trunc (splitAt k -> (h, t))
+ | null t = h
+ | otherwise = h <> ["..."]
- -- Helper to format a line using empty lines at the end and at the beginning,
- -- and 4-space indents for the line itself
- surroundWithNewLines :: Doc -> Doc
- surroundWithNewLines l =
- line
- <$$> indent 4 l
- <$$> line
+ surroundWithNewLines :: Doc -> Doc
+ surroundWithNewLines = PP.enclose PP.linebreak PP.linebreak
instance Exception TcError where
displayException = pretty
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
@@ -30,7 +30,7 @@
-- @SomeTcInstr@, wrap it in a @WellTypedSeq@.
workOnInstr
:: IsInstrOp op
- => U.ExtInstrAbstract op
+ => U.ExtInstrAbstract [] op
-> TypeCheckInstr op (SomeTcInstr s)
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op s)
workOnInstr ext = tcEither
@@ -41,7 +41,7 @@
:: forall s op.
(SingI s, IsInstrOp op)
=> TcInstrBase op
- -> U.ExtInstrAbstract op
+ -> U.ExtInstrAbstract [] op
-> HST s
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op s)
typeCheckExt tcOp ext hst = do
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
@@ -57,7 +57,7 @@
import Morley.Michelson.TypeCheck.Types
import Morley.Michelson.Typed
(BadTypeForScope(..), CommentType(StackTypeComment), Comparable, Contract, Contract'(..),
- ExtInstr(COMMENT_ITEM), Instr(..), SingT(..), T(..), WellTyped, getComparableProofS, requireEq)
+ ExtInstr(COMMENT_ITEM), Instr(..), SingT(..), T(..), WellTyped, comparabilityPresence, requireEq)
import Morley.Michelson.Typed.Annotation
import Morley.Michelson.Typed.Arith (Add, ArithOp(..), EDiv, Mul, Sub, UnaryArithOp(..))
import Morley.Michelson.Typed.Polymorphic
@@ -125,7 +125,7 @@
onTypeCheckInstrErr
:: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
- => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
+ => Un.InstrAbstract [] op -> SomeHST -> Maybe TypeContext
-> Either TcTypeError a -> m a
onTypeCheckInstrErr instr hst mContext ei = do
either (typeCheckInstrErr' instr hst mContext) return ei
@@ -133,7 +133,7 @@
onScopeCheckInstrErr
:: forall (t :: T) op m a.
(MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m, SingI t)
- => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
+ => Un.InstrAbstract [] op -> SomeHST -> Maybe TypeContext
-> Either BadTypeForScope a -> m a
onScopeCheckInstrErr instr hst mContext = \case
Right a -> return a
@@ -144,7 +144,7 @@
typeCheckInstrErr
:: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
- => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
+ => Un.InstrAbstract [] op -> SomeHST -> Maybe TypeContext
-> m a
typeCheckInstrErr instr hst mContext = do
pos <- view tcieErrorPos
@@ -152,7 +152,7 @@
typeCheckInstrErr'
:: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
- => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
+ => Un.InstrAbstract [] op -> SomeHST -> Maybe TypeContext
-> TcTypeError -> m a
typeCheckInstrErr' instr hst mContext err = do
pos <- view tcieErrorPos
@@ -161,11 +161,11 @@
withCompareableCheck
:: forall a m v ts op. (SingI ts, MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
=> Sing a
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> HST ts
-> (Comparable a => v)
-> m v
-withCompareableCheck sng instr i act = case getComparableProofS sng of
+withCompareableCheck sng instr i act = case comparabilityPresence sng of
Just d@Dict -> pure $ withDict d act
Nothing -> typeCheckInstrErr instr (SomeHST i) $ Just ComparisonArguments
@@ -193,7 +193,7 @@
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
continueTypeChecking tcOp done rest = case done of
WellTypedSeq instr -> handleFirst instr
- MixedSeq i e left -> pure (MixedSeq i e (left <> map NonTypedInstr rest))
+ MixedSeq n i e left -> pure (MixedSeq n i e (left <> map NonTypedInstr rest))
IllTypedSeq e left -> pure (IllTypedSeq e (left <> map NonTypedInstr rest))
where
handleFirst :: SomeTcInstr inp -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
@@ -204,11 +204,11 @@
let combiner = combine inputStack instr
pure case nextPiece of
WellTypedSeq nextInstr -> WellTypedSeq (combiner nextInstr)
- MixedSeq nextInstr err left -> MixedSeq (combiner nextInstr) err left
- IllTypedSeq err left -> MixedSeq packedInstr err left
+ MixedSeq n nextInstr err left -> MixedSeq n (combiner nextInstr) err left
+ IllTypedSeq err left -> MixedSeq 0 packedInstr err left
AnyOutInstr{} -> pure case rest of
[] -> WellTypedSeq packedInstr
- op : ops -> (MixedSeq
+ op : ops -> (MixedSeq 0
packedInstr
(TcUnreachableCode (extractOpPos op) (op :| ops))
(map NonTypedInstr ops))
@@ -285,7 +285,7 @@
-> f (TypeCheckedSeq op inp')
mapMSeq f v = case v of
WellTypedSeq instr -> f instr <&> WellTypedSeq
- MixedSeq instr err tail' -> f instr <&> \instr' -> MixedSeq instr' err tail'
+ MixedSeq n instr err tail' -> f instr <&> \instr' -> MixedSeq n instr' err tail'
IllTypedSeq err tail' -> pure $ IllTypedSeq err tail'
mapSeq
@@ -454,7 +454,7 @@
=> (Anns '[VarAnn] -> Instr inp (ArithRes aop n m ': s))
-> HST inp
-> VarAnn
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> t (SomeTcInstr inp)
arithImpl mkInstr i@(_ ::& _ ::& rs) vn _ =
pure $ i :/ mkInstr (Anns1 vn) ::: ((sing, Dict) ::& rs)
@@ -470,7 +470,7 @@
=> Sing a -> Sing b
-> HST inp
-> VarAnn
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> m (SomeTcInstr inp)
addImpl t1 t2 = case (t1, t2) of
(STInt, STInt) -> arithImpl @Add AnnADD
@@ -497,7 +497,7 @@
=> Sing a -> Sing b
-> HST inp
-> VarAnn
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> m (SomeTcInstr inp)
edivImpl t1 t2 = case (t1, t2) of
(STInt, STInt) -> edivImplDo
@@ -519,7 +519,7 @@
)
=> HST inp
-> VarAnn
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> t (SomeTcInstr inp)
edivImplDo i@(_ ::& _ ::& rs) vn _ =
pure $ i :/ AnnEDIV (Anns1 vn) ::: ((sing, Dict) ::& rs)
@@ -535,7 +535,7 @@
=> Sing a -> Sing b
-> HST inp
-> VarAnn
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> m (SomeTcInstr inp)
subImpl t1 t2 = case (t1, t2) of
(STInt, STInt) -> arithImpl @Sub AnnSUB
@@ -560,7 +560,7 @@
=> Sing a -> Sing b
-> HST inp
-> VarAnn
- -> Un.InstrAbstract op
+ -> Un.InstrAbstract [] op
-> m (SomeTcInstr inp)
mulImpl t1 t2 = case (t1, t2) of
(STInt, STInt) -> arithImpl @Mul AnnMUL
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
@@ -100,7 +100,7 @@
typeCheckContractAndStorage'
:: IsInstrOp op
- => TcInstrBase op -> U.Contract' op -> U.Value' op -> TypeCheckResult op SomeContractAndStorage
+ => TcInstrBase op -> U.Contract' op -> U.Value' [] op -> TypeCheckResult op SomeContractAndStorage
typeCheckContractAndStorage' tcOp uContract uStorage = do
SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract' tcOp uContract
storage <- typeVerifyStorage' @st tcOp uStorage
@@ -112,8 +112,7 @@
typeCheckContract = typeCheckContract' typeCheckExpandedOp
typeCheckContract'
- :: IsInstrOp op
- => TcInstrBase op
+ :: TcInstrBase op
-> U.Contract' op
-> TypeCheckResult op SomeContract
typeCheckContract' tcOp c = do
@@ -129,7 +128,7 @@
typeVerifyContract'
:: forall cp st op.
- (SingI cp, SingI st, IsInstrOp op)
+ (SingI cp, SingI st)
=> TcInstrBase op -> U.Contract' op -> TypeCheckResult op (Contract cp st)
typeVerifyContract' tcOp uContract = do
SomeContract tContract@(Contract{} :: Contract cp' st') <-
@@ -148,7 +147,7 @@
Right Dict -> fn
Left err -> throwError $ TcContractError (pretty err) Nothing
-withWTPInstr_ :: forall t op a. SingI t => U.InstrAbstract op -> SomeHST -> (WellTyped t => TypeCheckInstr op a) -> TypeCheckInstr op a
+withWTPInstr_ :: forall t op a. SingI t => U.InstrAbstract [] op -> SomeHST -> (WellTyped t => TypeCheckInstr op a) -> TypeCheckInstr op a
withWTPInstr_ v t fn = case getWTP @t of
Right Dict -> fn
Left (NotWellTyped badType cause) -> do
@@ -157,7 +156,7 @@
withWTPInstr'_
:: forall t op inp. (SingI t, IsInstrOp op)
- => U.InstrAbstract op
+ => U.InstrAbstract [] op
-> SomeHST
-> (WellTyped t => TypeCheckInstrNoExcept op (TypeCheckedSeq op inp))
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
@@ -170,13 +169,10 @@
pure $ IllTypedSeq err [NonTypedInstr $ liftInstr v]
doTypeCheckContract'
- :: forall op. IsInstrOp op
- => TcInstrBase op
+ :: forall op. TcInstrBase op
-> U.Contract' op
-> TypeCheck op SomeContract
doTypeCheckContract' tcOp uContract@(U.Contract wholeParam@(U.ParameterType mParam rootAnn) mStorage pCode entriesOrder uViews) = do
- _ <- maybe (throwError $ TcContractError "no instructions in contract code" $ Just EmptyCode)
- pure (nonEmpty pCode)
withUType mParam $ \(paramNote :: Notes param) ->
withUType mStorage $ \(storageNote :: Notes st) -> do
withWTP @st $ do
@@ -191,20 +187,18 @@
codeRes <-
usingReaderT def $
liftNoExcept $
- typeCheckImpl
- (giveNotInView $ local (set tcieNotInView $ Just Dict) ... tcOp)
- pCode
- inp
+ giveNotInView $ local (set tcieNotInView $ Just Dict) $
+ tcOp pCode inp
instr@(_ :/ instrOut) <-
tcsEither onFailedCodeTypeCheck pure codeRes
-- typecheck views
cViews <- typeCheckViews' tcOp
- uContract{ U.contractCode = [someInstrToOp instr], U.contractViews = def }
+ uContract{ U.contractCode = someInstrToOp instr, U.contractViews = def }
storageNote uViews
let tcViews = coerce $ someViewToOp @_ @op <$> coerce @_ @(ViewsSetF (SomeView st)) cViews
- handleError (onFailedFullTypeCheck [someInstrToOp instr] tcViews) $ do
+ handleError (onFailedFullTypeCheck (someInstrToOp instr) tcViews) $ do
-- match contract code with contract signature, construct contract
let cStoreNotes = storageNote
cParamNotes <-
@@ -235,22 +229,22 @@
then TcIncompletelyTyped err U.Contract
{ contractParameter = wholeParam
, contractStorage = mStorage
- , contractCode = ops
+ , contractCode = TCOpSeq ops
, entriesOrder = entriesOrder
, contractViews = def
}
else err
- onFailedFullTypeCheck :: [TypeCheckedOp op] -> U.ViewsSet (TypeCheckedOp op) -> TcError' op -> TypeCheck op a
+ onFailedFullTypeCheck :: TypeCheckedOp op -> U.ViewsSet (TypeCheckedOp op) -> TcError' op -> TypeCheck op a
onFailedFullTypeCheck ops views err = do
verbose <- asks' tcVerbose
throwError if verbose
then TcIncompletelyTyped err U.Contract
{ contractParameter = wholeParam
, contractStorage = mStorage
- , contractCode = ops
+ , contractCode = TCOpSeq [ops]
, entriesOrder = entriesOrder
- , contractViews = views
+ , contractViews = TCOpSeq . one <$> views
}
else err
@@ -262,7 +256,7 @@
typeVerifyView'
:: forall arg ret st op.
- (SingI arg, SingI ret, WellTyped st, IsInstrOp op)
+ (SingI arg, SingI ret, WellTyped st)
=> TcInstrBase op -> Notes st -> U.View' op -> TypeCheckResult op (View arg st ret)
typeVerifyView' tcOp notes v = do
SomeView (tcView@View{} :: View arg' st' ret') <-
@@ -278,7 +272,7 @@
UnexpectedTopLevelType tyDesc merr
typeCheckView'
- :: (WellTyped st, IsInstrOp op)
+ :: WellTyped st
=> TcInstrBase op
-> Notes st
-> U.View' op
@@ -301,7 +295,7 @@
codeRes <-
usingReaderT def $
liftNoExcept $
- typeCheckImpl tcOp uInstr inp
+ tcOp uInstr inp
_ :/ instrOut <-
tcsEither (onFailedViewsTypeCheck uView) pure codeRes
@@ -322,7 +316,7 @@
onFailedViewsTypeCheck v viewOps err = do
verbose <- asks' tcVerbose
throwError if verbose
- then TcIncompletelyTypedView err v{ U.viewCode = viewOps }
+ then TcIncompletelyTypedView err v{ U.viewCode = TCOpSeq viewOps }
else err
hasTypeError :: forall (t :: T) a op. SingI t => Text -> BadTypeForScope -> TypeCheck op a
@@ -332,7 +326,7 @@
typeCheckViews'
:: forall st op.
- (WellTyped st, IsInstrOp op)
+ WellTyped st
=> TcInstrBase op
-> U.Contract' (TypeCheckedOp op)
-> Notes st
@@ -343,7 +337,7 @@
typeCheckView' doTypeCheckOp storageNote uView
`catchError` \case
TcIncompletelyTypedView err view' ->
- let tcViews = someViewToOp <$> processedViews
+ let tcViews = fmap (TCOpSeq . one) . someViewToOp <$> processedViews
in onFailedViewsTypeCheck (coerce $ unsafeInsert name view' tcViews) err
err -> throwError err
where
@@ -352,11 +346,11 @@
unsafeInsert :: ViewName -> a -> ViewsSetF a -> ViewsSetF a
unsafeInsert = unsafe ... VS.addViewToSet . const
- onFailedViewsTypeCheck :: U.ViewsSet (TypeCheckedOp op) -> TcError' op -> TypeCheck op a
+ onFailedViewsTypeCheck :: U.ViewsSet (TCOpSeq op) -> TcError' op -> TypeCheck op a
onFailedViewsTypeCheck processedViews err = do
verbose <- asks' tcVerbose
throwError if verbose
- then TcIncompletelyTyped err tcContract
+ then TcIncompletelyTyped err (TCOpSeq . one <$> tcContract)
{ U.contractViews = processedViews
}
else err
@@ -445,7 +439,7 @@
typeVerifyStorage'
:: (SingI t, IsInstrOp op)
- => TcInstrBase op -> U.Value' op -> TypeCheckResult op (Value t)
+ => TcInstrBase op -> U.Value' [] op -> TypeCheckResult op (Value t)
typeVerifyStorage' tcOp = typeVerifyTopLevelType' tcOp Nothing
typeVerifyTopLevelType
@@ -455,7 +449,7 @@
typeVerifyTopLevelType'
:: forall t op. (SingI t, IsInstrOp op)
- => TcInstrBase op -> Maybe TcOriginatedContracts -> U.Value' op -> TypeCheckResult op (Value t)
+ => TcInstrBase op -> Maybe TcOriginatedContracts -> U.Value' [] op -> TypeCheckResult op (Value t)
typeVerifyTopLevelType' tcOp mOriginatedContracts valueU =
runTypeCheck (TypeCheckValue (valueU, demote @t) Nothing) $ usingReaderT def $
typeCheckValImpl mOriginatedContracts tcOp valueU
@@ -479,7 +473,7 @@
typeCheckTopLevelType'
:: IsInstrOp op
- => TcInstrBase op -> Maybe TcOriginatedContracts -> U.Ty -> U.Value' op -> TypeCheckResult op SomeValue
+ => TcInstrBase op -> Maybe TcOriginatedContracts -> U.Ty -> U.Value' [] op -> TypeCheckResult op SomeValue
typeCheckTopLevelType' tcOp mOriginatedContracts (AsUType (_ :: Notes t)) valueU =
SomeValue <$> typeVerifyTopLevelType' @t tcOp mOriginatedContracts valueU
@@ -555,7 +549,7 @@
-- non-throwing one, embedding possible errors into the type checking tree.
workOnInstr
:: IsInstrOp op
- => U.InstrAbstract op
+ => U.InstrAbstract [] op
-> TypeCheckInstr op (SomeTcInstr s)
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op s)
workOnInstr instr = tcEither
@@ -579,7 +573,7 @@
-- 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
-- error.
-typeCheckInstr :: forall op. IsInstrOp op => TcInstrBase op -> TcInstr op (U.InstrAbstract op)
+typeCheckInstr :: forall op. IsInstrOp op => TcInstrBase op -> TcInstr op (U.InstrAbstract [] op)
typeCheckInstr tcOp uInstr inp = case (uInstr, inp) of
(U.EXT ext, si) ->
typeCheckExt tcOp ext si
@@ -1144,7 +1138,7 @@
(U.DIP is, a ::& s) -> do
typeCheckDipBody tcOp U.DIP uInstr is s
- (IllTypedSeq)
+ IllTypedSeq
(\subI t -> WellTypedSeq $ inp :/ DIP subI ::: (a ::& t))
(U.DIP _is, SNil) -> notEnoughItemsOnStack
@@ -1552,8 +1546,11 @@
(STOption STKeyHash, _)
::& (STMutez{}, _)
::& (_ :: SingT g, Dict) ::& rs) -> workOnInstr uInstr $ withNotInView uInstr do
- (SomeContract contr@(Contract _ _ (_ :: Notes st) _ _))
- <- lift $ doTypeCheckContract' tcOp contract
+ paramType <- liftEither $ first (TcContractError "illegal parameter declaration: " . Just ) $
+ mkSomeParamType $ U.contractParameter contract
+ SomeContract contr@(Contract _ _ (_ :: Notes st) _ _) <- lift $
+ local (tcModeL .~ TypeCheckContract paramType) $
+ doTypeCheckContract' tcOp contract
Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage) $
eqType @g @st
pure
@@ -1789,7 +1786,7 @@
notEnoughItemsOnStack' :: TypeCheckInstr op a
notEnoughItemsOnStack' = failWithErr' NotEnoughItemsOnStack
- withNotInView :: U.InstrAbstract op -> (IsNotInView => TypeCheckInstr op r) -> TypeCheckInstr op r
+ withNotInView :: U.InstrAbstract [] op -> (IsNotInView => TypeCheckInstr op r) -> TypeCheckInstr op r
withNotInView instr act = asks' (tcMode @op) >>= \case
-- we provide the not-in-view constraint in the isolated mode
TypeCheckTest -> giveNotInView act
@@ -1809,7 +1806,7 @@
Instr bfi s' ->
Instr (cond ': rs) s'
)
- -> (forall op1. [op1] -> [op1] -> U.InstrAbstract op1)
+ -> (forall op1. [op1] -> [op1] -> U.InstrAbstract [] op1)
-> [op]
-> [op]
-> HST bti
@@ -1817,7 +1814,7 @@
-> HST (cond ': rs)
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op (cond ': rs))
genericIf tcOp cons mCons mbt mbf bti bfi i@(_ ::& _) = do
- let cons1 opsT = mCons opsT (map (IllTypedOp . NonTypedInstr) mbf)
+ let cons1 opsT = mCons opsT (one $ IllTypedOp $ map NonTypedInstr mbf)
preserving' (tcList tcOp mbt bti) cons1 $ \tInstr@(_ :/ pinstr) -> do
let cons2 opsF = mCons [someInstrToOp tInstr] opsF
preserving (tcList tcOp mbf bfi) cons2 $ \(_ :/ qinstr) -> do
@@ -1845,7 +1842,7 @@
-> ([TypeCheckedOp op] -> TypeCheckedInstr op)
-> SingT (MapOpInp c)
-> VarAnn
- -> U.InstrAbstract op
+ -> U.InstrAbstract [] op
-> [op]
-> HST (c ': rs)
-> (forall v'. (SingI v') =>
@@ -1873,7 +1870,7 @@
)
=> TcInstrBase op
-> SingT (IterOpEl c)
- -> U.InstrAbstract op
+ -> U.InstrAbstract [] op
-> [op]
-> HST (c ': rs)
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op (c ': rs))
@@ -1895,7 +1892,7 @@
-> SingT ot
-> ([TypeCheckedOp op] -> TypeCheckedInstr op)
-> Anns '[VarAnn, Notes it, Notes ot]
- -> U.InstrAbstract op
+ -> U.InstrAbstract [] op
-> HST ts
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op ts)
@@ -1951,11 +1948,11 @@
AnyOutInstr lam ->
pure (tyCon anns (RfAlwaysFails lam) ::: lamSt ons)
where
- hasSelf :: op -> First (U.InstrAbstract op)
+ hasSelf :: op -> First (U.InstrAbstract [] op)
hasSelf = everything (<>)
(mkQ (First Nothing)
(\case
- selfInstr@(U.SELF{} :: U.InstrAbstract op) -> First $ Just selfInstr
+ selfInstr@(U.SELF{} :: U.InstrAbstract [] op) -> First $ Just selfInstr
_ -> First Nothing
)
)
@@ -1980,8 +1977,10 @@
typeCheckSeqWithLoc loc op = fmap (wrapWithLoc loc) . local (set tcieErrorPos loc) . typeCheckSeq op
typeCheckSeq :: TcInstr U.ExpandedOp [U.ExpandedOp]
- typeCheckSeq sq hst = typeCheckImpl typeCheckExpandedOp sq hst
- <&> mapSeq (mapSomeInstr Nested)
+ typeCheckSeq sq hst = typeCheckImpl typeCheckExpandedOp sq hst <&> \case
+ WellTypedSeq instr -> WellTypedSeq $ mapSomeInstr Nested instr
+ MixedSeq nest instr err rest -> MixedSeq (succ nest) instr err rest
+ IllTypedSeq err op -> IllTypedSeq err [IllTypedNest op]
----------------------------------------------------------------------------
-- Helpers for DIP (n) typechecking
@@ -1999,7 +1998,7 @@
:: (SingI inp, IsInstrOp op)
=> TcInstrBase op
-> ([TypeCheckedOp op] -> TypeCheckedInstr op)
- -> U.InstrAbstract op
+ -> U.InstrAbstract [] op
-> [op]
-> HST inp
-> (TcError' op -> [IllTypedInstr op] -> r)
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
@@ -121,7 +121,7 @@
data TypeCheckMode op
= TypeCheckValue
-- ^ We're typechecking a value.
- (U.Value' op, T.T)
+ (U.Value' [] op, T.T)
(Maybe BigMapFinder)
-- ^ When this is a `Just`, we simulate the typechecking behavior of the RPC's @/run_code@ endpoint.
--
@@ -220,7 +220,7 @@
-- | Lift a single instruction to operation.
--
-- This is used only in error messages.
- liftInstr :: U.InstrAbstract op -> op
+ liftInstr :: U.InstrAbstract [] op -> op
-- | Get callstack at this instruction, if any given.
--
@@ -235,14 +235,14 @@
-- two forms.
--
-- TODO [#785]: try to remove these two functions
- tryOpToVal :: op -> Maybe (U.Value' op)
+ tryOpToVal :: op -> Maybe (U.Value' [] op)
-- | Do our best to re-interpret a value as an instruction.
--
-- This does the opposite to 'tryOpToVal'.
--
-- If a value is already a lambda, this can return 'Nothing'.
- tryValToOp :: U.Value' op -> Maybe op
+ tryValToOp :: U.Value' [] op -> Maybe op
instance IsInstrOp U.ExpandedOp where
liftInstr = U.PrimEx
@@ -299,7 +299,7 @@
-- untyped instruction.
guarding
:: IsInstrOp op
- => U.InstrAbstract op -- ^ Untyped instruction
+ => U.InstrAbstract [] op -- ^ Untyped instruction
-> TypeCheckInstr op a -- ^ Acquiring computation
-> (a -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)) -- ^ Follow-up action
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
@@ -312,7 +312,7 @@
-- action.
guarding_
:: IsInstrOp op
- => U.InstrAbstract op
+ => U.InstrAbstract [] op
-> TypeCheckInstr op a
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
-> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
diff --git a/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs b/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs
--- a/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs
+++ b/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs
@@ -7,13 +7,19 @@
( TypeCheckedInstr
, TypeCheckedOp(..)
, IllTypedInstr(..)
+ , Nesting
+ , SomeSingInstr(..)
, someInstrToOp
, someViewToOp
+ , withSomeTcInstr
) where
import Data.Singletons (SingI)
+import Fmt (Doc)
+import Prettyprinter (enclose)
-import Morley.Michelson.Printer.Util (RenderDoc(..), renderOpsListNoBraces)
+import Morley.Michelson.Printer.Util
+ (RenderDoc(..), doesntNeedParens, renderOpsList, renderOpsListNoBraces)
import Morley.Michelson.TypeCheck.Types (HST(..), SomeTcInstr(..), SomeTcInstrOut(..))
import Morley.Michelson.Typed.Aliases
import Morley.Michelson.Typed.Annotation
@@ -22,58 +28,98 @@
import Morley.Michelson.Typed.View (SomeView'(..), View'(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Michelson.Untyped.Instr (InstrAbstract(..))
-import Morley.Util.TH (deriveGADTNFData)
-- | Represents a root of a partially typed operation tree.
-type TypeCheckedInstr op = InstrAbstract (TypeCheckedOp op)
+type TypeCheckedInstr op = InstrAbstract [] (TypeCheckedOp op)
+newtype Nesting = Nesting Word
+ deriving newtype (Eq, Ord, Enum, Bounded, Num, NFData)
+ deriving stock Show
+
+data SomeSingInstr where
+ SomeSingInstr :: (SingI inp, SingI out) => Instr inp out -> SomeSingInstr
+
+deriving stock instance Show SomeSingInstr
+
+instance Eq SomeSingInstr where
+ SomeSingInstr i1 == SomeSingInstr i2 = castInstr i1 == Just i2
+
+instance NFData SomeSingInstr where
+ rnf (SomeSingInstr x) = rnf x
+
-- | Represents nodes of a partially typed operation tree.
data TypeCheckedOp op where
-- | Constructs well-typed node.
- WellTypedOp :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp op
+ WellTypedOp :: SomeSingInstr -> TypeCheckedOp op
-- | Constructs ill-typed node which might in turn contain well-typed and
-- non-typed operations.
- IllTypedOp :: IllTypedInstr op -> TypeCheckedOp op
-
-deriving stock instance Show op => Show (TypeCheckedOp op)
-deriving stock instance Functor TypeCheckedOp
-
-instance Eq op => Eq (TypeCheckedOp op) where
- WellTypedOp i1 == WellTypedOp i2 = castInstr i1 == Just i2
- IllTypedOp i1 == IllTypedOp i2 = i1 == i2
- _ == _ = False
+ IllTypedOp :: [IllTypedInstr op] -> TypeCheckedOp op
+ -- | Partially typed sequence of operations. Used exclusively for error-reporting.
+ -- 'Nesting' argument exists because we can't mix typed and untyped
+ -- instructions, so we need a way to represent brace nesting of @{ ; }@
+ MixedOp :: Nesting -> SomeSingInstr -> [IllTypedInstr op] -> TypeCheckedOp op
+ deriving stock (Eq, Functor, Show)
-- | Represents a non-well-typed operation
data IllTypedInstr op
- = SemiTypedInstr (TypeCheckedInstr op) -- ^ Constructs a partialy typed operation.
+ = SemiTypedInstr (TypeCheckedInstr op) -- ^ Constructs a partially typed operation.
| NonTypedInstr op -- ^ Constructs a completely untyped operation.
+ | IllTypedNest [IllTypedInstr op] -- ^ Nested sequence of ill-typed operations.
deriving stock (Show, Eq, Generic, Functor)
+instance RenderDoc op => RenderDoc (IllTypedInstr op) where
+ renderDoc pn = \case
+ SemiTypedInstr instr -> renderDoc pn instr
+ NonTypedInstr op -> renderDoc pn op
+ IllTypedNest ops -> renderOpsList False ops
+
deriving anyclass instance (NFData (TypeCheckedOp op), NFData op) => NFData (IllTypedInstr op)
instance RenderDoc op => RenderDoc (TypeCheckedOp op) where
- renderDoc _ (WellTypedOp instr) = renderOpsListNoBraces False (instrToOps instr)
- renderDoc pn (IllTypedOp (SemiTypedInstr instr)) = renderDoc pn instr
- renderDoc pn (IllTypedOp (NonTypedInstr op)) = renderDoc pn op
+ renderDoc _ (WellTypedOp (SomeSingInstr instr)) = renderOpsListNoBraces False (instrToOps instr)
+ renderDoc _ (MixedOp nesting (SomeSingInstr instr) rest) =
+ nestBraces nesting $ renderOpsListNoBraces False $ doRender (instrToOps instr) <> doRender rest
+ where
+ doRender :: RenderDoc a => [a] -> [Doc]
+ doRender = fmap (renderDoc doesntNeedParens) . filter isRenderable
+ renderDoc _ (IllTypedOp ops) = renderOpsListNoBraces False ops
+nestBraces :: Nesting -> Doc -> Doc
+nestBraces 0 = id
+nestBraces n = enclose "{ " " }" . nestBraces (pred n)
+
-- | Makes a well-typed node out of `SomeTcInstr`
someInstrToOp :: SomeTcInstr inp -> TypeCheckedOp op
-someInstrToOp (hst :/ rest) = case hst of
+someInstrToOp hst = withSomeTcInstr hst $ WellTypedOp . SomeSingInstr
+
+-- | Extracts 'Instr' from 'SomeTcInstr' and passes it to a continuation.
+withSomeTcInstr
+ :: SomeTcInstr inp
+ -> (forall out. (SingI inp, SingI out) => Instr inp out -> r)
+ -> r
+withSomeTcInstr (hst :/ rest) = case hst of
SNil -> go rest
(::&){} -> go rest
where
- go :: SingI inp => SomeTcInstrOut inp -> TypeCheckedOp op
- go (i ::: _) = WellTypedOp i
- go (AnyOutInstr i) = WellTypedOp (i @'[])
+ go :: SingI inp => SomeTcInstrOut inp
+ -> (forall out. (SingI inp, SingI out) => Instr inp out -> r)
+ -> r
+ go (i ::: _) cont = cont i
+ go (AnyOutInstr i) cont = cont (i @'[])
-- | Makes takes a typed view and converts it into an untyped one with
-- typechecked code.
someViewToOp :: SomeView st -> U.View' (TypeCheckedOp op)
someViewToOp (SomeView View{..}) = U.View
- { U.viewCode = [WellTypedOp vCode]
+ { U.viewCode = WellTypedOp $ SomeSingInstr vCode
, U.viewName = vName
, U.viewArgument = mkUType vArgument
, U.viewReturn = mkUType vReturn
}
-$(deriveGADTNFData ''TypeCheckedOp)
+instance NFData op => NFData (TypeCheckedOp op) where
+ rnf = \case
+ WellTypedOp x -> rnf x
+ IllTypedOp x -> rnf x
+ MixedOp x y z -> rnf x `seq` rnf y `seq` rnf z
diff --git a/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs b/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs
--- a/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs
+++ b/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs
@@ -12,6 +12,7 @@
, TypeCheckedOp(..)
, IllTypedInstr(..)
, TypeCheckedSeq(..)
+ , Nesting
, tcsEither
, seqToOps
, someInstrToOp
@@ -20,7 +21,6 @@
import Morley.Michelson.TypeCheck.Error (TcError')
import Morley.Michelson.TypeCheck.TypeCheckedOp
- (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), someInstrToOp, someViewToOp)
import Morley.Michelson.TypeCheck.Types (SomeTcInstr(..))
-- | Represents a partiall typed sequence of instructions.
@@ -28,15 +28,18 @@
-- | A fully well-typed sequence.
= WellTypedSeq (SomeTcInstr inp)
-- | A well-typed prefix followed by some error and semi-typed instructions.
- | MixedSeq (SomeTcInstr inp) (TcError' op) [IllTypedInstr op]
+ -- 'Nesting' argument exists because we can't mix typed and untyped
+ -- instructions, so we need a way to represent brace nesting of @{ ; }@
+ | MixedSeq Nesting (SomeTcInstr inp) (TcError' op) [IllTypedInstr op]
-- | There is no well-typed prefix, only an error and semi-typed instructions.
| IllTypedSeq (TcError' op) [IllTypedInstr op]
seqToOps :: TypeCheckedSeq op inp -> [TypeCheckedOp op]
seqToOps = \case
WellTypedSeq instr -> [someInstrToOp instr]
- MixedSeq instr _ tail' -> someInstrToOp instr : map IllTypedOp tail'
- IllTypedSeq _ tail' -> map IllTypedOp tail'
+ MixedSeq nesting instr _ tail' -> [withSomeTcInstr instr (MixedOp nesting . SomeSingInstr) tail']
+ IllTypedSeq _ tail' -> [IllTypedOp tail']
-- | Case analysis for @TypeCheckedSeq@.
tcsEither
@@ -47,5 +50,5 @@
-> a
tcsEither onErr onInstr v = case v of
WellTypedSeq instr -> onInstr instr
- MixedSeq _ err _ -> onErr (seqToOps v) err
+ MixedSeq _ _ err _ -> onErr (seqToOps v) err
IllTypedSeq err _ -> onErr (seqToOps v) err
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
@@ -19,11 +19,9 @@
import Data.Constraint (Dict(..))
import Data.Map.Lazy qualified as Map
import Data.Singletons (Sing, SingI(..))
-import Fmt (Buildable(..), pretty, (+|), (|+))
+import Fmt (Buildable(..), Doc, pretty, (+|), (<+>), (|+))
import Prelude hiding (EQ, GT, LT)
-import Text.PrettyPrint.Leijen.Text (Doc, (<+>))
-import Morley.Michelson.Printer.Util
import Morley.Michelson.Typed (SomeContract(..), T(..))
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Contract
@@ -69,16 +67,13 @@
rnf ((d, b) ::& hst) = rnf (d, b, hst)
instance Buildable (HST ts) where
- build = buildRenderDocExtended
-
-instance RenderDoc (HST ts) where
- renderDoc _ SNil = "[]"
- renderDoc context (r ::& rs) = "[" <+> doRender (r ::& rs) <+> "]"
+ build SNil = "[]"
+ build (r ::& rs) = "[" <+> doRender (r ::& rs) <+> "]"
where
doRender :: HST (t ': ts_) -> Doc
doRender ((t, Dict) ::& (b ::& c)) =
- renderDoc context t <> "," <+> doRender (b ::& c)
- doRender ((t, Dict) ::& SNil) = renderDoc context t
+ build t <> "," <+> doRender (b ::& c)
+ doRender ((t, Dict) ::& SNil) = build t
infixr 7 ::&
instance Eq (HST ts) 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
@@ -33,7 +33,7 @@
import Morley.Tezos.Crypto.Timelock (chestFromBytes, chestKeyFromBytes)
import Morley.Util.Type (onFirst)
-tcFailedOnValue :: U.Value' op -> T.T -> Text -> Maybe TcTypeError -> TypeCheckInstr op a
+tcFailedOnValue :: U.Value' [] op -> T.T -> Text -> Maybe TcTypeError -> TypeCheckInstr op a
tcFailedOnValue v t msg err = do
loc <- view tcieErrorPos
throwError $ TcFailedOnValue v t msg loc err
@@ -59,11 +59,11 @@
(SingI ty, IsInstrOp op)
=> Maybe TcOriginatedContracts
-> TcInstrBase op
- -> U.Value' op
+ -> U.Value' [] op
-> TypeCheckInstr op (T.Value ty)
typeCheckValImpl mOriginatedContracts tcDo uv = doTypeCheckVal (uv, sing @ty)
where
- doTypeCheckVal :: forall tz. (U.Value' op, Sing tz) -> TypeCheckInstr op (T.Value tz)
+ doTypeCheckVal :: forall tz. (U.Value' [] op, Sing tz) -> TypeCheckInstr op (T.Value tz)
doTypeCheckVal (uvalue, sng) = do
typeCheckMode <- asks' (tcMode @op)
case (uvalue, sng) of
@@ -215,7 +215,7 @@
(U.ValueNil, STSet s) -> do
instrPos <- view tcieErrorPos
- case T.getComparableProofS s of
+ case T.comparabilityPresence 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)
@@ -250,13 +250,34 @@
-- `{ {} }` can be typechecked either as `VLam` or `VList`.
(U.ValueLambda s, STList l) ->
case traverse tryOpToVal s of
- Just xs -> doTypeCheckVal (U.ValueSeq xs, sng)
+ Just xs -> doTypeCheckVal (maybe U.ValueNil U.ValueSeq $ nonEmpty xs, sng)
Nothing -> tcFailedOnValue uvalue (fromSing l) "" Nothing
(U.ValueSeq s, STLambda _ _) -> case traverse tryValToOp s of
- Just xs -> doTypeCheckVal (U.ValueLambda xs, sng)
+ Just xs -> doTypeCheckVal (U.ValueLambda $ toList xs, sng)
Nothing -> tcFailedOnValue uvalue (fromSing sng) "" Nothing
+ (U.ValueLamRec mp, lam@(STLambda (var :: Sing it) (b :: Sing ot)) :: Sing lam) ->
+ withSingI var $ withSingI b $ do
+ _ :/ instr <-
+ withWTP @lam uvalue $ throwingTcError $
+ typeCheckImpl
+ -- lambdas can contain operations forbidden inside views, hence
+ -- we invent a "not in view" constraint here.
+ (giveNotInView $ local (set tcieNotInView $ Just Dict) ... tcDo)
+ (toList mp)
+ ((sing @it, Dict) ::& (lam, Dict) ::& SNil)
+ case instr of
+ code ::: (lo :: HST lo) -> withWTP @ot uvalue $ do
+ case eqHST1 @ot lo of
+ Right Refl -> do
+ pure $ T.mkVLamRec (T.RfNormal code)
+ Left m ->
+ tcFailedOnValue uvalue (demote @ty)
+ "wrong output type of lambda's value:" (Just m)
+ AnyOutInstr code ->
+ pure $ T.mkVLamRec (T.RfAlwaysFails code)
+
(v, STLambda (var :: Sing it) (b :: Sing ot)) -> withSingI var $ withSingI b $ do
mp <- case v of
U.ValueNil -> pure []
@@ -304,13 +325,13 @@
(v, t) -> tcFailedOnValue v (fromSing t) "unknown value" Nothing
- seqToRightCombedPair :: (NonEmpty $ U.Value' op) -> U.Value' op
+ seqToRightCombedPair :: (NonEmpty $ U.Value' [] op) -> U.Value' [] op
seqToRightCombedPair (x :| [y]) = U.ValuePair x y
seqToRightCombedPair (x :| xs) = U.ValuePair x $ seqToRightCombedPair (NE.fromList xs)
withWTP
:: forall t a. SingI t
- => U.Value' op
+ => U.Value' [] op
-> (T.WellTyped t => TypeCheckInstr op a)
-> TypeCheckInstr op a
withWTP uvalue fn = case T.getWTP @t of
@@ -318,7 +339,7 @@
Left err -> tcFailedOnValue uvalue (demote @ty) (pretty err) Nothing
typeCheckValsImpl
- :: ([U.Value' op], Sing t)
+ :: ([U.Value' [] op], Sing t)
-> TypeCheckInstr op [T.Value t]
typeCheckValsImpl (mvs, sng) =
fmap reverse $ foldM (\res mv -> (: res) <$> (doTypeCheckVal (mv, sng))) [] mvs
@@ -328,8 +349,8 @@
-- It return list of pairs (key, value) with keys in ascending order
-- so it is safe to call @fromDistinctAscList@ on returned list
typeCheckMapVal
- :: [U.Elt op]
- -> U.Value' op
+ :: [U.Elt [] op]
+ -> U.Value' [] op
-> Sing kt
-> Sing vt
-> TypeCheckInstr op [(T.Value kt, T.Value vt)]
@@ -343,31 +364,27 @@
typecheckContractValue
:: forall cp tz. (tz ~ 'T.TContract cp)
- => U.Value' op -> EpAddress -> Sing cp -> TypeCheckInstr op (T.Value tz)
+ => U.Value' [] op -> EpAddress -> Sing cp -> TypeCheckInstr op (T.Value tz)
typecheckContractValue cv (EpAddress addr epName) pc = do
instrPos <- view tcieErrorPos
- let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr op (cp :~: t')
- ensureTypeMatches = liftEither @_ @(TypeCheckInstr op) $
- first (TcFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $
- (withSingI pc $ eqType @cp @t')
- let unsupportedType :: T.BadTypeForScope -> TcError' op
- unsupportedType reason = TcFailedOnValue cv (fromSing pc)
- "Unsupported type in type argument of 'contract' type" instrPos $
- Just $ UnsupportedTypeForScope (fromSing pc) reason
+ let unsupportedType =
+ TcFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just
+ checkParameterScope :: TypeCheckInstr op (Dict (T.ParameterScope cp))
+ checkParameterScope = liftEither
+ $ first (unsupportedType . UnsupportedTypeForScope (fromSing pc))
+ $ withSingI pc $ T.checkScope @(T.ParameterScope cp)
case addr of
ImplicitAddress _ -> case pc of
STUnit -> pure $ VContract (MkAddress addr) T.sepcPrimitive
STTicket _ -> do
- Dict <- liftEither
- $ first unsupportedType
- $ withSingI pc $ T.checkScope @(T.ParameterScope cp)
+ Dict <- checkParameterScope
pure $ VContract (MkAddress addr) T.sepcPrimitive
- _ -> throwError $
- TcFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos $ Just $
- UnexpectedType (one "unit" :| [one "ticket 'a"])
+ _ -> throwError $ unsupportedType $ UnexpectedType (one "unit" :| [one "ticket 'a"])
ContractAddress ca -> case mOriginatedContracts of
- Nothing -> liftEither . Left $ unsupportedType T.BtHasContract
+ Nothing -> throwError $ TcFailedOnValue cv (fromSing $ STContract pc)
+ "'contract' type can not be used in this context" instrPos $
+ Just $ UnsupportedTypeForScope (fromSing $ STContract pc) T.BtHasContract
Just originatedContracts -> case M.lookup ca originatedContracts of
Just (SomeParamType paramNotes) ->
case T.mkEntrypointCall epName paramNotes of
@@ -376,26 +393,23 @@
TcFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $
EntrypointNotFound epName
Just (T.MkEntrypointCallRes (_ :: Notes t') epc) -> do
- Refl <- ensureTypeMatches @t'
+ Refl <- liftEither $ first unsupportedType $ withSingI pc $ eqType @cp @t'
pure $ VContract (MkAddress addr) (T.SomeEpc epc)
Nothing ->
throwError $ TcFailedOnValue cv (demote @ty) "Contract literal unknown"
instrPos (Just $ UnknownContract addr)
SmartRollupAddress _ -> do
-- TODO [#932]: Check that argument type matches
- Dict <- liftEither $
- first (TcFailedOnValue cv (demote @ty) "Bad parameter type" instrPos .
- Just . UnsupportedTypeForScope (fromSing pc)) $
- withSingI pc $ T.checkScope @(T.ParameterScope cp)
+ Dict <- checkParameterScope
pure $ VContract (MkAddress addr) $ T.SomeEpc T.unsafeEpcCallRoot
withComparable
:: forall a (t :: T.T) ty op. Sing a
- -> U.Value' op
+ -> U.Value' [] op
-> Sing t
-> (T.Comparable a => TypeCheckInstr op ty)
-> TypeCheckInstr op ty
-withComparable s uv t act = case T.getComparableProofS s of
+withComparable s uv t act = case T.comparabilityPresence s of
Just Dict -> act
Nothing -> do
instrPos <- view tcieErrorPos
@@ -404,12 +418,12 @@
withBigMapAbsence
:: forall a (t :: T.T) ty op. Sing a
- -> U.Value' op
+ -> U.Value' [] op
-> Sing t
- -> (T.HasNoBigMap a => TypeCheckInstr op ty)
+ -> (T.ForbidBigMap a => TypeCheckInstr op ty)
-> TypeCheckInstr op ty
-withBigMapAbsence s uv t act = case T.bigMapAbsense s of
- Just Dict -> act
+withBigMapAbsence s uv t act = case T.tAbsence T.SPSBigMap s of
+ Just Refl -> act
Nothing -> do
instrPos <- view tcieErrorPos
liftEither . Left $
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
@@ -34,10 +34,9 @@
import Data.Default (Default(def))
import Data.Singletons (Sing, SingI(..), fromSing)
-import Fmt (Buildable(..))
import Language.Haskell.TH.Syntax (Lift)
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)
+import Morley.Michelson.Printer.Util (RenderDoc(..))
import Morley.Michelson.Typed.Sing
import Morley.Michelson.Typed.T (T(..))
import Morley.Michelson.Untyped qualified as Un
@@ -94,10 +93,6 @@
deriving stock instance Show (Notes t)
deriving stock instance Lift (Notes t)
$(deriveGADTNFData ''Notes)
-
-
-instance Buildable (Notes t) where
- build = buildRenderDoc
instance RenderDoc (Notes t) where
renderDoc pn = renderDoc pn . mkUType
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs
--- a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs
@@ -8,12 +8,12 @@
( module Morley.Michelson.Typed.ClassifiedInstr.Internal.TH
) where
-import Prelude hiding (Type)
+import Prelude hiding (Type, lift)
import Prelude qualified
import Data.Constraint (Dict(..))
import Language.Haskell.TH
-import Text.Show qualified as Show (show)
+import Language.Haskell.TH.Syntax (Lift(..))
import Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.HasAnns
import Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsAlwaysFailing
@@ -46,9 +46,12 @@
cons'' <- mapM substOne cons
pure [DataD cxt' name tvb mk cons'' ders]
--- | A dirty hack to turn a enum value into its corresponding 'Name'
-toName :: forall a. (Enum a, Show a) => a -> Name
-toName = mkName . Show.show
+-- | Convert a 'Enum' constructor to a TemplateHaskell type quote with the
+-- corresponding promoted datakind constructor.
+promote :: forall a. (Enum a, Lift a) => a -> TypeQ
+promote = lift >=> \case
+ ConE nm -> promotedT nm
+ _ -> error "impossible because it's a enum"
where _ = Dict @(Enum a) -- silence redundant constraint warning
-- | Based on instruction constructor name and types of its arguments, generate
@@ -56,11 +59,10 @@
classifyInstrTH :: Name -> [Type] -> TypeQ
classifyInstrTH nm args = [t|'InstrClass $numc $ft $mich $anns|]
where
- numc = promotedT $ toName numc'
- numc' = numChildren args
- ft = promotedT . toName @FailureType $ isAlwaysFailing someEnum
- mich = promotedT . toName $ isMichelson someEnum
- anns = promotedT . toName $ hasAnns someEnum
+ numc = promote $ numChildren args
+ ft = promote $ isAlwaysFailing someEnum
+ mich = promote $ isMichelson someEnum
+ anns = promote $ hasAnns someEnum
someEnum = fromName nm
-- | Generate the function converting from 'Instr' to @WellClassifiedInstr@ existential.
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs
--- a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs
@@ -2,6 +2,7 @@
-- SPDX-License-Identifier: LicenseRef-MIT-OA
{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE DeriveLift #-}
-- Required due to 'genSingletonsType' producing those.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
@@ -12,6 +13,7 @@
) where
import Data.Singletons (Sing)
+import Language.Haskell.TH.Syntax (Lift)
import Morley.Util.Sing
@@ -28,7 +30,7 @@
-- ^ The instruction has one child.
| TwoChildren
-- ^ The instruction has two children.
- deriving stock (Show, Enum)
+ deriving stock (Show, Enum, Lift)
-- | Whether an instruction always fails. An example of always-failing
-- instruction is @NEVER@.
@@ -38,7 +40,7 @@
| FailingNormal
-- ^ Instruction might fail if inputs are incorrect, but will generally
-- work.
- deriving stock (Show, Enum)
+ deriving stock (Show, Enum, Lift)
data IsMichelson
= FromMichelson
@@ -50,7 +52,7 @@
-- ^ Wrappers that don't affect execution.
| Structural
-- ^ Michelson structures that are not instructions, e.g. a nested code block.
- deriving stock (Show, Enum)
+ deriving stock (Show, Enum, Lift)
-- | Whether an instruction carries Michelson annotations.
data HasAnns
@@ -60,7 +62,7 @@
-- annotations as @Anns@ type, which is true for most annotated
-- instructions. There are a couple exceptions, however.
| DoesHaveNonStandardAnns
- deriving stock (Show, Enum)
+ deriving stock (Show, Enum, Lift)
-- | A product type of all classifications.
data InstrClass = InstrClass NumChildren FailureType IsMichelson HasAnns
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
@@ -23,12 +23,10 @@
, mapContractCodeM
, mapContractCodeBlockM
, mapContractViewBlocksM
- , mapEntriesOrdered
) where
import Data.Constraint (Dict(..))
import Data.Default (Default(..))
-import Data.Map qualified as Map
import GHC.TypeLits (TypeError, pattern Text)
import Unsafe.Coerce (unsafeCoerce)
@@ -38,7 +36,6 @@
import Morley.Michelson.Typed.T (T(..))
import Morley.Michelson.Typed.View
import Morley.Michelson.Untyped.Contract (EntriesOrder)
-import Morley.Michelson.Untyped.Contract qualified as U
type ContractInp1 param st = 'TPair param st
type ContractInp param st = '[ ContractInp1 param st ]
@@ -162,7 +159,7 @@
-> Contract' instr cp st
-> m (Contract' instr cp st)
mapContractViewBlocksM f contract = do
- views <- UnsafeViewsSet <$> forM (unViewsSet (cViews contract)) \(SomeView v) -> do
+ views <- ViewsSet <$> forM (unViewsSet (cViews contract)) \(SomeView v) -> do
code <- f $ vCode v
pure $ SomeView v{ vCode = code }
pure contract{ cViews = views }
@@ -181,24 +178,3 @@
-> Contract' instr cp st
-> m (Contract' instr cp st)
mapContractCodeM f = mapContractCodeBlockM f <=< mapContractViewBlocksM f
-
--- | Map each typed contract fields by the given function and sort the output
--- based on the 'EntriesOrder'.
-mapEntriesOrdered
- :: Contract' instr cp st
- -> (ParamNotes cp -> a)
- -> (Notes st -> a)
- -> (ContractCode' instr cp st -> a)
- -> (forall arg ret. View' instr arg st ret -> a)
- -> [a]
-mapEntriesOrdered Contract{..} fParam fStorage fCode fView = snd <$> sortWith fst elements
- where
- getElemOrder ty = fromMaybe maxBound $ Map.lookup ty $ U.unEntriesOrder cEntriesOrder
- elements
- = first getElemOrder
- <$> [ (U.EntryParameter, fParam cParamNotes)
- , (U.EntryStorage, fStorage cStoreNotes)
- , (U.EntryCode, fCode cCode)]
- <> (toList cViews <&> \(SomeView v@View{..}) -> (U.EntryView vName, fView v))
-{-# DEPRECATED mapEntriesOrdered "Unused and untested, essentially dead code; open an issue on the \
- \morley repository if you use this." #-}
diff --git a/src/Morley/Michelson/Typed/Convert.hs b/src/Morley/Michelson/Typed/Convert.hs
--- a/src/Morley/Michelson/Typed/Convert.hs
+++ b/src/Morley/Michelson/Typed/Convert.hs
@@ -8,7 +8,9 @@
, convertView
, convertSomeView
, convertContractCode
+ , convertContractCodeOptimized
, convertContract
+ , convertContractOptimized
, instrToOps
, instrToOpsOptimized
, untypeDemoteT
@@ -31,8 +33,7 @@
import Data.List.NonEmpty ((<|))
import Data.Map qualified as Map
import Data.Singletons (Sing, demote)
-import Fmt (Buildable(..), fmt, listF, pretty)
-import Text.PrettyPrint.Leijen.Text (Doc)
+import Fmt (Buildable(..), Doc, fmt, listF, pretty)
import Unsafe qualified (fromIntegral)
import Morley.Michelson.Printer.Util
@@ -69,35 +70,66 @@
convertContractCode
:: forall param store . (SingI param, SingI store)
=> ContractCode param store -> U.Contract
-convertContractCode contract =
+convertContractCode = convertContractCode' Readable
+
+-- | Convert typed t'ContractCode' to an untyped t'U.Contract' using optimized
+-- representation.
+convertContractCodeOptimized
+ :: forall param store . (SingI param, SingI store)
+ => ContractCode param store -> U.Contract
+convertContractCodeOptimized = convertContractCode' Optimized
+
+convertContractCode'
+ :: forall param store . (SingI param, SingI store)
+ => UntypingOptions -> ContractCode param store -> U.Contract
+convertContractCode' opts contract =
U.Contract
{ contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn
, contractStorage = untypeDemoteT @store
- , contractCode = instrToOps $ unContractCode contract
+ , contractCode = seqOrSingleOp $ instrToOpsImpl opts $ unContractCode contract
, entriesOrder = U.canonicalEntriesOrder
, contractViews = def
}
convertView :: forall arg store ret. View arg store ret -> U.View
-convertView View{..} =
+convertView = convertView' Readable
+
+convertView' :: forall arg store ret. UntypingOptions -> View arg store ret -> U.View
+convertView' opts View{..} =
U.View
{ viewName = vName
, viewArgument = untypeDemoteT @arg
, viewReturn = untypeDemoteT @ret
- , viewCode = instrToOps vCode
+ , viewCode = seqOrSingleOp $ instrToOpsImpl opts vCode
}
+seqOrSingleOp :: [U.ExpandedOp] -> U.ExpandedOp
+seqOrSingleOp = \case
+ [x] -> x
+ xs -> U.SeqEx xs
+
convertSomeView :: SomeView st -> U.View
-convertSomeView (SomeView v) = convertView v
+convertSomeView = convertSomeView' Readable
+convertSomeView' :: UntypingOptions -> SomeView st -> U.View
+convertSomeView' opts (SomeView v) = convertView' opts v
+
-- | Convert typed t'Contract' to an untyped t'U.Contract'.
convertContract :: Contract param store -> U.Contract
-convertContract Contract{..} =
- let c = convertContractCode cCode
+convertContract = convertContract' Readable
+
+-- | Convert typed t'Contract' to untyped t'U.Contract' using optimized
+-- representation.
+convertContractOptimized :: Contract param store -> U.Contract
+convertContractOptimized = convertContract' Optimized
+
+convertContract' :: UntypingOptions -> Contract param store -> U.Contract
+convertContract' opts Contract{..} =
+ let c = convertContractCode' opts cCode
in c { U.contractParameter = convertParamNotes cParamNotes
, U.contractStorage = mkUType cStoreNotes
, U.entriesOrder = cEntriesOrder
- , U.contractViews = U.UnsafeViewsSet $ convertSomeView <$> unViewsSet cViews
+ , U.contractViews = U.ViewsSet $ convertSomeView' opts <$> unViewsSet cViews
}
-- Note: if you change this type, check 'untypeValueImpl' wildcard patterns.
@@ -113,21 +145,21 @@
deriving stock (Eq, Show)
-- | Convert a typed value to an untyped human-readable representation
-untypeValue :: HasNoOp t => Value' Instr t -> U.Value
+untypeValue :: ForbidOp t => Value' Instr t -> U.Value
untypeValue = untypeValueImpl' Readable
-- | Like 'untypeValueOptimized', but without list notation for pairs.
--
-- Created to match @octez-client hash data@ behaviour for typed values.
-untypeValueHashable :: HasNoOp t => Value' Instr t -> U.Value
+untypeValueHashable :: ForbidOp t => Value' Instr t -> U.Value
untypeValueHashable = untypeValueImpl' Hashable
-- | Convert a typed value to an untyped optimized representation
-untypeValueOptimized :: HasNoOp t => Value' Instr t -> U.Value
+untypeValueOptimized :: ForbidOp t => Value' Instr t -> U.Value
untypeValueOptimized = untypeValueImpl' Optimized
untypeValueImpl'
- :: HasNoOp t
+ :: ForbidOp t
=> UntypingOptions
-> Value' Instr t
-> U.Value
@@ -139,72 +171,70 @@
-- 'TOperation' - a compile error will be raised otherwise.
-- You can analyse its presence with 'checkOpPresence' function.
untypeValueImpl
- :: HasNoOp t
+ :: ForbidOp t
=> UntypingOptions
-> Sing t
-> Value' Instr t
-> U.Value
-untypeValueImpl opts sng val = case (val, sng) of
- (VInt i, _) -> U.ValueInt i
- (VNat i, _) -> U.ValueInt $ toInteger i
- (VString s, _) -> U.ValueString s
- (VBytes b, _) -> U.ValueBytes $ U.InternalByteString b
- (VMutez m, _) -> U.ValueInt $ toInteger $ unMutez m
- (VBool True, _) -> U.ValueTrue
- (VBool False, _) -> U.ValueFalse
- (VKeyHash h, _) ->
+untypeValueImpl opts sng val = case val of
+ VInt i -> U.ValueInt i
+ VNat i -> U.ValueInt $ toInteger i
+ VString s -> U.ValueString s
+ VBytes b -> U.ValueBytes $ U.InternalByteString b
+ VMutez m -> U.ValueInt $ toInteger $ unMutez m
+ VBool True -> U.ValueTrue
+ VBool False -> U.ValueFalse
+ VKeyHash h ->
case opts of
Readable -> U.ValueString $ mformatHash h
_ -> U.ValueBytes $ U.InternalByteString $ hashToBytes h
- (VBls12381Fr v, _) ->
+ VBls12381Fr v ->
case opts of
Readable -> U.ValueInt $ toInteger v
_ -> U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v
- (VBls12381G1 v, _) ->
+ VBls12381G1 v ->
U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v
- (VBls12381G2 v, _) ->
+ VBls12381G2 v ->
U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v
- (VTimestamp t, _) ->
+ VTimestamp t ->
case opts of
Readable -> U.ValueString . unsafe . mkMText $ pretty t
_ -> U.ValueInt $ timestampToSeconds t
- (VAddress a, _) ->
+ VAddress a ->
case opts of
Readable -> U.ValueString $ mformatEpAddress a
_ -> U.ValueBytes . U.InternalByteString $ encodeEpAddress a
- (VKey b, _) ->
+ VKey b ->
case opts of
Readable -> U.ValueString $ mformatPublicKey b
_ -> U.ValueBytes . U.InternalByteString $ keyToBytes b
- (VUnit, _) ->
+ VUnit ->
U.ValueUnit
- (VSignature b, _) ->
+ VSignature b ->
case opts of
Readable -> U.ValueString $ mformatSignature b
_ -> U.ValueBytes . U.InternalByteString $ signatureToBytes b
- (VChainId b, _) ->
+ VChainId b ->
case opts of
Readable -> U.ValueString $ mformatChainId b
_ ->
U.ValueBytes . U.InternalByteString $ ByteArray.convert (unChainId b)
- (VOption (Just x), STOption op) ->
+ VOption (Just x) | STOption op <- sng ->
U.ValueSome (untypeValueImpl opts op x)
- (VOption Nothing, STOption _) ->
- U.ValueNone
- (VList l, STList lt) ->
+ VOption Nothing -> U.ValueNone
+ VList l | STList lt <- sng ->
vList U.ValueSeq $ map (untypeValueImpl opts lt) l
- (VSet s, STSet st) ->
- case checkOpPresence st of
- OpAbsent -> vList U.ValueSeq $ map (untypeValueImpl opts st) $ toList s
- (VContract addr sepc, _) ->
+ VSet s | STSet st <- sng ->
+ vList U.ValueSeq $ map (untypeValueImpl opts st) $ toList s
+ VContract addr sepc ->
case opts of
Readable ->
U.ValueString . mformatEpAddress $ EpAddress' addr (sepcName sepc)
_ -> U.ValueBytes . U.InternalByteString . encodeEpAddress $
EpAddress' addr (sepcName sepc)
- (VChest c, _) -> U.ValueBytes . U.InternalByteString $ chestBytes c
- (VChestKey c, _) -> U.ValueBytes . U.InternalByteString $ chestKeyBytes c
- (VTicket s v a, STTicket vt) ->
+ VChest c -> U.ValueBytes . U.InternalByteString $ chestBytes c
+ VChestKey c -> U.ValueBytes . U.InternalByteString $ chestKeyBytes c
+ VTicket s v a | STTicket vt <- sng ->
case valueTypeSanity v of
Dict ->
let us = untypeValueImpl opts STAddress $ VAddress (EpAddress' s DefEpName)
@@ -213,46 +243,39 @@
in case opts of
Optimized -> U.ValueSeq $ us :| [uv, ua]
_ -> U.ValuePair us (U.ValuePair uv ua)
- p@(VPair (l, r), STPair lt rt) ->
- case checkOpPresence lt of
- OpAbsent -> case opts of
- Optimized -> U.ValueSeq $ pairToSeq p
- _ -> U.ValuePair (untypeValueImpl opts lt l) (untypeValueImpl opts rt r)
+ VPair (l, r) -> case opts of
+ Optimized -> U.ValueSeq $ pairToSeq (val, sng)
+ _ | STPair lt rt <- sng -> deMorganForbidT SPSOp lt rt $
+ U.ValuePair (untypeValueImpl opts lt l) (untypeValueImpl opts rt r)
- (VOr (Left x), STOr lt _) ->
- case checkOpPresence lt of
- OpAbsent -> U.ValueLeft (untypeValueImpl opts lt x)
+ VOr (Left x) | STOr lt rt <- sng -> deMorganForbidT SPSOp lt rt $
+ U.ValueLeft (untypeValueImpl opts lt x)
- (VOr (Right x), STOr lt rt) ->
- case checkOpPresence lt of
- OpAbsent -> U.ValueRight (untypeValueImpl opts rt x)
+ VOr (Right x) | STOr lt rt <- sng -> deMorganForbidT SPSOp lt rt $
+ U.ValueRight (untypeValueImpl opts rt x)
- (VLam (LambdaCode (rfAnyInstr -> ops)), _) ->
- vList U.ValueLambda $ instrToOpsImpl opts ops
+ VLam (LambdaCode (rfAnyInstr -> ops)) ->
+ vList (U.ValueLambda . toList) $ instrToOpsImpl opts ops
- (VLam (LambdaCodeRec (rfAnyInstr -> ops)), _) ->
- vList U.ValueLamRec $ instrToOpsImpl opts ops
+ VLam (LambdaCodeRec (rfAnyInstr -> ops)) ->
+ vList (U.ValueLamRec . toList) $ instrToOpsImpl opts ops
- (VMap m, STMap kt vt) ->
- case (checkOpPresence kt, checkOpPresence vt) of
- (OpAbsent, OpAbsent) ->
- vList U.ValueMap $ Map.toList m <&> \(k, v) ->
- U.Elt (untypeValueImpl opts kt k) (untypeValueImpl opts vt v)
+ VMap m | STMap kt vt <- sng -> deMorganForbidT SPSOp kt vt $
+ vList U.ValueMap $ Map.toList m <&> \(k, v) ->
+ U.Elt (untypeValueImpl opts kt k) (untypeValueImpl opts vt v)
- (VBigMap _ m, STBigMap kt vt) ->
- case (checkOpPresence kt, checkOpPresence vt) of
- (OpAbsent, OpAbsent) ->
- vList U.ValueMap $ Map.toList m <&> \(k, v) ->
- U.Elt (untypeValueImpl opts kt k) (untypeValueImpl opts vt v)
+ VBigMap _ m | STBigMap kt vt <- sng -> deMorganForbidT SPSOp kt vt $
+ vList U.ValueMap $ Map.toList m <&> \(k, v) ->
+ U.Elt (untypeValueImpl opts kt k) (untypeValueImpl opts vt v)
where
vList ctor = maybe U.ValueNil ctor . nonEmpty
- pairToSeq :: HasNoOp ty
+ pairToSeq :: ForbidOp ty
=> (Value ty, Sing ty)
-> NonEmpty U.Value
pairToSeq = \case
- (VPair (a, b), STPair l r) -> case checkOpPresence l of
- OpAbsent -> untypeValueImpl opts l a <| pairToSeq (b, r)
+ (VPair (a, b), STPair l r) -> deMorganForbidT SPSOp l r $
+ untypeValueImpl opts l a <| pairToSeq (b, r)
(v, vt) -> untypeValueImpl opts vt v :| []
hashToBytes :: Hash kind -> ByteString
@@ -305,7 +328,7 @@
instrToOpsImpl opts = \case
Nop -> []
Seq i1 i2 -> instrToOpsImpl opts i1 <> instrToOpsImpl opts i2
- Nested sq -> one $ U.SeqEx $ instrToOps sq
+ Nested sq -> one $ U.SeqEx $ instrToOpsImpl opts sq
DocGroup _ sq -> instrToOpsImpl opts sq
Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext
-- TODO [#283]: After representation of locations is polished,
@@ -419,7 +442,7 @@
': g
': s)
('TOperation ': 'TAddress ': s) <- i ->
- annotateInstr ann U.CREATE_CONTRACT (convertContract contract)
+ annotateInstr ann U.CREATE_CONTRACT (convertContract' opts contract)
AnnIMPLICIT_ACCOUNT ann -> annotateInstr ann U.IMPLICIT_ACCOUNT
AnnNOW ann -> annotateInstr ann U.NOW
AnnAMOUNT ann -> annotateInstr ann U.AMOUNT
@@ -459,12 +482,12 @@
untypePrintComment :: PrintComment s -> U.PrintComment
untypePrintComment (PrintComment pc) = U.PrintComment $ map (second untypeStackRef) pc
-extInstrToOps :: ExtInstr s -> [U.ExtInstrAbstract U.ExpandedOp]
+extInstrToOps :: ExtInstr s -> [U.ExpandedExtInstr]
extInstrToOps = \case
PRINT pc -> one $ U.UPRINT (untypePrintComment pc)
TEST_ASSERT (TestAssert nm pc i) ->
one $ U.UTEST_ASSERT $
- U.TestAssert nm (untypePrintComment pc) (instrToOps i)
+ U.TestAssert nm (untypePrintComment pc) (instrToOpsImpl Readable i)
DOC_ITEM{} -> []
COMMENT_ITEM tp ->
case tp of
@@ -500,15 +523,12 @@
, instr1 `eqInstrExt` instr2
]
-instance HasNoOp t => RenderDoc (Value' Instr t) where
+instance ForbidOp t => RenderDoc (Value' Instr t) where
renderDoc pn = renderDoc pn . untypeValue
instance Buildable (Value' Instr t) where
- build val = printDocB True $ let tv = withValueTypeSanity val sing
- in renderDocSing doesntNeedParens (checkOpPresence tv) (val, tv)
-
-instance Buildable (Instr inp out) where
- build = buildRenderDocExtended
+ build val = let tv = withValueTypeSanity val sing
+ in renderDocSing doesntNeedParens (checkTPresence SPSOp tv) (val, tv)
instance RenderDoc (Instr inp out) where
renderDoc context = renderDocList context . instrToOps
@@ -590,50 +610,50 @@
-- | An extended version of renderDoc for typed values that handles VOp
-- accepts explicit singleton
-renderDocSing :: RenderContext -> OpPresence t -> (Value' Instr t, Sing t) -> Doc
+renderDocSing :: RenderContext -> TPresence 'PSOp t -> (Value' Instr t, Sing t) -> Doc
renderDocSing pn = \case
- OpAbsent -> renderDoc pn . untypeValue . fst
- OpPresent -> \case
- (VOp op, _) -> renderAnyBuildable op
+ TAbsent -> renderDoc pn . untypeValue . fst
+ TPresent -> \case
+ (VOp op, _) -> build op
-- other cases try to mimic instance RenderDoc U.Value, see "Michelson.Untyped.Value"
(VOption Nothing, _) -> U.renderNone
- (VOption (Just x), STOption tx) -> U.renderSome pn $ \ctx -> renderDocSing ctx OpPresent (x, tx)
- (VList xs, STList txs) -> renderList OpPresent txs xs
- (VSet ss, STSet tss) -> renderList OpPresent tss $ toList ss
- (VTicket s v a, STTicket tv) -> renderDocSing
- needsParens
- OpPresent
- (VPair (VAddress (EpAddress' s DefEpName), VPair (v, VNat a))
- , STPair STAddress (STPair tv STNat))
+ (VOption (Just x), STOption tx) -> U.renderSome pn $ \ctx -> renderDocSing ctx TPresent (x, tx)
+ (VList xs, STList txs) -> renderList TPresent txs xs
val@(VPair (_, (VPair (_, _))), _) ->
U.renderValuesList id $ renderLinearizedRightCombValuePair val
(VPair (l, r), STPair tl tr) -> U.renderPair pn (render tl l) (render tr r)
(VOr (Left l), STOr tl _) -> U.renderLeft pn $ render tl l
(VOr (Right r), STOr _ tr) -> U.renderRight pn $ render tr r
- (VMap m, STMap tk tv) -> renderMap (tk, tv, checkOpPresence tk, checkOpPresence tv) m
- (VBigMap _ m, STBigMap tk tv) -> renderMap (tk, tv, checkOpPresence tk, checkOpPresence tv) m
- where render sg v ctx = renderDocSing ctx (checkOpPresence sg) (v, sg)
+ (VMap m, STMap tk tv) -> renderMap (tk, tv, TPresent) m \\ comparableImplies tk
+ (VBigMap _ m, STBigMap tk tv) -> renderMap (tk, tv, TPresent) m \\ comparableImplies tk
+ (VSet{}, STSet tv) -> case checkComparability tv of
+ (VTicket{}, STTicket tv) -> case checkComparability tv of
+ where render sg v ctx = renderDocSing ctx (checkTPresence SPSOp sg) (v, sg)
-renderList :: OpPresence t -> Sing t -> [Value' Instr t] -> Doc
+renderList :: TPresence 'PSOp t -> Sing t -> [Value' Instr t] -> Doc
renderList osg sg = renderList' $ renderDocSing doesntNeedParens osg . (, sg)
-renderMap :: (Sing tk, Sing tv, OpPresence tk, OpPresence tv)
- -> Map (Value' Instr tk) (Value' Instr tv) -> Doc
+renderMap
+ :: ForbidOp tk
+ => (Sing tk, Sing tv, TPresence 'PSOp tv)
+ -> Map (Value' Instr tk) (Value' Instr tv) -> Doc
renderMap ctx = renderList' (renderElt ctx) . Map.toList
renderList' :: (a -> Doc) -> [a] -> Doc
renderList' f = maybe "{ }" (U.renderValuesList f) . nonEmpty
-renderElt :: (Sing tk, Sing tv, OpPresence tk, OpPresence tv)
- -> (Value' Instr tk, Value' Instr tv) -> Doc
-renderElt (tk, tv, otk, otv) (k, v) =
- U.renderElt' (render otk k tk) (render otv v tv)
+renderElt
+ :: ForbidOp tk
+ => (Sing tk, Sing tv, TPresence 'PSOp tv)
+ -> (Value' Instr tk, Value' Instr tv) -> Doc
+renderElt (tk, tv, otv) (k, v) =
+ U.renderElt' (render TAbsent k tk) (render otv v tv)
where render o x tx ctx = renderDocSing ctx o (x, tx)
-- | Mimics U.linearizeRightCombValuePair, but for typed values;
-- however, unlike U.linearizeRightCombValuePair renders values on-the-fly.
renderLinearizedRightCombValuePair :: (Value' Instr t, Sing t) -> NonEmpty Doc
renderLinearizedRightCombValuePair = \case
- (VPair (l, r), STPair tl tr) -> renderDocSing doesntNeedParens (checkOpPresence tl) (l, tl)
+ (VPair (l, r), STPair tl tr) -> renderDocSing doesntNeedParens (checkTPresence SPSOp tl) (l, tl)
<| renderLinearizedRightCombValuePair (r, tr)
- val@(_, tv) -> renderDocSing doesntNeedParens (checkOpPresence tv) val :| []
+ val@(_, tv) -> renderDocSing doesntNeedParens (checkTPresence SPSOp tv) val :| []
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
@@ -46,12 +46,10 @@
import Data.ByteString qualified as BS
import Data.Constraint (Dict(..))
import Data.List.NonEmpty qualified as NE
-import Data.Singletons (withSingI)
import Data.Text qualified as T
-import Fmt (Buildable(..), hexF, pretty, (+|), (|+))
-import Text.PrettyPrint.Leijen.Text (int, punctuate, squotes, textStrict, (<+>))
+import Fmt (Buildable(..), hexF, pretty, (+|), (<+>), (|+))
+import Prettyprinter (punctuate, squotes)
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)
import Morley.Michelson.Text
import Morley.Michelson.Typed.Annotation
import Morley.Michelson.Typed.Scope
@@ -62,8 +60,8 @@
import Morley.Tezos.Address
import Morley.Tezos.Crypto (hashLengthBytes)
import Morley.Util.TH
-import Morley.Util.TypeLits
import Morley.Util.Typeable
+import Morley.Util.TypeLits
----------------------------------------------------------------------------
-- Primitives
@@ -114,19 +112,16 @@
instance NFData ParseEpAddressError
instance Buildable ParseEpAddressError where
- build = buildRenderDoc
-
-instance RenderDoc ParseEpAddressError where
- renderDoc context = \case
- ParseEpAddressBadAddress err -> renderDoc context err
- ParseEpAddressRawBadAddress err -> renderDoc context err
+ build = \case
+ ParseEpAddressBadAddress err -> build err
+ ParseEpAddressRawBadAddress err -> build err
ParseEpAddressBadEntryopint addr exception ->
- "Invalid entrypoint given for raw adddress" <+> (renderAnyBuildable $ hexF addr)<>
- " and failed with" <+> (textStrict (show @Text exception))
- ParseEpAddressBadRefAnn txt -> "Invalid reference annotation:" <+> (textStrict txt)
- ParseEpAddressRefAnnError err -> renderDoc context err
+ "Invalid entrypoint given for raw adddress" <+> hexF addr <>
+ " and failed with" <+> build (displayException exception)
+ ParseEpAddressBadRefAnn txt -> "Invalid reference annotation:" <+> build txt
+ ParseEpAddressRefAnnError err -> build err
ParseEpAddressInvalidLength len ->
- "Given raw entrypoint address has invalid length:" <+> int len
+ "Given raw entrypoint address has invalid length:" <+> build len
-- | Parse an address which can be suffixed with entrypoint name
-- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").
@@ -200,10 +195,7 @@
instance NFData ArmCoord
instance Buildable ArmCoord where
- build = buildRenderDoc
-
-instance RenderDoc ArmCoord where
- renderDoc _ = \case
+ build = \case
AcLeft -> "left"
AcRight -> "right"
@@ -217,18 +209,15 @@
instance NFData ParamEpError
instance Buildable ParamEpError where
- build = buildRenderDoc
-
-instance RenderDoc ParamEpError where
- renderDoc context = \case
+ build = \case
ParamEpDuplicatedNames names -> mconcat
[ "Duplicated entrypoint names: "
- , mconcat $ punctuate ", " . map (squotes . renderAnyBuildable) $ toList names
+ , mconcat $ punctuate ", " $ squotes . build <$> toList names
]
ParamEpUncallableArm arm -> mconcat
[ "Due to presence of 'default' entrypoint, one of contract \"arms\" \
\cannot be called: \""
- , mconcat . intersperse " - " $ map (renderDoc context) arm
+ , mconcat . intersperse " - " $ map build arm
, "\""
, if length arm > 1 then " (in top-to-bottom order)" else ""
]
@@ -432,19 +421,17 @@
-> Notes param
-> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)
-> Maybe r
-withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =
- case (sing @param, param) of
- (STOr lSing rSing, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->
- withSingI lSing $
- withSingI rSing $
- case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of
- (OpAbsent, NestedBigMapsAbsent) -> asum
- [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)
- , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)
- , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft)
- , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight)
- ]
- _ -> Nothing
+withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont = case param of
+ NTOr _ lFieldAnn rFieldAnn (lNotes :: Notes a) (rNotes :: Notes b) ->
+ withDeMorganScope @ForbidOp @'TOr @a @b $
+ withDeMorganScope @ForbidNestedBigMaps @'TOr @a @b $
+ asum
+ [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)
+ , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)
+ , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft)
+ , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight)
+ ]
+ _ -> Nothing
-- Helper datatype for 'mkEntrypointCall'.
data MkEntrypointCallRes param where
diff --git a/src/Morley/Michelson/Typed/Existential.hs b/src/Morley/Michelson/Typed/Existential.hs
--- a/src/Morley/Michelson/Typed/Existential.hs
+++ b/src/Morley/Michelson/Typed/Existential.hs
@@ -37,7 +37,7 @@
pattern SomeConstrainedValue v = Constrained v
{-# COMPLETE SomeConstrainedValue #-}
-instance (forall t. cs t => HasNoOp t) => RenderDoc (SomeConstrainedValue cs) where
+instance (forall t. cs t => ForbidOp t) => RenderDoc (SomeConstrainedValue cs) where
renderDoc pn (Constrained v) = renderDoc pn v
----------------------------------------------------------------------------
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
@@ -36,7 +36,6 @@
, unsafeConcreteTypeDocHaskellRep
, haskellAddNewtypeField
, haskellRepNoFields
- , haskellRepStripFieldPrefix
, haskellRepMap
, haskellRepAdjust
, homomorphicTypeDocMichelsonRep
@@ -59,7 +58,7 @@
import Data.List (lookup)
import Data.Singletons (SingI, demote)
import Data.Typeable (typeRep, typeRepArgs)
-import Fmt (Buildable, Builder, build, (+|), (|+))
+import Fmt (Buildable, Doc, build, singleLineF, (+|), (|+))
import GHC.Generics ((:*:)(..), (:+:)(..))
import GHC.Generics qualified as G
import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)
@@ -82,6 +81,10 @@
import Morley.Util.Text
import Morley.Util.Typeable
+{- $setup
+>>> import Morley.Michelson.Typed
+-}
+
-- | Stands for representation of some Haskell ADT corresponding to
-- Michelson value. Type parameter @a@ is what you put in place of
-- each field of the datatype, e.g. information about field type.
@@ -411,11 +414,19 @@
docItemToToc lvl d@(DType ap') =
mdTocFromRef lvl (build $ typeDocName ap') d
--- | Fully render Michelson representation of a type.
-typeDocBuiltMichelsonRep :: TypeHasDoc a => Proxy a -> Builder
+{- | Fully render Michelson representation of a type.
+
+Since this will be used in markdown, the type is forced to a single line.
+
+>>> data Foo = Foo () () () () () () () () () () () () deriving (Generic, IsoValue)
+>>> instance TypeHasDoc Foo where typeDocMdDescription = "Foo type"
+>>> typeDocBuiltMichelsonRep $ Proxy @Foo
+**Final Michelson representation:** `pair (pair (pair unit unit unit) unit unit unit) (pair unit unit unit) unit unit unit`
+-}
+typeDocBuiltMichelsonRep :: TypeHasDoc a => Proxy a -> Doc
typeDocBuiltMichelsonRep ap' =
let (mlhs, rep) = typeDocMichelsonRep ap'
- renderedRep = mdTicked (build rep)
+ renderedRep = mdTicked $ singleLineF rep
in case mlhs of
Nothing ->
mdSubsection "Final Michelson representation"
@@ -607,13 +618,6 @@
-- | Like 'haskellRepAdjust', but can't add or remove field names.
haskellRepMap :: (Text -> Text) -> TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellRepMap = haskellRepAdjust . fmap
-
--- | Map over fields with 'stripFieldPrefix'. Equivalent to @haskellRepMap
--- stripFieldPrefix@. Left for compatibility.
-haskellRepStripFieldPrefix :: TypeDocHaskellRep a -> TypeDocHaskellRep a
-haskellRepStripFieldPrefix = haskellRepMap stripFieldPrefix
-{-# DEPRECATED haskellRepStripFieldPrefix
- "Use 'haskellRepMap' with utilities from \"Morley.Util.Text\" instead" #-}
-- | Add field name for @newtype@.
--
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
@@ -267,8 +267,8 @@
type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)
type WellTypedToT a = (IsoValue a, WellTyped (ToT a))
-type HasNoOpToT a = (IsoValue a, HasNoOp (ToT a))
-type HasNoBigMapToT a = (IsoValue a, HasNoBigMap (ToT a))
+type HasNoOpToT a = (IsoValue a, ForbidOp (ToT a))
+type HasNoBigMapToT a = (IsoValue a, ForbidBigMap (ToT a))
-- | Since @Contract@ name is used to designate contract code, lets call
-- analogy of 'TContract' type as follows.
@@ -285,7 +285,7 @@
instance (IsoValue (ContractRef arg)) => Buildable (ContractRef arg) where
build = buildVContract . toVal
-instance (HasNoOpToT arg, HasNoNestedBigMaps (ToT arg), WellTypedToT arg)
+instance (HasNoOpToT arg, ForbidNestedBigMaps (ToT arg), WellTypedToT arg)
=> IsoValue (ContractRef arg) where
type ToT (ContractRef arg) = 'TContract (ToT arg)
toVal ContractRef{..} = VContract crAddress crEntrypoint
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
@@ -323,9 +323,15 @@
-> Instr s s'
-> Instr ('TList a ': s) 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)
+ AnnEMPTY_SET
+ :: Comparable e
+ => Anns '[TypeAnn, VarAnn, Notes e] -> Instr s ('TSet e ': s)
+ AnnEMPTY_MAP
+ :: (SingI b, Comparable a)
+ => Anns '[TypeAnn, VarAnn, Notes a, Notes b] -> Instr s ('TMap a b ': s)
+ AnnEMPTY_BIG_MAP
+ :: (SingI b, Comparable a, ForbidBigMap 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)
@@ -515,7 +521,7 @@
=> AnnVar
-> Instr (n ': s) (UnaryArithRes Not n ': s)
AnnCOMPARE
- :: (Comparable n, SingI n)
+ :: Comparable n
=> AnnVar
-> Instr (n ': n ': s) ('TInt ': s)
AnnEQ
@@ -622,11 +628,11 @@
AnnSELF_ADDRESS :: AnnVar -> Instr s ('TAddress ': s)
NEVER :: Instr ('TNever ': s) t
AnnTICKET_DEPRECATED
- :: (Comparable a)
+ :: Comparable a
=> AnnVar
-> Instr (a ': 'TNat ': s) ('TTicket a ': s)
AnnTICKET
- :: (Comparable a)
+ :: Comparable a
=> AnnVar
-> Instr (a ': 'TNat ': s) ('TOption ('TTicket a) ': s)
AnnREAD_TICKET
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,22 +17,34 @@
import Data.Binary.Builder qualified as Bi
import Data.Binary.Put (putWord64be, runPut)
import Data.ByteString.Lazy qualified as BSL
+import Fmt (Buildable(..), Doc, quoteF, quoteOrIndentF, (++|), (|++), (|++^))
import Morley.Micheline.Binary.Internal (buildInteger)
import Morley.Michelson.Interpret.Pack (toBinary, toBinary')
import Morley.Michelson.Runtime.GState (TicketKey(..))
-import Morley.Michelson.Runtime.TxData (TxData)
-import Morley.Michelson.Typed (Emit, EpName(..), Instr, unContractCode)
+import Morley.Michelson.Runtime.TxData (TxData(..))
+import Morley.Michelson.Typed (Emit(..), EpName(..), Instr, cCode, convertContractCodeOptimized)
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 (PackedValScope, ParameterScope, StorageScope)
+import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core (Mutez(..))
import Morley.Tezos.Crypto (Hash(..), HashTag(..), KeyHash, blake2b, blake2b160)
+{- $setup
+>>> import Morley.Tezos.Core
+>>> import Morley.Tezos.Address
+>>> import Morley.Tezos.Address.Alias
+>>> import Morley.Michelson.Typed
+>>> import Morley.Michelson.Parser
+>>> import Morley.Michelson.Typed.Operation
+>>> import Morley.Michelson.Runtime.TxData
+>>> import Fmt (pretty)
+-}
+
newtype OperationHash = OperationHash
{ unOperationHash :: ByteString
}
@@ -81,6 +93,51 @@
deriving stock instance Show OriginationOperation
+{- | Prettyprinter for 'OriginationOperation'
+
+>>> :{
+contract
+ :: (StorageScope storage, ConstantScope storage)
+ => Contract TUnit storage
+contract = defaultContract FAILWITH
+:}
+
+>>> let ia = [ta|tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH|]
+>>> pretty $ OriginationOperation ia Nothing [tz|123u|] VUnit contract 1 Nothing
+Originate a contract with delegate initial storage 'Unit' and balance
+123 μꜩ
+
+>>> :{
+pretty $ OriginationOperation ia (Just $ unImplicitAddress ia)
+ [tz|123u|] VUnit contract 1 Nothing
+:}
+Originate a contract with delegate tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH initial
+storage 'Unit' and balance 123 μꜩ
+
+>>> :{
+pretty $ OriginationOperation ia Nothing
+ [tz|123u|] VUnit contract 1 (Just $ mkAlias "some_alias")
+:}
+Originate contract some_alias with delegate initial storage 'Unit' and
+balance 123 μꜩ
+
+>>> let storage = toVal (((), ()), ((), ()))
+>>> :{
+pretty $ OriginationOperation ia Nothing [tz|123u|] storage contract 1 Nothing
+:}
+Originate a contract with delegate initial storage
+ Pair (Pair Unit Unit) (Pair Unit Unit)
+and balance 123 μꜩ
+-}
+instance Buildable OriginationOperation where
+ build OriginationOperation{..} =
+ "Originate" ++| alias |++ "with delegate" ++| delegate
+ |++ "initial storage" ++| quoteOrIndentF ooStorage
+ |++^ "and balance" ++| ooBalance |++ ""
+ where
+ alias = maybe ("a contract" :: Doc) (("contract" ++|) . (|++ "")) ooAlias
+ delegate = maybe "" build ooDelegate
+
-- | Construct 'OperationHash' for an 'OriginationOperation'.
mkOriginationOperationHash :: OriginationOperation -> OperationHash
mkOriginationOperationHash OriginationOperation{..} =
@@ -94,7 +151,9 @@
packedOperation =
BSL.toStrict (runPut $ putWord64be $ fromIntegral @Word63 @Word64 $ unMutez ooBalance)
<> packMaybe (toBinary' . toVal) ooDelegate
- <> toBinary' (unContractCode $ cCode ooContract)
+ -- NB: we don't use typed code directly because there is some mismatch on
+ -- when it's a sequence vs a single instruction.
+ <> toBinary' (U.contractCode $ convertContractCodeOptimized $ cCode ooContract)
<> toBinary' ooStorage
-- | Compute address of a contract from its origination operation and global counter.
@@ -111,7 +170,7 @@
-- to generate contract addresses in a simplified manner.
--
-- Namely, we encode 'OriginationOperation' as we can and concat it with the global counter.
-
+--
-- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's
-- address.
mkContractAddress
@@ -136,6 +195,44 @@
, toCounter :: GlobalCounter
} deriving stock (Show)
+{- | Prettyprinter for 'TransferOperation'
+
+>>> let ia = [ta|tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH|]
+>>> let ca = [ta|KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz|]
+>>> :{
+transfer
+ :: (IsoValue p, ParameterScope (ToT p))
+ => KindedAddress kind -> p -> TransferOperation
+transfer dest param =
+ TransferOperation (Constrained dest) (TxData (Constrained ia)
+ (TxTypedParam $ toVal param) DefEpName [tz|123u|]) 1
+:}
+
+>>> pretty $ transfer ia ()
+Transfer 123 μꜩ tokens from tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH to
+tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH
+
+>>> pretty $ transfer ca ()
+Transfer to KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz entrypoint from
+tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH with parameter 'Unit' and amount 123 μꜩ
+
+>>> pretty $ transfer ca (MkAddress ca, MkAddress ia)
+Transfer to KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz entrypoint from
+tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH with parameter
+ Pair
+ "KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz"
+ "tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH"
+and amount 123 μꜩ
+-}
+instance Buildable TransferOperation where
+ build (TransferOperation (Constrained dest) TxData{..} _) = case dest of
+ ImplicitAddress{} ->
+ -- Implicit address' entrypoint and parameter are fixed, so omit them.
+ "Transfer" ++| tdAmount |++ "tokens from" ++| tdSenderAddress |++ "to" ++| dest |++ ""
+ _ -> "Transfer to" ++| dest |++ "entrypoint" ++| tdEntrypoint
+ |++ "from" ++| tdSenderAddress |++ "with parameter" ++| quoteOrIndentF tdParameter
+ |++^ "and amount" ++| tdAmount |++ ""
+
mkTransferOperationHash
:: ParameterScope t
=> KindedAddress kind
@@ -190,6 +287,23 @@
, sdoCounter :: GlobalCounter
} deriving stock Show
+{- | Prettyprinter for 'SetDelegateOperation'
+
+>>> let ia = [ta|tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH|]
+>>> pretty $ SetDelegateOperation (Constrained ia) Nothing 1
+Set delegate of contract tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH to
+
+>>> :{
+pretty $ SetDelegateOperation (Constrained ia) (Just $ unImplicitAddress ia) 1
+:}
+Set delegate of contract tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH to
+tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH
+-}
+instance Buildable SetDelegateOperation where
+ build SetDelegateOperation{..} =
+ "Set delegate of contract" ++| sdoContract
+ |++ "to" ++| maybe "" build sdoDelegate |++ ""
+
-- | Construct 'OperationHash' for a 'SetDelegateOperation'.
mkDelegationOperationHash :: SetDelegateOperation -> OperationHash
mkDelegationOperationHash SetDelegateOperation{..} =
@@ -206,3 +320,34 @@
}
deriving stock instance Show EmitOperation
+
+{- | Prettyprinter for 'EmitOperation'
+
+>>> let ca = [ta|KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz|]
+>>> :{
+emit :: (IsoValue a, PackedValScope (ToT a)) => a -> EmitOperation
+emit val = EmitOperation ca $ Emit "tag" starNotes (toVal val) 1
+:}
+
+>>> pretty $ emit ()
+Emit event 'tag' with type 'unit' and value 'Unit' from contract
+KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz
+
+>>> let tup = (((), ()), ((), ()))
+>>> let largeTup = (tup, tup)
+>>> pretty $ emit largeTup
+Emit event 'tag' with type
+ pair (pair (pair unit unit) unit unit) (pair unit unit) unit unit
+and value
+ Pair
+ (Pair (Pair Unit Unit) (Pair Unit Unit))
+ (Pair (Pair Unit Unit) (Pair Unit Unit))
+from contract KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz
+-}
+instance Buildable EmitOperation where
+ build (EmitOperation source Emit{..}) =
+ "Emit event" ++| quoteF "'" emTag
+ |++ "with type" ++| quoteOrIndentF emNotes
+ |++^ "and value" ++| quoteOrIndentF emValue
+ |++^ "from contract" ++| source
+ |++ ""
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
@@ -182,7 +182,7 @@
-> str
-> Maybe str
sliceImpl dropF takeF offset l s
- | offset >= Unsafe.fromIntegral @Int @Natural (length s) || offset + l > Unsafe.fromIntegral @Int @Natural (length s) =
+ | let len = length s, offset >= len || offset + l > len =
Nothing
| otherwise
-- Drop offset and then take requested number of items.
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
@@ -1,1416 +1,137 @@
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-{-# LANGUAGE UndecidableSuperClasses #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-
-{- | Module, containing restrictions imposed by instruction or value scope.
-
-Michelson have multiple restrictions on values, examples:
-
-* @operation@ type cannot appear in parameter.
-* @big_map@ type cannot appear in @PUSH@-able constants.
-* @contract@ type cannot appear in type we @UNPACK@ to.
-
-Thus we declare multiple "scopes" - constraints applied in corresponding
-situations, for instance
-
-* 'ParameterScope';
-* 'StorageScope';
-* 'ConstantScope'.
-
-Also we separate multiple "classes" of scope-related constraints.
-
-* 'ParameterScope' and similar ones are used within Michelson engine,
-they are understandable by GHC but produce not very clarifying errors.
-
-* 'ProperParameterBetterErrors' and similar ones are middle-layer constraints,
-they produce human-readable errors but GHC cannot make conclusions from them.
-They are supposed to be used only by eDSLs to define their own high-level
-constraints.
-
-* Lorentz and other eDSLs may declare their own constraints, in most cases
-you should use them. For example see @Lorentz.Constraints@ module.
-
--}
-
-module Morley.Michelson.Typed.Scope
- ( -- * Scopes
- ConstantScope
- , DupableScope
- , StorageScope
- , PackedValScope
- , ParameterScope
- , UntypedValScope
- , UnpackedValScope
- , ViewableScope
- , ComparabilityScope
-
- , ProperParameterBetterErrors
- , ProperStorageBetterErrors
- , ProperConstantBetterErrors
- , ProperDupableBetterErrors
- , ProperPackedValBetterErrors
- , ProperUnpackedValBetterErrors
- , ProperUntypedValBetterErrors
- , ProperViewableBetterErrors
- , ProperNonComparableValBetterErrors
-
- , IsDupableScope
- , (:-)(..)
-
- , BadTypeForScope (..)
- , CheckScope (..)
- , WithDeMorganScope (..)
- , Comparable (..)
- , WellTyped (..)
- , NotWellTyped (..)
-
- -- * Implementation internals
- , HasNoBigMap
- , HasNoNestedBigMaps
- , HasNoOp
- , HasNoContract
- , HasNoTicket
- , ContainsBigMap
- , ContainsContract
- , ContainsNestedBigMaps
- , ContainsOp
- , ContainsTicket
- , IsComparable
-
- , ForbidOp
- , ForbidContract
- , ForbidTicket
- , ForbidBigMap
- , ForbidNestedBigMaps
- , ForbidNonComparable
-
- , OpPresence (..)
- , ContractPresence (..)
- , TicketPresence (..)
- , BigMapPresence (..)
- , NestedBigMapsPresence (..)
- , checkOpPresence
- , checkContractTypePresence
- , checkTicketPresence
- , checkBigMapPresence
- , checkNestedBigMapsPresence
- , comparabilityPresence
- , opAbsense
- , contractTypeAbsense
- , bigMapAbsense
- , nestedBigMapsAbsense
-
- , Comparability(..)
- , checkComparability
- , getComparableProofS
-
- , comparabilityImpliesNoNestedBigMaps
- , comparabilityImpliesNoOp
-
- , getWTP
- , getWTP'
- -- * Re-exports
- , withDict
- , SingI (..)
- ) where
-
-import Data.Bool.Singletons (SBool(..))
-import Data.Constraint (Dict(..), withDict, (:-)(..), (\\))
-import Data.Singletons
- (SLambda(..), Sing, SingI(..), fromSing, type (@@), type (~>), type Apply, withSingI, (@@))
-import Data.Type.Bool (Not, type (&&), type (||))
-import Fmt (Buildable(..))
-import GHC.TypeLits (ErrorMessage(..))
-
-import Data.Type.Equality ((:~:)(..))
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)
-import Morley.Michelson.Typed.Sing (SingT(..))
-import Morley.Michelson.Typed.T (T(..))
-import Morley.Util.StubbedProof (stubProof)
-import Morley.Util.Type (FailUnless, FailWhen)
-import Unsafe.Coerce (unsafeCoerce)
-
-----------------------------------------------------------------------------
--- Constraints
-----------------------------------------------------------------------------
--- | Whether a value of this type _may_ contain an operation.
---
--- In some scopes (constants, parameters, storage) appearing for operation type
--- is prohibited.
--- Operations in input/output of lambdas are allowed without limits though.
-type family ContainsOp (t :: T) :: Bool where
- ContainsOp 'TKey = 'False
- ContainsOp 'TUnit = 'False
- ContainsOp 'TSignature = 'False
- ContainsOp 'TChainId = 'False
- ContainsOp ('TOption t) = ContainsOp t
- ContainsOp ('TList t) = ContainsOp t
- ContainsOp ('TSet t) = ContainsOp t
- ContainsOp 'TOperation = 'True
- ContainsOp ('TContract _) = 'False
- ContainsOp ('TTicket t) = ContainsOp t
- ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b
- ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b
- ContainsOp ('TLambda _ _) = 'False
- ContainsOp ('TMap k v) = ContainsOp k || ContainsOp v
- ContainsOp ('TBigMap k v) = ContainsOp k || ContainsOp v
- ContainsOp _ = 'False
-
--- | Whether a value of this type _may_ contain a @contract@ value.
---
--- In some scopes (constants, storage) appearing for contract type
--- is prohibited.
--- Contracts in input/output of lambdas are allowed without limits though.
-type family ContainsContract (t :: T) :: Bool where
- ContainsContract 'TKey = 'False
- ContainsContract 'TUnit = 'False
- ContainsContract 'TSignature = 'False
- ContainsContract 'TChainId = 'False
- ContainsContract ('TOption t) = ContainsContract t
- ContainsContract ('TList t) = ContainsContract t
- ContainsContract ('TSet _) = 'False
- ContainsContract 'TOperation = 'False
- ContainsContract ('TContract _) = 'True
- ContainsContract ('TPair a b) = ContainsContract a || ContainsContract b
- ContainsContract ('TOr a b) = ContainsContract a || ContainsContract b
- ContainsContract ('TLambda _ _) = 'False
- ContainsContract ('TMap _ v) = ContainsContract v
- ContainsContract ('TBigMap _ v) = ContainsContract v
- ContainsContract _ = 'False
-
--- | Whether a value of this type _may_ contain a @ticket@ value.
-type family ContainsTicket (t :: T) :: Bool where
- ContainsTicket ('TOption t) = ContainsTicket t
- ContainsTicket ('TList t) = ContainsTicket t
- ContainsTicket ('TSet _) = 'False
- ContainsTicket ('TTicket _) = 'True
- ContainsTicket ('TPair a b) = ContainsTicket a || ContainsTicket b
- ContainsTicket ('TOr a b) = ContainsTicket a || ContainsTicket b
- ContainsTicket ('TLambda _ _) = 'False
- ContainsTicket ('TMap _ v) = ContainsTicket v
- ContainsTicket ('TBigMap _ v) = ContainsTicket v
- ContainsTicket _ = 'False
-
--- | Whether a value of this type _may_ contain a @big_map@ value.
-type family ContainsBigMap (t :: T) :: Bool where
- ContainsBigMap 'TKey = 'False
- ContainsBigMap 'TUnit = 'False
- ContainsBigMap 'TSignature = 'False
- ContainsBigMap 'TChainId = 'False
- ContainsBigMap ('TOption t) = ContainsBigMap t
- ContainsBigMap ('TList t) = ContainsBigMap t
- ContainsBigMap ('TSet _) = 'False
- ContainsBigMap 'TOperation = 'False
- ContainsBigMap ('TContract _) = 'False
- ContainsBigMap ('TPair a b) = ContainsBigMap a || ContainsBigMap b
- ContainsBigMap ('TOr a b) = ContainsBigMap a || ContainsBigMap b
- ContainsBigMap ('TLambda _ _) = 'False
- ContainsBigMap ('TMap _ v) = ContainsBigMap v
- ContainsBigMap ('TBigMap _ _) = 'True
- ContainsBigMap _ = 'False
-
--- | Whether a value of this type _may_ contain nested @big_map@s.
---
--- Nested big_maps (i.e. big_map which contains another big_map inside of it's value type) are
--- prohibited in all contexts. Some context such as PUSH, APPLY, PACK/UNPACK instructions are more
--- strict because they don't work with big_map at all.
-type family ContainsNestedBigMaps (t :: T) :: Bool where
- ContainsNestedBigMaps 'TKey = 'False
- ContainsNestedBigMaps 'TUnit = 'False
- ContainsNestedBigMaps 'TSignature = 'False
- ContainsNestedBigMaps 'TChainId = 'False
- ContainsNestedBigMaps ('TOption t) = ContainsNestedBigMaps t
- ContainsNestedBigMaps ('TList t) = ContainsNestedBigMaps t
- ContainsNestedBigMaps ('TSet _) = 'False
- ContainsNestedBigMaps 'TOperation = 'False
- ContainsNestedBigMaps ('TContract _) = 'False
- ContainsNestedBigMaps ('TPair a b) = ContainsNestedBigMaps a || ContainsNestedBigMaps b
- ContainsNestedBigMaps ('TOr a b) = ContainsNestedBigMaps a || ContainsNestedBigMaps b
- ContainsNestedBigMaps ('TLambda _ _) = 'False
- ContainsNestedBigMaps ('TMap _ v) = ContainsNestedBigMaps v
- ContainsNestedBigMaps ('TBigMap _ v) = ContainsBigMap v
- ContainsNestedBigMaps _ = 'False
-
--- | Whether a value of this type _may_ contain a @samping_state@ value.
-type family ContainsSaplingState (t :: T) :: Bool where
- ContainsSaplingState ('TOption t) = ContainsSaplingState t
- ContainsSaplingState ('TList t) = ContainsSaplingState t
- ContainsSaplingState ('TPair a b) = ContainsSaplingState a || ContainsSaplingState b
- ContainsSaplingState ('TOr a b) = ContainsSaplingState a || ContainsSaplingState b
- ContainsSaplingState ('TMap _ v) = ContainsSaplingState v
- ContainsSaplingState ('TBigMap _ v) = ContainsSaplingState v
- ContainsSaplingState ('TSaplingState _) = 'True
- ContainsSaplingState _ = 'False
-
--- | Constraint which ensures that type is comparable.
-type family IsComparable (t :: T) :: Bool where
- IsComparable ('TPair a b) = IsComparable a && IsComparable b
- IsComparable ('TOption t) = IsComparable t
- IsComparable 'TBls12381Fr = 'False
- IsComparable 'TBls12381G1 = 'False
- IsComparable 'TBls12381G2 = 'False
- IsComparable ('TList _) = 'False
- IsComparable ('TSet _) = 'False
- IsComparable 'TOperation = 'False
- IsComparable ('TContract _) = 'False
- IsComparable ('TTicket _) = 'False
- IsComparable ('TOr a b) = IsComparable a && IsComparable b
- IsComparable ('TLambda _ _) = 'False
- IsComparable ('TMap _ _) = 'False
- IsComparable ('TBigMap _ _) = 'False
- IsComparable 'TChest = 'False
- IsComparable 'TChestKey = 'False
- IsComparable ('TSaplingState _) = 'False
- IsComparable ('TSaplingTransaction _) = 'False
- IsComparable _ = 'True
-
--- | Constraint which ensures that a value of type @t@ does not contain operations.
---
--- Not just a type alias in order to be able to partially apply it
--- (e.g. in 'Each').
-class (ContainsOp t ~ 'False) => HasNoOp t
-instance (ContainsOp t ~ 'False) => HasNoOp t
-
--- | Constraint which ensures that a value of type @t@ does not contain @contract@ values.
-class (ContainsContract t ~ 'False) => HasNoContract t
-instance (ContainsContract t ~ 'False) => HasNoContract t
-
--- | Constraint which ensures that a value of type @t@ does not contain @ticket@ values.
-class (ContainsTicket t ~ 'False) => HasNoTicket t
-instance (ContainsTicket t ~ 'False) => HasNoTicket t
-
--- | Constraint which ensures that a value of type @t@ does not contain @big_map@ values.
-class (ContainsBigMap t ~ 'False) => HasNoBigMap t
-instance (ContainsBigMap t ~ 'False) => HasNoBigMap t
-
--- | Constraint which ensures that a value of type @t@ does not contain @sapling_state@ values.
-class (ContainsSaplingState t ~ 'False) => HasNoSaplingState t
-instance (ContainsSaplingState t ~ 'False) => HasNoSaplingState t
-
--- | Constraint which ensures that there are no nested bigmaps.
-class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t
-instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t
-
--- | This is like 'HasNoOp', it raises a more human-readable error
--- when @t@ type is concrete, and also imposes an equality constraint.
---
--- Use this constraint in our eDSL.
-type ForbidOp t =
- FailWhen
- (ContainsOp t)
- ('Text "Operations are not allowed in this scope")
-
-type ForbidContract t =
- FailWhen
- (ContainsContract t)
- ('Text "Type `contract` is not allowed in this scope")
-
-type ForbidTicket t =
- FailWhen
- (ContainsTicket t)
- ('Text "Type `ticket` is not allowed in this scope")
-
-type ForbidSaplingState t =
- FailWhen
- (ContainsSaplingState t)
- ('Text "Type `sapling_state` is not allowed in this scope")
-
-type ForbidBigMap t =
- FailWhen
- (ContainsBigMap t)
- ('Text "BigMaps are not allowed in this scope")
-
-type ForbidNestedBigMaps t =
- FailWhen
- (ContainsNestedBigMaps t)
- ('Text "Nested BigMaps are not allowed")
-
--- | Constraint that rises human-readable error message, in case given value
--- can't be compared
-type ForbidNonComparable t =
- FailUnless
- (IsComparable t)
- ('Text "Only comparable types are allowed here")
-
--- | Whether a value of this type _may_ contain an operation.
-data OpPresence (t :: T)
- = ContainsOp t ~ 'True => OpPresent
- -- ^ A value of type @t@ may or may not contain an operation.
- | ContainsOp t ~ 'False => OpAbsent
- -- ^ A value of type @t@ cannot contain @big_map@ values.
-
--- | Whether a value of this type _may_ contain a @contract@ value.
-data ContractPresence (t :: T)
- = ContainsContract t ~ 'True => ContractPresent
- -- ^ A value of type @t@ may or may not contain a @contract@ value.
- | ContainsContract t ~ 'False => ContractAbsent
- -- ^ A value of type @t@ cannot contain @contract@ values.
-
--- | Whether a value of this type _may_ contain a @ticket@ value.
-data TicketPresence (t :: T)
- = ContainsTicket t ~ 'True => TicketPresent
- -- ^ A value of type @t@ may or may not contain a @ticket@ value.
- | ContainsTicket t ~ 'False => TicketAbsent
- -- ^ A value of type @t@ cannot contain @ticket@ values.
-
--- | Whether a value of this type _may_ contain a @big_map@ value.
-data BigMapPresence (t :: T)
- = ContainsBigMap t ~ 'True => BigMapPresent
- -- ^ A value of type @t@ may or may not contain a @big_map@ value.
- | ContainsBigMap t ~ 'False => BigMapAbsent
- -- ^ A value of type @t@ cannot contain @big_map@ values.
-
--- | Whether a value of this type _may_ contain nested @big_map@s.
-data NestedBigMapsPresence (t :: T)
- = ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresent
- -- ^ A value of type @t@ may or may not contain nested @big_map@s.
- | ContainsNestedBigMaps t ~ 'False => NestedBigMapsAbsent
- -- ^ A value of type @t@ cannot contain nested @big_map@s.
-
--- | Whether a value of this type _may_ contain a @sapling_state@ value.
-data SaplingStatePresence (t :: T)
- = ContainsSaplingState t ~ 'True => SaplingStatePresent
- -- ^ A value of type @t@ may or may not contain a @sapling_state@ value.
- | ContainsSaplingState t ~ 'False => SaplingStateAbsent
- -- ^ A value of type @t@ cannot contain @sapling_state@ values.
-
--- @rvem: IMO, generalization of OpPresence and BigMapPresence to
--- TPresence is not worth it, due to the fact that
--- it will require more boilerplate in checkTPresence implementation
--- than it is already done in checkOpPresence and checkBigMapPresence
-
--- | Check at runtime whether a value of the given type _may_ contain an operation.
-checkOpPresence :: Sing (ty :: T) -> OpPresence ty
-checkOpPresence = \case
- -- This is a sad amount of boilerplate, but at least
- -- there is no chance to make a mistake in it.
- -- We can't do in a simpler way while requiring only @Sing ty@ / @SingI ty@,
- -- and a more complex constraint would be too unpleasant and confusing to
- -- propagate everywhere.
- STKey -> OpAbsent
- STSignature -> OpAbsent
- STChainId -> OpAbsent
- STUnit -> OpAbsent
- STOption t -> case checkOpPresence t of
- OpPresent -> OpPresent
- OpAbsent -> OpAbsent
- STList t -> case checkOpPresence t of
- OpPresent -> OpPresent
- OpAbsent -> OpAbsent
- STSet a -> case checkOpPresence a of
- OpPresent -> OpPresent
- OpAbsent -> OpAbsent
- STOperation -> OpPresent
- STContract _ -> OpAbsent
- STTicket t -> case checkOpPresence t of
- OpPresent -> OpPresent
- OpAbsent -> OpAbsent
- STPair a b -> case (checkOpPresence a, checkOpPresence b) of
- (OpPresent, _) -> OpPresent
- (_, OpPresent) -> OpPresent
- (OpAbsent, OpAbsent) -> OpAbsent
- STOr a b -> case (checkOpPresence a, checkOpPresence b) of
- (OpPresent, _) -> OpPresent
- (_, OpPresent) -> OpPresent
- (OpAbsent, OpAbsent) -> OpAbsent
- STLambda _ _ -> OpAbsent
- STMap k v -> case (checkOpPresence k, checkOpPresence v) of
- (OpAbsent, OpAbsent) -> OpAbsent
- (OpPresent, _) -> OpPresent
- (_, OpPresent) -> OpPresent
- STBigMap k v -> case (checkOpPresence k, checkOpPresence v) of
- (OpAbsent, OpAbsent) -> OpAbsent
- (OpPresent, _) -> OpPresent
- (_, OpPresent) -> OpPresent
- STInt -> OpAbsent
- STNat -> OpAbsent
- STString -> OpAbsent
- STBytes -> OpAbsent
- STMutez -> OpAbsent
- STBool -> OpAbsent
- STKeyHash -> OpAbsent
- STBls12381Fr -> OpAbsent
- STBls12381G1 -> OpAbsent
- STBls12381G2 -> OpAbsent
- STTimestamp -> OpAbsent
- STAddress -> OpAbsent
- STChest -> OpAbsent
- STChestKey -> OpAbsent
- STNever -> OpAbsent
- STSaplingState _ -> OpAbsent
- STSaplingTransaction _ -> OpAbsent
-
--- | Check at runtime whether a value of the given type _may_ contain a @contract@ value.
-checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty
-checkContractTypePresence = \case
- STKey -> ContractAbsent
- STSignature -> ContractAbsent
- STChainId -> ContractAbsent
- STUnit -> ContractAbsent
- STOption t -> case checkContractTypePresence t of
- ContractPresent -> ContractPresent
- ContractAbsent -> ContractAbsent
- STList t -> case checkContractTypePresence t of
- ContractPresent -> ContractPresent
- ContractAbsent -> ContractAbsent
- STSet _ -> ContractAbsent
- STOperation -> ContractAbsent
- STContract _ -> ContractPresent
- STTicket _ -> ContractAbsent -- contract type is not allowed in tickets at all
- STPair a b -> case (checkContractTypePresence a, checkContractTypePresence b) of
- (ContractPresent, _) -> ContractPresent
- (_, ContractPresent) -> ContractPresent
- (ContractAbsent, ContractAbsent) -> ContractAbsent
- STOr a b -> case (checkContractTypePresence a, checkContractTypePresence b) of
- (ContractPresent, _) -> ContractPresent
- (_, ContractPresent) -> ContractPresent
- (ContractAbsent, ContractAbsent) -> ContractAbsent
- STLambda _ _ -> ContractAbsent
- STMap _ v -> case checkContractTypePresence v of
- ContractPresent -> ContractPresent
- ContractAbsent -> ContractAbsent
- STBigMap _ v -> case checkContractTypePresence v of
- ContractPresent -> ContractPresent
- ContractAbsent -> ContractAbsent
- STInt -> ContractAbsent
- STNat -> ContractAbsent
- STString -> ContractAbsent
- STBytes -> ContractAbsent
- STMutez -> ContractAbsent
- STBool -> ContractAbsent
- STKeyHash -> ContractAbsent
- STBls12381Fr -> ContractAbsent
- STBls12381G1 -> ContractAbsent
- STBls12381G2 -> ContractAbsent
- STTimestamp -> ContractAbsent
- STAddress -> ContractAbsent
- STChest -> ContractAbsent
- STChestKey -> ContractAbsent
- STNever -> ContractAbsent
- STSaplingState _ -> ContractAbsent
- STSaplingTransaction _ -> ContractAbsent
-
--- | Check at runtime whether a value of the given type _may_ contain a @ticket@ value.
-checkTicketPresence :: Sing (ty :: T) -> TicketPresence ty
-checkTicketPresence = \case
- STKey -> TicketAbsent
- STSignature -> TicketAbsent
- STChainId -> TicketAbsent
- STUnit -> TicketAbsent
- STOption t -> case checkTicketPresence t of
- TicketPresent -> TicketPresent
- TicketAbsent -> TicketAbsent
- STList t -> case checkTicketPresence t of
- TicketPresent -> TicketPresent
- TicketAbsent -> TicketAbsent
- STSet _ -> TicketAbsent
- STOperation -> TicketAbsent
- STContract _ -> TicketAbsent
- STTicket _ -> TicketPresent
- STPair a b -> case (checkTicketPresence a, checkTicketPresence b) of
- (TicketPresent, _) -> TicketPresent
- (_, TicketPresent) -> TicketPresent
- (TicketAbsent, TicketAbsent) -> TicketAbsent
- STOr a b -> case (checkTicketPresence a, checkTicketPresence b) of
- (TicketPresent, _) -> TicketPresent
- (_, TicketPresent) -> TicketPresent
- (TicketAbsent, TicketAbsent) -> TicketAbsent
- STLambda _ _ -> TicketAbsent
- STMap _ v -> case checkTicketPresence v of
- TicketPresent -> TicketPresent
- TicketAbsent -> TicketAbsent
- STBigMap _ v -> case checkTicketPresence v of
- TicketPresent -> TicketPresent
- TicketAbsent -> TicketAbsent
- STInt -> TicketAbsent
- STNat -> TicketAbsent
- STString -> TicketAbsent
- STBytes -> TicketAbsent
- STMutez -> TicketAbsent
- STBool -> TicketAbsent
- STKeyHash -> TicketAbsent
- STBls12381Fr -> TicketAbsent
- STBls12381G1 -> TicketAbsent
- STBls12381G2 -> TicketAbsent
- STTimestamp -> TicketAbsent
- STAddress -> TicketAbsent
- STChest -> TicketAbsent
- STChestKey -> TicketAbsent
- STNever -> TicketAbsent
- STSaplingState _ -> TicketAbsent
- STSaplingTransaction _ -> TicketAbsent
-
--- | Check at runtime whether a value of the given type _may_ contain a @big_map@ value.
-checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty
-checkBigMapPresence = \case
- -- More boilerplate to boilerplate god.
- STKey -> BigMapAbsent
- STSignature -> BigMapAbsent
- STChainId -> BigMapAbsent
- STUnit -> BigMapAbsent
- STOption t -> case checkBigMapPresence t of
- BigMapPresent -> BigMapPresent
- BigMapAbsent -> BigMapAbsent
- STList t -> case checkBigMapPresence t of
- BigMapPresent -> BigMapPresent
- BigMapAbsent -> BigMapAbsent
- STSet _ -> BigMapAbsent
- STOperation -> BigMapAbsent
- STContract _ -> BigMapAbsent
- STTicket _ -> BigMapAbsent -- big_maps are not allowed in tickets at all
- STPair a b -> case (checkBigMapPresence a, checkBigMapPresence b) of
- (BigMapPresent, _) -> BigMapPresent
- (_, BigMapPresent) -> BigMapPresent
- (BigMapAbsent, BigMapAbsent) -> BigMapAbsent
- STOr a b -> case (checkBigMapPresence a, checkBigMapPresence b) of
- (BigMapPresent, _) -> BigMapPresent
- (_, BigMapPresent) -> BigMapPresent
- (BigMapAbsent, BigMapAbsent) -> BigMapAbsent
- STLambda _ _ -> BigMapAbsent
- STMap _ v -> case checkBigMapPresence v of
- BigMapPresent -> BigMapPresent
- BigMapAbsent -> BigMapAbsent
- STBigMap _ _ ->
- BigMapPresent
- STInt -> BigMapAbsent
- STNat -> BigMapAbsent
- STString -> BigMapAbsent
- STBytes -> BigMapAbsent
- STMutez -> BigMapAbsent
- STBool -> BigMapAbsent
- STKeyHash -> BigMapAbsent
- STBls12381Fr -> BigMapAbsent
- STBls12381G1 -> BigMapAbsent
- STBls12381G2 -> BigMapAbsent
- STTimestamp -> BigMapAbsent
- STAddress -> BigMapAbsent
- STChest -> BigMapAbsent
- STChestKey -> BigMapAbsent
- STNever -> BigMapAbsent
- STSaplingState _ -> BigMapAbsent
- STSaplingTransaction _ -> BigMapAbsent
-
--- | Check at runtime whether a value of the given type _may_ contain nested @big_map@s.
-checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty
-checkNestedBigMapsPresence = \case
- -- More boilerplate to boilerplate god.
- STKey -> NestedBigMapsAbsent
- STSignature -> NestedBigMapsAbsent
- STChainId -> NestedBigMapsAbsent
- STUnit -> NestedBigMapsAbsent
- STOption t -> case checkNestedBigMapsPresence t of
- NestedBigMapsPresent -> NestedBigMapsPresent
- NestedBigMapsAbsent -> NestedBigMapsAbsent
- STList t -> case checkNestedBigMapsPresence t of
- NestedBigMapsPresent -> NestedBigMapsPresent
- NestedBigMapsAbsent -> NestedBigMapsAbsent
- STSet _ -> NestedBigMapsAbsent
- STOperation -> NestedBigMapsAbsent
- STContract _ -> NestedBigMapsAbsent
- STTicket _ -> NestedBigMapsAbsent
- STPair a b -> case (checkNestedBigMapsPresence a, checkNestedBigMapsPresence b) of
- (NestedBigMapsPresent, _) -> NestedBigMapsPresent
- (_, NestedBigMapsPresent) -> NestedBigMapsPresent
- (NestedBigMapsAbsent, NestedBigMapsAbsent) -> NestedBigMapsAbsent
- STOr a b -> case (checkNestedBigMapsPresence a, checkNestedBigMapsPresence b) of
- (NestedBigMapsPresent, _) -> NestedBigMapsPresent
- (_, NestedBigMapsPresent) -> NestedBigMapsPresent
- (NestedBigMapsAbsent, NestedBigMapsAbsent) -> NestedBigMapsAbsent
- STLambda _ _ -> NestedBigMapsAbsent
- STMap _ v -> case checkNestedBigMapsPresence v of
- NestedBigMapsPresent -> NestedBigMapsPresent
- NestedBigMapsAbsent -> NestedBigMapsAbsent
- STBigMap _ v -> case checkBigMapPresence v of
- BigMapPresent -> NestedBigMapsPresent
- BigMapAbsent -> NestedBigMapsAbsent
- STInt -> NestedBigMapsAbsent
- STNat -> NestedBigMapsAbsent
- STString -> NestedBigMapsAbsent
- STBytes -> NestedBigMapsAbsent
- STMutez -> NestedBigMapsAbsent
- STBool -> NestedBigMapsAbsent
- STKeyHash -> NestedBigMapsAbsent
- STBls12381Fr -> NestedBigMapsAbsent
- STBls12381G1 -> NestedBigMapsAbsent
- STBls12381G2 -> NestedBigMapsAbsent
- STTimestamp -> NestedBigMapsAbsent
- STAddress -> NestedBigMapsAbsent
- STChest -> NestedBigMapsAbsent
- STChestKey -> NestedBigMapsAbsent
- STNever -> NestedBigMapsAbsent
- STSaplingState _ -> NestedBigMapsAbsent
- STSaplingTransaction _ -> NestedBigMapsAbsent
-
-
--- | Check at runtime whether a value of the given type _may_ contain a @sapling_state@ value.
-checkSaplingStatePresence :: Sing (ty :: T) -> SaplingStatePresence ty
-checkSaplingStatePresence = \case
- STKey -> SaplingStateAbsent
- STSignature -> SaplingStateAbsent
- STChainId -> SaplingStateAbsent
- STUnit -> SaplingStateAbsent
- STOption t -> case checkSaplingStatePresence t of
- SaplingStatePresent -> SaplingStatePresent
- SaplingStateAbsent -> SaplingStateAbsent
- STList t -> case checkSaplingStatePresence t of
- SaplingStatePresent -> SaplingStatePresent
- SaplingStateAbsent -> SaplingStateAbsent
- STSet _ -> SaplingStateAbsent
- STOperation -> SaplingStateAbsent
- STContract _ -> SaplingStateAbsent
- STTicket _ -> SaplingStateAbsent
- STPair a b -> case (checkSaplingStatePresence a, checkSaplingStatePresence b) of
- (SaplingStatePresent, _) -> SaplingStatePresent
- (_, SaplingStatePresent) -> SaplingStatePresent
- (SaplingStateAbsent, SaplingStateAbsent) -> SaplingStateAbsent
- STOr a b -> case (checkSaplingStatePresence a, checkSaplingStatePresence b) of
- (SaplingStatePresent, _) -> SaplingStatePresent
- (_, SaplingStatePresent) -> SaplingStatePresent
- (SaplingStateAbsent, SaplingStateAbsent) -> SaplingStateAbsent
- STLambda _ _ -> SaplingStateAbsent
- STMap _ v -> case checkSaplingStatePresence v of
- SaplingStatePresent -> SaplingStatePresent
- SaplingStateAbsent -> SaplingStateAbsent
- STBigMap _ v -> case checkSaplingStatePresence v of
- SaplingStatePresent -> SaplingStatePresent
- SaplingStateAbsent -> SaplingStateAbsent
- STInt -> SaplingStateAbsent
- STNat -> SaplingStateAbsent
- STString -> SaplingStateAbsent
- STBytes -> SaplingStateAbsent
- STMutez -> SaplingStateAbsent
- STBool -> SaplingStateAbsent
- STKeyHash -> SaplingStateAbsent
- STBls12381Fr -> SaplingStateAbsent
- STBls12381G1 -> SaplingStateAbsent
- STBls12381G2 -> SaplingStateAbsent
- STTimestamp -> SaplingStateAbsent
- STAddress -> SaplingStateAbsent
- STChest -> SaplingStateAbsent
- STChestKey -> SaplingStateAbsent
- STNever -> SaplingStateAbsent
- STSaplingState _ -> SaplingStatePresent
- STSaplingTransaction _ -> SaplingStateAbsent
-
--- | Check at runtime that a value of the given type cannot contain operations.
-opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)
-opAbsense s = case checkOpPresence s of
- OpPresent -> Nothing
- OpAbsent -> Just Dict
-
--- | Check at runtime that a value of the given type cannot contain @contract@ values.
-contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t)
-contractTypeAbsense s = case checkContractTypePresence s of
- ContractPresent -> Nothing
- ContractAbsent -> Just Dict
-
--- | Check at runtime that a value of the given type cannot contain @ticket@ values.
-ticketAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoTicket t)
-ticketAbsense s = case checkTicketPresence s of
- TicketPresent -> Nothing
- TicketAbsent -> Just Dict
-
--- | Check at runtime that a value of the given type cannot containt @big_map@ values
-bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)
-bigMapAbsense s = case checkBigMapPresence s of
- BigMapPresent -> Nothing
- BigMapAbsent -> Just Dict
-
--- | Check at runtime that a value of the given type cannot containt @sapling_state@ values
-saplingStateAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoSaplingState t)
-saplingStateAbsense s = case checkSaplingStatePresence s of
- SaplingStatePresent -> Nothing
- SaplingStateAbsent -> Just Dict
-
--- | Check at runtime that a value of the given type cannot contain nested @big_map@s.
-nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t)
-nestedBigMapsAbsense s = case checkNestedBigMapsPresence s of
- NestedBigMapsPresent -> Nothing
- NestedBigMapsAbsent -> Just Dict
-
-----------------------------------------------------------------------------
--- Scopes
-----------------------------------------------------------------------------
-
-data BadTypeForScope
- = BtNotComparable
- | BtIsOperation
- | BtHasBigMap
- | BtHasNestedBigMap
- | BtHasContract
- | BtHasTicket
- | BtHasSaplingState
- deriving stock (Show, Eq, Generic)
- deriving anyclass (NFData)
-
-instance Buildable BadTypeForScope where
- build = buildRenderDoc
-
-instance RenderDoc BadTypeForScope where
- renderDoc _ = \case
- BtNotComparable -> "is not comparable"
- BtIsOperation -> "has 'operation' type"
- BtHasBigMap -> "has 'big_map'"
- BtHasNestedBigMap -> "has nested 'big_map'"
- BtHasContract -> "has 'contract' type"
- BtHasTicket -> "has 'ticket' type"
- BtHasSaplingState -> "has 'sapling_state' type"
-
--- | Set of constraints that Michelson applies to parameters.
---
--- Not just a type alias in order to be able to partially apply it
-class (SingI t, WellTyped t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t
-instance (SingI t, WellTyped t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t
-
--- | Set of constraints that Michelson applies to contract storage.
---
--- Not just a type alias in order to be able to partially apply it
-class (SingI t, WellTyped t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t
-instance (SingI t, WellTyped t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t
-
--- | Set of constraints that Michelson applies to pushed constants.
---
--- Not just a type alias in order to be able to partially apply it
-class (SingI t, WellTyped t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t, HasNoSaplingState t) => ConstantScope t
-instance (SingI t, WellTyped t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t, HasNoSaplingState t) => ConstantScope t
-
--- | Alias for constraints which Michelson requires in @DUP@ instruction.
-class (SingI t, HasNoTicket t) => DupableScope t
-instance (SingI t, HasNoTicket t) => DupableScope t
-
--- | Returns whether the type is dupable.
-type family IsDupableScope (t :: T) :: Bool where
- IsDupableScope t = Not (ContainsTicket t)
-
--- | Set of constraints that Michelson applies to packed values.
---
--- Not just a type alias in order to be able to partially apply it
-class (SingI t, WellTyped t, HasNoOp t, HasNoBigMap t, HasNoTicket t, HasNoSaplingState t) => PackedValScope t
-instance (SingI t, WellTyped t, HasNoOp t, HasNoBigMap t, HasNoTicket t, HasNoSaplingState t ) => PackedValScope t
-
--- | Set of constraints that Michelson applies to unpacked values.
---
--- It is different from 'PackedValScope', e.g. @contract@ type cannot appear
--- in a value we unpack to.
---
--- Not just a type alias in order to be able to partially apply it
-class (WellTyped t, PackedValScope t, ConstantScope t) => UnpackedValScope t
-instance (WellTyped t, PackedValScope t, ConstantScope t) => UnpackedValScope t
-
--- | Set of constraints that Michelson applies to argument type and
--- return type of views.
--- All info related to views can be found in
--- [TZIP](https://gitlab.com/tezos/tzip/-/blob/master/drafts/current/draft_views.md).
---
--- Not just a type alias in order to be able to partially apply it
-class (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => ViewableScope t
-instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => ViewableScope t
-
--- | Alias for constraints which are required for untyped representation.
-type UntypedValScope t = (SingI t, HasNoOp t)
-
-----------------------------------------------------------------------------
--- Conveniences
-----------------------------------------------------------------------------
-
--- | Should be present for common scopes.
-class CheckScope (c :: Constraint) where
- -- | Check that constraint hold for a given type.
- checkScope :: Either BadTypeForScope (Dict c)
-
-instance SingI t => CheckScope (WellTyped t) where
- checkScope = first nwtCause $ getWTP @t
-instance SingI t => CheckScope (HasNoOp t) where
- checkScope = maybeToRight BtIsOperation $ opAbsense sing
-instance SingI t => CheckScope (HasNoBigMap t) where
- checkScope = maybeToRight BtHasBigMap $ bigMapAbsense sing
-instance SingI t => CheckScope (HasNoNestedBigMaps t) where
- checkScope = maybeToRight BtHasNestedBigMap $ nestedBigMapsAbsense sing
-instance SingI t => CheckScope (HasNoContract t) where
- checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing
-instance SingI t => CheckScope (HasNoTicket t) where
- checkScope = maybeToRight BtHasTicket $ ticketAbsense sing
-instance SingI t => CheckScope (HasNoSaplingState t) where
- checkScope = maybeToRight BtHasSaplingState $ saplingStateAbsense sing
-instance SingI t => CheckScope (Comparable t) where
- checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing
-
--- | Alias for comparable types.
-class (SingI t, Comparable t) => ComparabilityScope t
-instance (SingI t, Comparable t) => ComparabilityScope t
-
-comparabilityPresence :: Sing t -> Maybe (Dict (Comparable t))
-comparabilityPresence s = case checkComparability s of
- CanBeCompared -> Just Dict
- CannotBeCompared -> Nothing
-
-instance SingI t => CheckScope (ParameterScope t) where
- checkScope =
- (\Dict Dict Dict -> Dict)
- <$> checkScope @(WellTyped t)
- <*> checkScope @(HasNoOp t)
- <*> checkScope @(HasNoNestedBigMaps t)
-
-instance SingI t => CheckScope (StorageScope t) where
- checkScope =
- (\Dict Dict Dict Dict -> Dict)
- <$> checkScope @(WellTyped t)
- <*> checkScope @(HasNoOp t)
- <*> checkScope @(HasNoNestedBigMaps t)
- <*> checkScope @(HasNoContract t)
-
-instance SingI t => CheckScope (ConstantScope t) where
- checkScope =
- (\Dict Dict Dict Dict Dict Dict -> Dict)
- <$> checkScope @(WellTyped t)
- <*> checkScope @(HasNoOp t)
- <*> checkScope @(HasNoBigMap t)
- <*> checkScope @(HasNoContract t)
- <*> checkScope @(HasNoTicket t)
- <*> checkScope @(HasNoSaplingState t)
-
-instance SingI t => CheckScope (DupableScope t) where
- checkScope =
- (\Dict -> Dict)
- <$> checkScope @(HasNoTicket t)
-
-instance SingI t => CheckScope (PackedValScope t) where
- checkScope =
- (\Dict Dict Dict Dict Dict -> Dict)
- <$> checkScope @(WellTyped t)
- <*> checkScope @(HasNoOp t)
- <*> checkScope @(HasNoBigMap t)
- <*> checkScope @(HasNoTicket t)
- <*> checkScope @(HasNoSaplingState t)
-
-instance SingI t => CheckScope (UnpackedValScope t) where
- checkScope =
- (\Dict Dict Dict -> Dict)
- <$> checkScope @(WellTyped t)
- <*> checkScope @(PackedValScope t)
- <*> checkScope @(ConstantScope t)
-
-instance SingI t => CheckScope (ViewableScope t) where
- checkScope =
- (\Dict Dict Dict -> Dict)
- <$> checkScope @(HasNoOp t)
- <*> checkScope @(HasNoBigMap t)
- <*> checkScope @(HasNoTicket t)
-
-instance SingI t => CheckScope (ComparabilityScope t) where
- checkScope =
- (\Dict -> Dict) <$> checkScope @(Comparable t)
-
-instance (CheckScope a, CheckScope b) => CheckScope (a, b) where
- checkScope = do
- Dict <- checkScope @a
- Dict <- checkScope @b
- pure Dict
-
--- | Allows using a scope that can be proven true with a De Morgan law.
---
--- Many scopes are defined as @not a@ (or rather @a ~ 'False@) where @a@ is a
--- negative property we want to avoid as a 'Constraint'.
--- The negative constraints are implemented with a type family that for some
--- combination types resolves to itself applied to the type arguments in an @or@,
--- e.g. A @pair l r@ has @x@ if @l@ or @r@ contain @x@.
---
--- Because of the De Morgan laws @not (a or b)@ implies @(not a) and (not b)@
--- or in our case: @pair@ does not contain @x@ -> @a@ and @b@ don't contain @x@.
-class WithDeMorganScope (c :: T -> Constraint) t a b where
- withDeMorganScope :: c (t a b) => ((c a, c b) => ret) -> ret
-
--- | Produce evidence that the first argument of a disjunction
--- is false if the whole disjunction is false.
-orL :: forall a b. (a || b) ~ 'False => Sing a -> a :~: 'False
-orL SFalse = Refl
-{-# NOINLINE [1] orL #-}
-
--- This rule is *slightly* illegitimate, because the right hand side is lazier
--- than the left hand side. In context, this is fine, and we really *want* to
--- do it so we have at least some hope of avoiding building singletons that we
--- don't end up using. We'd get a totally legitimate rule if we used a SingI
--- constraint instead of a Sing argument, but then we'd need to use withSingI,
--- which for some reason doesn't use the newfangled GHC machinery for such and
--- therefore risks gumming up optimization. Of course, we could roll our own
--- withSingI, but that's very hairy and GHC version dependent (the
--- never-really-documented magicDict was recently replaced by withDict, which
--- is documented in ... the type checker source code, apparently).
-{-# RULES
-"orL" forall s. orL s = unsafeCoerce Refl
- #-}
-
--- | When a class looks like
---
--- @
--- class (SomeTypeFamily t ~ 'False, ...) => TheClass t
--- instance (SomeTypeFamily t ~ 'False, ...) => TheClass t
--- @
---
--- and the additional constraints are satisfied by the instance constraints of
--- the 'WithDeMorganScope' instance for @TheClass@, we can use
--- `simpleWithDeMorgan` to define 'withDeMorganScope' for the instance.
-simpleWithDeMorgan
- :: forall sym a b ret.
- ((sym @@ a || sym @@ b) ~ 'False, SingI sym, SingI a)
- => (((sym @@ a) ~ 'False, (sym @@ b) ~ 'False) => ret) -> ret
--- Note: If the "orL" rule fires (which it should), we won't actually calculate
--- the (likely recursive) `sing @sym @@ sing @a` at all. If we're lucky, GHC
--- might not build the `SingI a` dictionary either.
-simpleWithDeMorgan f
- | Refl <- orL @(sym @@ a) @(sym @@ b) (sing @sym @@ sing @a)
- = f
-
-data ContainsOpSym :: T ~> Bool
-type instance Apply ContainsOpSym x = ContainsOp x
-instance SingI ContainsOpSym where
- sing = SLambda $ \t -> case checkOpPresence t of
- OpPresent -> STrue
- OpAbsent -> SFalse
-instance SingI a => WithDeMorganScope HasNoOp 'TPair a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsOpSym @a @b f
-instance SingI a => WithDeMorganScope HasNoOp 'TOr a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsOpSym @a @b f
-instance SingI k => WithDeMorganScope HasNoOp 'TMap k v where
- withDeMorganScope f = simpleWithDeMorgan @ContainsOpSym @k @v f
-instance SingI k => WithDeMorganScope HasNoOp 'TBigMap k v where
- withDeMorganScope f = simpleWithDeMorgan @ContainsOpSym @k @v f
-
-data ContainsContractSym :: T ~> Bool
-type instance Apply ContainsContractSym x = ContainsContract x
-instance SingI ContainsContractSym where
- sing = SLambda $ \t -> case checkContractTypePresence t of
- ContractPresent -> STrue
- ContractAbsent -> SFalse
-instance SingI a => WithDeMorganScope HasNoContract 'TPair a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsContractSym @a @b f
-instance SingI a => WithDeMorganScope HasNoContract 'TOr a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsContractSym @a @b f
-
-data ContainsTicketSym :: T ~> Bool
-type instance Apply ContainsTicketSym x = ContainsTicket x
-instance SingI ContainsTicketSym where
- sing = SLambda $ \t -> case checkTicketPresence t of
- TicketPresent -> STrue
- TicketAbsent -> SFalse
-instance SingI a => WithDeMorganScope HasNoTicket 'TPair a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsTicketSym @a @b f
-instance SingI a => WithDeMorganScope HasNoTicket 'TOr a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsTicketSym @a @b f
-
-data ContainsBigMapSym :: T ~> Bool
-type instance Apply ContainsBigMapSym x = ContainsBigMap x
-instance SingI ContainsBigMapSym where
- sing = SLambda $ \t -> case checkBigMapPresence t of
- BigMapPresent -> STrue
- BigMapAbsent -> SFalse
-instance SingI a => WithDeMorganScope HasNoBigMap 'TPair a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsBigMapSym @a @b f
-instance SingI a => WithDeMorganScope HasNoBigMap 'TOr a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsBigMapSym @a @b f
-
-data ContainsNestedBigMapsSym :: T ~> Bool
-type instance Apply ContainsNestedBigMapsSym x = ContainsNestedBigMaps x
-instance SingI ContainsNestedBigMapsSym where
- sing = SLambda $ \t -> case checkNestedBigMapsPresence t of
- NestedBigMapsPresent -> STrue
- NestedBigMapsAbsent -> SFalse
-instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TPair a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsNestedBigMapsSym @a @b f
-instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TOr a b where
- withDeMorganScope f = simpleWithDeMorgan @ContainsNestedBigMapsSym @a @b f
-
-instance
- ( WithDeMorganScope HasNoOp t a b
- , WithDeMorganScope HasNoNestedBigMaps t a b
- , WellTyped a, WellTyped b
- ) => WithDeMorganScope ParameterScope t a b where
- withDeMorganScope f =
- withDeMorganScope @HasNoOp @t @a @b $
- withDeMorganScope @HasNoNestedBigMaps @t @a @b f
-
-instance
- ( WithDeMorganScope HasNoOp t a b
- , WithDeMorganScope HasNoNestedBigMaps t a b
- , WithDeMorganScope HasNoContract t a b
- , WellTyped a, WellTyped b
- ) => WithDeMorganScope StorageScope t a b where
- withDeMorganScope f =
- withDeMorganScope @HasNoOp @t @a @b $
- withDeMorganScope @HasNoNestedBigMaps @t @a @b $
- withDeMorganScope @HasNoContract @t @a @b f
-
-instance
- ( WithDeMorganScope HasNoOp t a b
- , WithDeMorganScope HasNoBigMap t a b
- , WithDeMorganScope HasNoContract t a b
- , WithDeMorganScope HasNoTicket t a b
- , WithDeMorganScope HasNoSaplingState t a b
- , WellTyped a, WellTyped b
- ) => WithDeMorganScope ConstantScope t a b where
- withDeMorganScope f =
- withDeMorganScope @HasNoOp @t @a @b $
- withDeMorganScope @HasNoBigMap @t @a @b $
- withDeMorganScope @HasNoContract @t @a @b $
- withDeMorganScope @HasNoTicket @t @a @b $
- withDeMorganScope @HasNoSaplingState @t @a @b f
-
-instance
- ( WithDeMorganScope HasNoOp t a b
- , WithDeMorganScope HasNoBigMap t a b
- , WithDeMorganScope HasNoTicket t a b
- , WithDeMorganScope HasNoSaplingState t a b
- , WellTyped a, WellTyped b
- ) => WithDeMorganScope PackedValScope t a b where
- withDeMorganScope f =
- withDeMorganScope @HasNoOp @t @a @b $
- withDeMorganScope @HasNoBigMap @t @a @b $
- withDeMorganScope @HasNoTicket @t @a @b $
- withDeMorganScope @HasNoSaplingState @t @a @b f
-
-instance
- ( WithDeMorganScope PackedValScope t a b
- , WithDeMorganScope ConstantScope t a b
- , WellTyped a, WellTyped b
- ) => WithDeMorganScope UnpackedValScope t a b where
- withDeMorganScope f =
- withDeMorganScope @PackedValScope @t @a @b $
- withDeMorganScope @ConstantScope @t @a @b f
-
--- Versions for eDSL
-----------------------------------------------------------------------------
-
-{- These constraints are supposed to be used only in eDSL code and eDSL should
-define its own wrapers over it.
--}
-
-type ProperParameterBetterErrors t =
- (SingI t, WellTyped t, ForbidOp t, ForbidNestedBigMaps t)
-
-type ProperStorageBetterErrors t =
- (SingI t, WellTyped t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)
-
-type ProperConstantBetterErrors t =
- (SingI t, WellTyped t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t, ForbidSaplingState t)
-
-type ProperDupableBetterErrors t =
- (SingI t, ForbidTicket t)
-
-type ProperPackedValBetterErrors t =
- (SingI t, WellTyped t, ForbidOp t, ForbidBigMap t, ForbidTicket t, ForbidSaplingState t)
-
-type ProperUnpackedValBetterErrors t =
- (ProperPackedValBetterErrors t, ProperConstantBetterErrors t)
-
-type ProperViewableBetterErrors t =
- (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket t)
-
-type ProperUntypedValBetterErrors t =
- (SingI t, ForbidOp t)
-
-type ProperNonComparableValBetterErrors t =
- (SingI t, ForbidNonComparable t)
-
-class (IsComparable t ~ 'True, SingI t, ComparableSuperC t) => Comparable t where
- -- | Constraints required for instance of a given type.
- type ComparableSuperC t :: Constraint
- type ComparableSuperC _ = ()
-
-instance ComparableSuperC ('TPair t1 t2) => Comparable ('TPair t1 t2) where
- type ComparableSuperC ('TPair t1 t2) =
- (Comparable t1, Comparable t2, ForbidNonComparable t1, ForbidNonComparable t2)
-
-instance ComparableSuperC ('TOr t1 t2) => Comparable ('TOr t1 t2) where
- type ComparableSuperC ('TOr t1 t2) =
- (Comparable t1, Comparable t2, ForbidNonComparable t1, ForbidNonComparable t2)
-
-instance ComparableSuperC ('TOption t) => Comparable ('TOption t) where
- type ComparableSuperC ('TOption t) = (Comparable t, ForbidNonComparable t)
-
-instance Comparable 'TUnit
-instance Comparable 'TInt
-instance Comparable 'TNat
-instance Comparable 'TString
-instance Comparable 'TBytes
-instance Comparable 'TMutez
-instance Comparable 'TBool
-instance Comparable 'TKeyHash
-instance Comparable 'TTimestamp
-instance Comparable 'TAddress
-instance Comparable 'TNever
-instance Comparable 'TChainId
-instance Comparable 'TSignature
-instance Comparable 'TKey
-
--- | This class encodes Michelson rules w.r.t where it requires comparable
--- types. Earlier we had a dedicated type for representing comparable types @CT@.
--- But then we integreated those types into @T@. This meant that some of the
--- types that could be formed with various combinations of @T@ would be
--- illegal as per Michelson typing rule. Using this class, we inductively
--- enforce that a type and all types it contains are well typed as per
--- Michelson's rules.
-class (SingI t, WellTypedSuperC t) => WellTyped (t :: T) where
- -- | Constraints required for instance of a given type.
- type WellTypedSuperC t :: Constraint
- type WellTypedSuperC _ = ()
-
-instance WellTyped 'TKey
-instance WellTyped 'TUnit
-instance WellTyped 'TNever
-instance WellTyped 'TSignature
-instance WellTyped 'TChainId
-instance WellTyped 'TChest
-instance WellTyped 'TChestKey
-
-instance WellTypedSuperC ('TOption t) => WellTyped ('TOption t) where
- type WellTypedSuperC ('TOption t) = WellTyped t
-
-instance WellTypedSuperC ('TList t) => WellTyped ('TList t) where
- type WellTypedSuperC ('TList t) = WellTyped t
-
-instance WellTypedSuperC ('TSet t) => WellTyped ('TSet t) where
- type WellTypedSuperC ('TSet t) = (Comparable t, WellTyped t)
-
-instance WellTyped 'TOperation
-
-instance WellTypedSuperC ('TContract t) => WellTyped ('TContract t) where
- type WellTypedSuperC ('TContract t) = (WellTyped t, HasNoOp t, HasNoNestedBigMaps t)
-
-instance WellTypedSuperC ('TTicket t) => WellTyped ('TTicket t) where
- type WellTypedSuperC ('TTicket t) = (WellTyped t, Comparable t)
-
-instance WellTypedSuperC ('TPair t1 t2) => WellTyped ('TPair t1 t2) where
- type WellTypedSuperC ('TPair t1 t2) = (WellTyped t1, WellTyped t2)
-
-instance WellTypedSuperC ('TOr t1 t2) => WellTyped ('TOr t1 t2) where
- type WellTypedSuperC ('TOr t1 t2) = (WellTyped t1, WellTyped t2)
-
-instance WellTypedSuperC ('TLambda t1 t2) => WellTyped ('TLambda t1 t2) where
- type WellTypedSuperC ('TLambda t1 t2) = (WellTyped t1, WellTyped t2)
-
-instance WellTypedSuperC ('TMap k v) => WellTyped ('TMap k v) where
- type WellTypedSuperC ('TMap k v) = (Comparable k, WellTyped k, WellTyped v)
-
-instance WellTypedSuperC ('TBigMap k v) => WellTyped ('TBigMap k v) where
- type WellTypedSuperC ('TBigMap k v) = ( Comparable k, WellTyped k, WellTyped v
- , HasNoBigMap v, HasNoOp v)
-
-instance WellTyped 'TInt
-instance WellTyped 'TNat
-instance WellTyped 'TString
-instance WellTyped 'TBytes
-instance WellTyped 'TMutez
-instance WellTyped 'TBool
-instance WellTyped 'TKeyHash
-instance WellTyped 'TBls12381Fr
-instance WellTyped 'TBls12381G1
-instance WellTyped 'TBls12381G2
-instance WellTyped 'TTimestamp
-instance WellTyped 'TAddress
-
-instance (SingI n) => WellTyped ('TSaplingState n) where
- type WellTypedSuperC ('TSaplingState n) = (SingI n)
-
-instance (SingI n) => WellTyped ('TSaplingTransaction n) where
- type WellTypedSuperC ('TSaplingTransaction n) = (SingI n)
-
--- | Error type for when a value is not well-typed.
-data NotWellTyped = NotWellTyped
- { nwtBadType :: T
- , nwtCause :: BadTypeForScope
- }
-
-instance Buildable NotWellTyped where
- build (NotWellTyped t c) =
- "Given type is not well typed because '" <> (build t) <> "' " <> (build c)
-
-data Comparability t where
- CanBeCompared :: (Comparable t) => Comparability t
- CannotBeCompared :: (IsComparable t ~ 'False) => Comparability t
-
--- | Given a type, provide evidence that it is well typed w.r.t to the
--- Michelson rules regarding where comparable types are required.
-getWTP :: forall t. (SingI t) => Either NotWellTyped (Dict (WellTyped t))
-getWTP = getWTP' sing
-
--- | Version of 'getWTP' that accepts 'Sing' at term-level.
-getWTP' :: Sing t -> Either NotWellTyped (Dict (WellTyped t))
-getWTP' = \case
- STKey -> Right Dict
- STUnit -> Right Dict
- STSignature -> Right Dict
- STChainId -> Right Dict
- STOption s -> do
- Dict <- getWTP' s
- pure Dict
- STList s -> do
- Dict <- getWTP' s
- pure Dict
- STSet s -> do
- Dict <- getWTP' s
- Dict <- eitherWellTyped BtNotComparable getComparableProofS s
- pure Dict
- STOperation -> Right Dict
- STContract s -> do
- Dict <- getWTP' s
- Dict <- eitherWellTyped BtIsOperation opAbsense s
- Dict <- eitherWellTyped BtHasNestedBigMap nestedBigMapsAbsense s
- pure Dict
- STTicket s -> do
- Dict <- getWTP' s
- Dict <- eitherWellTyped BtNotComparable getComparableProofS s
- pure Dict
- STPair s1 s2 -> do
- Dict <- getWTP' s1
- Dict <- getWTP' s2
- pure Dict
- STOr s1 s2 -> do
- Dict <- getWTP' s1
- Dict <- getWTP' s2
- pure Dict
- STLambda s1 s2 -> do
- Dict <- getWTP' s1
- Dict <- getWTP' s2
- pure Dict
- STMap s1 s2 -> do
- Dict <- getWTP' s1
- Dict <- getWTP' s2
- Dict <- eitherWellTyped BtNotComparable getComparableProofS s1
- pure Dict
- STBigMap s1 s2 -> do
- Dict <- getWTP' s1
- Dict <- getWTP' s2
- Dict <- eitherWellTyped BtNotComparable getComparableProofS s1
- Dict <- eitherWellTyped BtIsOperation opAbsense s2
- Dict <- eitherWellTyped BtHasBigMap bigMapAbsense s2
- pure Dict
- STInt -> Right Dict
- STNat -> Right Dict
- STString -> Right Dict
- STBytes -> Right Dict
- STMutez -> Right Dict
- STBool -> Right Dict
- STKeyHash -> Right Dict
- STBls12381Fr -> Right Dict
- STBls12381G1 -> Right Dict
- STBls12381G2 -> Right Dict
- STTimestamp -> Right Dict
- STAddress -> Right Dict
- STChest -> Right Dict
- STChestKey -> Right Dict
- STNever -> Right Dict
- STSaplingState s -> withSingI s $ Right Dict
- STSaplingTransaction s -> withSingI s $ Right Dict
- where
- eitherWellTyped
- :: BadTypeForScope
- -> (Sing (ty :: T) -> Maybe a)
- -> Sing (ty :: T)
- -> Either NotWellTyped a
- eitherWellTyped bt sf sng = maybeToRight (NotWellTyped (fromSing sng) bt) $ sf sng
-
-getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))
-getComparableProofS s = case checkComparability s of
- CanBeCompared -> Just Dict
- CannotBeCompared -> Nothing
-
-checkComparability :: Sing t -> Comparability t
-checkComparability = \case
- STPair a b -> case (checkComparability a, checkComparability b) of
- (CanBeCompared, CanBeCompared) -> CanBeCompared
- (CannotBeCompared, _) -> CannotBeCompared
- (_, CannotBeCompared) -> CannotBeCompared
- STOr a b -> case (checkComparability a, checkComparability b) of
- (CanBeCompared, CanBeCompared) -> CanBeCompared
- (CannotBeCompared, _) -> CannotBeCompared
- (_, CannotBeCompared) -> CannotBeCompared
- STOption t -> case checkComparability t of
- CanBeCompared -> CanBeCompared
- CannotBeCompared -> CannotBeCompared
- STList _ -> CannotBeCompared
- STSet _ -> CannotBeCompared
- STOperation -> CannotBeCompared
- STContract _ -> CannotBeCompared
- STTicket _ -> CannotBeCompared
- STLambda _ _ -> CannotBeCompared
- STMap _ _ -> CannotBeCompared
- STBigMap _ _ -> CannotBeCompared
- STNever -> CanBeCompared
- STUnit -> CanBeCompared
- STInt -> CanBeCompared
- STNat -> CanBeCompared
- STString -> CanBeCompared
- STBytes -> CanBeCompared
- STMutez -> CanBeCompared
- STBool -> CanBeCompared
- STKeyHash -> CanBeCompared
- STBls12381Fr -> CannotBeCompared
- STBls12381G1 -> CannotBeCompared
- STBls12381G2 -> CannotBeCompared
- STTimestamp -> CanBeCompared
- STAddress -> CanBeCompared
- STKey -> CanBeCompared
- STSignature -> CanBeCompared
- STChainId -> CanBeCompared
- STChest -> CannotBeCompared
- STChestKey -> CannotBeCompared
- STSaplingState _ -> CannotBeCompared
- STSaplingTransaction _ -> CannotBeCompared
-
--- | Inductive proof that 'Comparable' implies 'HasNoNestedBigMaps'. This is
--- stubbed with an @unsafeCoerce Refl@ at runtime to avoid runtime traversals.
-comparabilityImpliesNoNestedBigMaps
- :: forall t. (SingI t, IsComparable t ~ 'True) => ContainsNestedBigMaps t :~: 'False
-comparabilityImpliesNoNestedBigMaps = stubProof $ go (sing @t)
- where
- go :: IsComparable a ~ 'True => Sing a -> ContainsNestedBigMaps a :~: 'False
- go = \case
- STPair (a :: Sing a) (b :: Sing b) -> case (checkComparability a, checkComparability b) of
- (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
- STOr a b -> case (checkComparability a, checkComparability b) of
- (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
- STOption t -> Refl \\ go t
- STNever -> Refl
- STUnit -> Refl
- STInt -> Refl
- STNat -> Refl
- STString -> Refl
- STBytes -> Refl
- STMutez -> Refl
- STBool -> Refl
- STKeyHash -> Refl
- STTimestamp -> Refl
- STAddress -> Refl
- STKey -> Refl
- STSignature -> Refl
- STChainId -> Refl
-
--- | Inductive proof that 'Comparable' implies 'HasNoOp'. This is
--- stubbed with an @unsafeCoerce Refl@ at runtime to avoid runtime traversals.
-comparabilityImpliesNoOp
- :: forall t. (SingI t, IsComparable t ~ 'True) => ContainsOp t :~: 'False
-comparabilityImpliesNoOp = stubProof $ go (sing @t)
- where
- go :: IsComparable a ~ 'True => Sing a -> ContainsOp a :~: 'False
- go = \case
- STPair (a :: Sing a) (b :: Sing b) -> case (checkComparability a, checkComparability b) of
- (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
- STOr a b -> case (checkComparability a, checkComparability b) of
- (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
- STOption t -> Refl \\ go t
- STNever -> Refl
- STUnit -> Refl
- STInt -> Refl
- STNat -> Refl
- STString -> Refl
- STBytes -> Refl
- STMutez -> Refl
- STBool -> Refl
- STKeyHash -> Refl
- STTimestamp -> Refl
- STAddress -> Refl
- STKey -> Refl
- STSignature -> Refl
- STChainId -> Refl
+{- | Module, containing restrictions imposed by instruction or value scope.
+
+Michelson have multiple restrictions on values, examples:
+
+* @operation@ type cannot appear in parameter.
+* @big_map@ type cannot appear in @PUSH@-able constants.
+* @contract@ type cannot appear in type we @UNPACK@ to.
+
+Thus we declare multiple "scopes" - constraints applied in corresponding
+situations, for instance
+
+* 'ParameterScope';
+* 'StorageScope';
+* 'ConstantScope'.
+
+Also we separate multiple "classes" of scope-related constraints.
+
+* 'ParameterScope' and similar ones are used within Michelson engine,
+they are understandable by GHC and produce human-readable errors.
+
+* Lorentz and other eDSLs may declare their own constraints, in most cases
+you should use them. For example see @Lorentz.Constraints@ module.
+
+-}
+
+module Morley.Michelson.Typed.Scope
+ ( -- * Scopes
+ ConstantScope
+ , DupableScope
+ , StorageScope
+ , PackedValScope
+ , ParameterScope
+ , UntypedValScope
+ , UnpackedValScope
+ , ViewableScope
+ , ComparabilityScope
+
+ , IsDupableScope
+
+ , BadTypeForScope (..)
+ , CheckScope (..)
+ , WithDeMorganScope (..)
+ , deMorganForbidT
+ , Comparable
+ , comparableImplies
+ , WellTyped
+ , NotWellTyped (..)
+
+ -- * Implementation internals
+ , ContainsT
+ , IsComparable
+
+ , ForbidT
+ , ForbidOp
+ , ForbidContract
+ , ForbidTicket
+ , ForbidBigMap
+ , ForbidNestedBigMaps
+ , ForbidNonComparable
+
+ , TPresence(..
+ , OpPresent, OpAbsent
+ , ContractPresent, ContractAbsent
+ , TicketPresent, TicketAbsent
+ , BigMapPresent, BigMapAbsent
+ , NestedBigMapsPresent, NestedBigMapsAbsent
+ , SaplingStatePresent, SaplingStateAbsent
+ )
+ , TPredicateSym(..)
+ , SingTPredicateSym(..)
+ , checkTPresence
+ , tPresence
+ , tAbsence
+
+ , Comparability(..)
+ , checkComparability
+ , comparabilityPresence
+
+ , getWTP
+ , getWTP'
+ -- * Re-exports
+ , withDict
+ , SingI (..)
+ , (:-)(..)
+ -- * Deprecated
+ , OpPresence
+ , ContractPresence
+ , TicketPresence
+ , BigMapPresence
+ , NestedBigMapsPresence
+ , ProperParameterBetterErrors
+ , ProperStorageBetterErrors
+ , ProperConstantBetterErrors
+ , ProperDupableBetterErrors
+ , ProperPackedValBetterErrors
+ , ProperUnpackedValBetterErrors
+ , ProperUntypedValBetterErrors
+ , ProperViewableBetterErrors
+ , ProperNonComparableValBetterErrors
+ , opAbsense
+ , contractTypeAbsense
+ , bigMapAbsense
+ , nestedBigMapsAbsense
+ , checkOpPresence
+ , checkContractTypePresence
+ , checkTicketPresence
+ , checkBigMapPresence
+ , checkNestedBigMapsPresence
+ , HasNoBigMap
+ , HasNoNestedBigMaps
+ , HasNoOp
+ , HasNoContract
+ , HasNoTicket
+ , ContainsBigMap
+ , ContainsContract
+ , ContainsNestedBigMaps
+ , ContainsOp
+ , ContainsTicket
+ , comparabilityImpliesNoNestedBigMaps
+ , comparabilityImpliesNoOp
+ , getComparableProofS
+ ) where
+
+import Data.Constraint (withDict, (:-)(..))
+import Data.Singletons (SingI(..))
+
+import Morley.Michelson.Typed.Scope.Internal.CheckScope
+import Morley.Michelson.Typed.Scope.Internal.Comparable
+import Morley.Michelson.Typed.Scope.Internal.Deprecated
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.Presence
+import Morley.Michelson.Typed.Scope.Internal.Scopes
+import Morley.Michelson.Typed.Scope.Internal.WellTyped
+import Morley.Michelson.Typed.Scope.Internal.WithDeMorganScope
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/CheckScope.hs b/src/Morley/Michelson/Typed/Scope/Internal/CheckScope.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/CheckScope.hs
@@ -0,0 +1,102 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.CheckScope
+ ( module Morley.Michelson.Typed.Scope.Internal.CheckScope
+ ) where
+
+import Data.Constraint (Dict(..))
+import Data.Singletons (SingI(..))
+
+import Data.Type.Equality ((:~:)(..))
+import Morley.Michelson.Typed.Scope.Internal.Comparable
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.Presence
+import Morley.Michelson.Typed.Scope.Internal.Scopes
+import Morley.Michelson.Typed.Scope.Internal.WellTyped
+
+-- | Should be present for common scopes.
+class CheckScope (c :: Constraint) where
+ -- | Check that constraint hold for a given type.
+ checkScope :: Either BadTypeForScope (Dict c)
+
+instance SingI t => CheckScope (WellTyped t) where
+ checkScope = first nwtCause $ getWTP @t
+instance SingI t => CheckScope (ForbidOp t) where
+ checkScope = maybeToRight BtIsOperation $ fmap (\Refl -> Dict) $ tAbsence SPSOp $ sing @t
+instance SingI t => CheckScope (ForbidBigMap t) where
+ checkScope = maybeToRight BtHasBigMap $ fmap (\Refl -> Dict) $ tAbsence SPSBigMap $ sing @t
+instance SingI t => CheckScope (ForbidNestedBigMaps t) where
+ checkScope = maybeToRight BtHasNestedBigMap $ fmap (\Refl -> Dict) $ tAbsence SPSNestedBigMaps $ sing @t
+instance SingI t => CheckScope (ForbidContract t) where
+ checkScope = maybeToRight BtHasContract $ fmap (\Refl -> Dict) $ tAbsence SPSContract $ sing @t
+instance SingI t => CheckScope (ForbidTicket t) where
+ checkScope = maybeToRight BtHasTicket $ fmap (\Refl -> Dict) $ tAbsence SPSTicket $ sing @t
+instance SingI t => CheckScope (ForbidSaplingState t) where
+ checkScope = maybeToRight BtHasSaplingState $ fmap (\Refl -> Dict) $ tAbsence SPSSaplingState $ sing @t
+instance SingI t => CheckScope (Comparable t) where
+ checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing
+
+instance SingI t => CheckScope (ParameterScope t) where
+ checkScope = do
+ Dict <- checkScope @(WellTyped t)
+ Dict <- checkScope @(ForbidOp t)
+ Dict <- checkScope @(ForbidNestedBigMaps t)
+ pure Dict
+
+instance SingI t => CheckScope (StorageScope t) where
+ checkScope = do
+ Dict <- checkScope @(WellTyped t)
+ Dict <- checkScope @(ForbidOp t)
+ Dict <- checkScope @(ForbidNestedBigMaps t)
+ Dict <- checkScope @(ForbidContract t)
+ pure Dict
+
+instance SingI t => CheckScope (ConstantScope t) where
+ checkScope = do
+ Dict <- checkScope @(WellTyped t)
+ Dict <- checkScope @(ForbidOp t)
+ Dict <- checkScope @(ForbidBigMap t)
+ Dict <- checkScope @(ForbidContract t)
+ Dict <- checkScope @(ForbidTicket t)
+ Dict <- checkScope @(ForbidSaplingState t)
+ pure Dict
+
+instance SingI t => CheckScope (DupableScope t) where
+ checkScope = do
+ Dict <- checkScope @(ForbidTicket t)
+ pure Dict
+
+instance SingI t => CheckScope (PackedValScope t) where
+ checkScope = do
+ Dict <- checkScope @(WellTyped t)
+ Dict <- checkScope @(ForbidOp t)
+ Dict <- checkScope @(ForbidBigMap t)
+ Dict <- checkScope @(ForbidTicket t)
+ Dict <- checkScope @(ForbidSaplingState t)
+ pure Dict
+
+instance SingI t => CheckScope (UnpackedValScope t) where
+ checkScope = do
+ Dict <- checkScope @(ConstantScope t)
+ pure Dict
+
+instance SingI t => CheckScope (ViewableScope t) where
+ checkScope = do
+ Dict <- checkScope @(ForbidOp t)
+ Dict <- checkScope @(ForbidBigMap t)
+ Dict <- checkScope @(ForbidTicket t)
+ pure Dict
+
+instance SingI t => CheckScope (ComparabilityScope t) where
+ checkScope = do
+ Dict <- checkScope @(Comparable t)
+ pure Dict
+
+instance (CheckScope a, CheckScope b) => CheckScope (a, b) where
+ checkScope = do
+ Dict <- checkScope @a
+ Dict <- checkScope @b
+ pure Dict
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/Comparable.hs b/src/Morley/Michelson/Typed/Scope/Internal/Comparable.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/Comparable.hs
@@ -0,0 +1,146 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.Comparable
+ ( module Morley.Michelson.Typed.Scope.Internal.Comparable
+ ) where
+
+import Data.Constraint (Dict(..), (\\))
+import Data.Singletons (Sing, SingI(..))
+import Data.Type.Equality ((:~:)(..))
+
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Sing (SingT(..))
+import Morley.Michelson.Typed.T (T(..))
+import Morley.Util.StubbedProof
+
+{- $setup
+>>> import Morley.Michelson.Typed
+-}
+
+data Comparability t where
+ CanBeCompared :: (Comparable t, ComparabilityImplies t) => Comparability t
+ CannotBeCompared :: (ContainsT 'PSNonComparable t ~ 'True) => Comparability t
+deriving stock instance Show (Comparability t)
+
+-- | Constraints implied by 'Comparable'. This is a little expensive to carry as
+-- the superclass of 'Comparable', hence these can be brought into scope on
+-- demand using 'comparableImplies'.
+type ComparabilityImplies t =
+ ( ForbidOp t
+ , ForbidNestedBigMaps t
+ , ForbidTicket t
+ , ForbidSaplingState t
+ , ForbidBigMap t
+ , ForbidContract t
+ , ForbidNonComparable t
+ )
+
+-- | Produce 'ComparabilityImplies' on demand. Carrying it as 'Comparable'
+-- superclasses turns out to be a little expensive, considering we can produce
+-- evidence on demand in O(1).
+comparableImplies
+ :: forall t proxy. ForbidNonComparable t
+ => proxy t -> Dict (ComparabilityImplies t)
+comparableImplies _ = Dict
+ \\ proofImplOne SPSOp
+ \\ proofImplOne SPSNestedBigMaps
+ \\ proofImplOne SPSBigMap
+ \\ proofImplOne SPSTicket
+ \\ proofImplOne SPSSaplingState
+ \\ proofImplOne SPSContract
+ where
+ proofImplOne :: Sing p -> ContainsT p t :~: 'False
+ proofImplOne sp = stubProof $ case checkComparability (assumeSing @t) of
+ -- NB: using assumeSing isn't strictly safe in the sense that one can get
+ -- unsafeCoerce out of an ill-behaved t and assumeSing, but
+ -- ForbidNonComparable traverses t. So if it's not stuck, t is
+ -- well-behaved enough for our purposes here, and we can get by witout
+ -- requiring SingI.
+ CanBeCompared -> case sp of
+ SPSOp -> Refl
+ SPSContract -> Refl
+ SPSTicket -> Refl
+ SPSBigMap -> Refl
+ SPSNestedBigMaps -> Refl
+ SPSSaplingState -> Refl
+ SPSNonComparable -> Refl
+
+-- | Enforce recursive superclass constraints.
+type RecSuperC :: (T -> Constraint) -> T -> Constraint
+type family RecSuperC c t where
+ RecSuperC c (_ t1 t2) = (c t1, c t2)
+ RecSuperC c (_ t) = c t
+ RecSuperC _ _ = ()
+
+type Comparable :: T -> Constraint
+class (SingI t, RecSuperC Comparable t, ForbidNonComparable t) => Comparable t
+instance (SingI t, RecSuperC Comparable t, ForbidNonComparable t) => Comparable t
+
+{- | Check if type is comparable or not at runtime. This traverses the
+singleton, so it has a considerable runtime cost. If you just need to convince
+GHC, you may be looking for 'comparableImplies', or perhaps
+@withDeMorganScope@.
+
+>>> checkComparability STOperation
+CannotBeCompared
+>>> checkComparability STAddress
+CanBeCompared
+-}
+checkComparability :: Sing t -> Comparability t
+checkComparability = \case
+ STPair a b -> case (checkComparability a, checkComparability b) of
+ (CanBeCompared, CanBeCompared) -> CanBeCompared
+ (CannotBeCompared, _) -> CannotBeCompared
+ (_, CannotBeCompared) -> CannotBeCompared
+ STOr a b -> case (checkComparability a, checkComparability b) of
+ (CanBeCompared, CanBeCompared) -> CanBeCompared
+ (CannotBeCompared, _) -> CannotBeCompared
+ (_, CannotBeCompared) -> CannotBeCompared
+ STOption t -> case checkComparability t of
+ CanBeCompared -> CanBeCompared
+ CannotBeCompared -> CannotBeCompared
+ STList _ -> CannotBeCompared
+ STSet _ -> CannotBeCompared
+ STOperation -> CannotBeCompared
+ STContract _ -> CannotBeCompared
+ STTicket _ -> CannotBeCompared
+ STLambda _ _ -> CannotBeCompared
+ STMap _ _ -> CannotBeCompared
+ STBigMap _ _ -> CannotBeCompared
+ STNever -> CanBeCompared
+ STUnit -> CanBeCompared
+ STInt -> CanBeCompared
+ STNat -> CanBeCompared
+ STString -> CanBeCompared
+ STBytes -> CanBeCompared
+ STMutez -> CanBeCompared
+ STBool -> CanBeCompared
+ STKeyHash -> CanBeCompared
+ STBls12381Fr -> CannotBeCompared
+ STBls12381G1 -> CannotBeCompared
+ STBls12381G2 -> CannotBeCompared
+ STTimestamp -> CanBeCompared
+ STAddress -> CanBeCompared
+ STKey -> CanBeCompared
+ STSignature -> CanBeCompared
+ STChainId -> CanBeCompared
+ STChest -> CannotBeCompared
+ STChestKey -> CannotBeCompared
+ STSaplingState _ -> CannotBeCompared
+ STSaplingTransaction _ -> CannotBeCompared
+
+{- | Check if type is comparable or not at runtime. This is a @Dict@ version of
+'checkComparability', so the same caveats apply.
+
+>>> comparabilityPresence STOperation
+Nothing
+>>> comparabilityPresence STAddress
+Just Dict
+-}
+comparabilityPresence :: Sing t -> Maybe (Dict (Comparable t))
+comparabilityPresence s = case checkComparability s of
+ CanBeCompared -> Just Dict
+ CannotBeCompared -> Nothing
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/Deprecated.hs b/src/Morley/Michelson/Typed/Scope/Internal/Deprecated.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/Deprecated.hs
@@ -0,0 +1,299 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.Deprecated
+ ( module Morley.Michelson.Typed.Scope.Internal.Deprecated
+ ) where
+
+import Data.Constraint (Dict(..), (\\))
+import Data.Singletons (Sing, SingI(..))
+import Data.Type.Bool (Not)
+import Data.Type.Equality ((:~:)(..))
+
+import Morley.Michelson.Typed.Scope.Internal.Comparable
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.Presence
+import Morley.Michelson.Typed.Scope.Internal.WellTyped
+import Morley.Michelson.Typed.Sing (SingT(..))
+import Morley.Michelson.Typed.T (T(..))
+import Morley.Util.StubbedProof (stubProof)
+
+-- | Whether a value of this type _may_ contain an operation.
+--
+-- In some scopes (constants, parameters, storage) appearing for operation type
+-- is prohibited.
+-- Operations in input/output of lambdas are allowed without limits though.
+type ContainsOp t = ContainsT 'PSOp t
+
+-- | Whether a value of this type _may_ contain a @contract@ value.
+--
+-- In some scopes (constants, storage) appearing for contract type
+-- is prohibited.
+-- Contracts in input/output of lambdas are allowed without limits though.
+type ContainsContract t = ContainsT 'PSContract t
+
+-- | Whether a value of this type _may_ contain a @ticket@ value.
+type ContainsTicket t = ContainsT 'PSTicket t
+
+-- | Whether a value of this type _may_ contain a @big_map@ value.
+type ContainsBigMap t = ContainsT 'PSBigMap t
+
+-- | Whether a value of this type _may_ contain nested @big_map@s.
+--
+-- Nested big_maps (i.e. big_map which contains another big_map inside of it's value type) are
+-- prohibited in all contexts. Some context such as PUSH, APPLY, PACK/UNPACK instructions are more
+-- strict because they don't work with big_map at all.
+type ContainsNestedBigMaps t = ContainsT 'PSNestedBigMaps t
+
+-- | Whether a value of this type _may_ contain a @samping_state@ value.
+type ContainsSaplingState t = ContainsT 'PSSaplingState t
+
+{-# DEPRECATED
+ ContainsOp
+ , ContainsContract
+ , ContainsTicket
+ , ContainsBigMap
+ , ContainsNestedBigMaps
+ , ContainsSaplingState
+ "Use 'ContainsT' with the corresponding type marker, e.g. \
+ \'ContainsT PSOp', 'ContainsT PSTicket', etc"
+ #-}
+
+
+-- | Constraint which ensures that a value of type @t@ does not contain operations.
+--
+-- Not just a type alias in order to be able to partially apply it
+-- (e.g. in 'Each').
+class (ContainsOp t ~ 'False) => HasNoOp t
+instance (ContainsOp t ~ 'False) => HasNoOp t
+
+-- | Constraint which ensures that a value of type @t@ does not contain @contract@ values.
+class (ContainsContract t ~ 'False) => HasNoContract t
+instance (ContainsContract t ~ 'False) => HasNoContract t
+
+-- | Constraint which ensures that a value of type @t@ does not contain @ticket@ values.
+class (ContainsTicket t ~ 'False) => HasNoTicket t
+instance (ContainsTicket t ~ 'False) => HasNoTicket t
+
+-- | Constraint which ensures that a value of type @t@ does not contain @big_map@ values.
+class (ContainsBigMap t ~ 'False) => HasNoBigMap t
+instance (ContainsBigMap t ~ 'False) => HasNoBigMap t
+
+-- | Constraint which ensures that a value of type @t@ does not contain @sapling_state@ values.
+class (ContainsSaplingState t ~ 'False) => HasNoSaplingState t
+instance (ContainsSaplingState t ~ 'False) => HasNoSaplingState t
+
+-- | Constraint which ensures that there are no nested bigmaps.
+class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t
+instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t
+
+{-# DEPRECATED HasNoOp, HasNoContract, HasNoTicket, HasNoBigMap, HasNoSaplingState, HasNoNestedBigMaps
+ "Use Forbid* instead" #-}
+
+
+-- | Whether a value of this type _may_ contain an operation.
+type OpPresence (t :: T) = TPresence 'PSOp t
+pattern OpPresent :: () => ContainsOp t ~ 'True => OpPresence t
+pattern OpPresent = TPresent
+pattern OpAbsent :: () => ContainsOp t ~ 'False => OpPresence t
+pattern OpAbsent = TAbsent
+{-# COMPLETE OpPresent, OpAbsent #-}
+
+-- | Whether a value of this type _may_ contain a @contract@ value.
+type ContractPresence (t :: T) = TPresence 'PSContract t
+pattern ContractPresent :: () => ContainsContract t ~ 'True => ContractPresence t
+pattern ContractPresent = TPresent
+pattern ContractAbsent :: () => ContainsContract t ~ 'False => ContractPresence t
+pattern ContractAbsent = TAbsent
+{-# COMPLETE ContractPresent, ContractAbsent #-}
+
+-- | Whether a value of this type _may_ contain a @ticket@ value.
+type TicketPresence (t :: T) = TPresence 'PSTicket t
+pattern TicketPresent :: () => ContainsTicket t ~ 'True => TicketPresence t
+pattern TicketPresent = TPresent
+pattern TicketAbsent :: () => ContainsTicket t ~ 'False => TicketPresence t
+pattern TicketAbsent = TAbsent
+{-# COMPLETE TicketPresent, TicketAbsent #-}
+
+-- | Whether a value of this type _may_ contain a @big_map@ value.
+type BigMapPresence (t :: T) = TPresence 'PSBigMap t
+pattern BigMapPresent :: () => ContainsBigMap t ~ 'True => BigMapPresence t
+pattern BigMapPresent = TPresent
+pattern BigMapAbsent :: () => ContainsBigMap t ~ 'False => BigMapPresence t
+pattern BigMapAbsent = TAbsent
+{-# COMPLETE BigMapPresent, BigMapAbsent #-}
+
+-- | Whether a value of this type _may_ contain nested @big_map@s.
+type NestedBigMapsPresence (t :: T) = TPresence 'PSNestedBigMaps t
+pattern NestedBigMapsPresent :: () => ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresence t
+pattern NestedBigMapsPresent = TPresent
+pattern NestedBigMapsAbsent :: () => ContainsNestedBigMaps t ~ 'False => NestedBigMapsPresence t
+pattern NestedBigMapsAbsent = TAbsent
+{-# COMPLETE NestedBigMapsPresent, NestedBigMapsAbsent #-}
+
+-- | Whether a value of this type _may_ contain a @sapling_state@ value.
+type SaplingStatePresence (t :: T) = TPresence 'PSSaplingState t
+pattern SaplingStatePresent :: () => ContainsSaplingState t ~ 'True => SaplingStatePresence t
+pattern SaplingStatePresent = TPresent
+pattern SaplingStateAbsent :: () => ContainsSaplingState t ~ 'False => SaplingStatePresence t
+pattern SaplingStateAbsent = TAbsent
+{-# COMPLETE SaplingStatePresent, SaplingStateAbsent #-}
+
+{-# DEPRECATED
+ OpPresence, OpPresent, OpAbsent
+ , ContractPresence, ContractPresent, ContractAbsent
+ , TicketPresence, TicketPresent, TicketAbsent
+ , BigMapPresence, BigMapPresent, BigMapAbsent
+ , NestedBigMapsPresence, NestedBigMapsPresent, NestedBigMapsAbsent
+ , SaplingStatePresence, SaplingStatePresent, SaplingStateAbsent
+ "Use TPresence instead" #-}
+
+type ProperParameterBetterErrors t =
+ (SingI t, WellTyped t, ForbidOp t, ForbidNestedBigMaps t)
+
+type ProperStorageBetterErrors t =
+ (SingI t, WellTyped t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)
+
+type ProperConstantBetterErrors t =
+ (SingI t, WellTyped t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t, ForbidSaplingState t)
+
+type ProperDupableBetterErrors t =
+ (SingI t, ForbidTicket t)
+
+type ProperPackedValBetterErrors t =
+ (SingI t, WellTyped t, ForbidOp t, ForbidBigMap t, ForbidTicket t, ForbidSaplingState t)
+
+type ProperUnpackedValBetterErrors t =
+ (ProperPackedValBetterErrors t, ProperConstantBetterErrors t)
+
+type ProperViewableBetterErrors t =
+ (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket t)
+
+type ProperUntypedValBetterErrors t =
+ (SingI t, ForbidOp t)
+
+type ProperNonComparableValBetterErrors t =
+ (SingI t, ForbidNonComparable t)
+
+{-# DEPRECATED ProperParameterBetterErrors
+ , ProperStorageBetterErrors
+ , ProperConstantBetterErrors
+ , ProperDupableBetterErrors
+ , ProperPackedValBetterErrors
+ , ProperUnpackedValBetterErrors
+ , ProperViewableBetterErrors
+ , ProperUntypedValBetterErrors
+ , ProperNonComparableValBetterErrors
+ "Use *Scope instead"
+ #-}
+
+-- | Check at runtime whether a value of the given type _may_ contain an operation.
+checkOpPresence :: Sing (ty :: T) -> TPresence 'PSOp ty
+checkOpPresence = checkTPresence SPSOp
+
+-- | Check at runtime whether a value of the given type _may_ contain a @contract@ value.
+checkContractTypePresence :: Sing (ty :: T) -> TPresence 'PSContract ty
+checkContractTypePresence = checkTPresence SPSContract
+
+-- | Check at runtime whether a value of the given type _may_ contain a @ticket@ value.
+checkTicketPresence :: Sing (ty :: T) -> TPresence 'PSTicket ty
+checkTicketPresence = checkTPresence SPSTicket
+
+-- | Check at runtime whether a value of the given type _may_ contain a @big_map@ value.
+checkBigMapPresence :: Sing (ty :: T) -> TPresence 'PSBigMap ty
+checkBigMapPresence = checkTPresence SPSBigMap
+
+-- | Check at runtime whether a value of the given type _may_ contain nested @big_map@s.
+checkNestedBigMapsPresence :: Sing (ty :: T) -> TPresence 'PSNestedBigMaps ty
+checkNestedBigMapsPresence = checkTPresence SPSNestedBigMaps
+
+{-# DEPRECATED checkOpPresence, checkContractTypePresence, checkTicketPresence, checkBigMapPresence, checkNestedBigMapsPresence
+ "Use checkTPresence instead" #-}
+
+-- | Check at runtime that a value of the given type cannot contain operations.
+opAbsense :: Sing (t :: T) -> Maybe (Dict $ ForbidOp t)
+opAbsense = fmap (\Refl -> Dict) . tAbsence SPSOp
+
+-- | Check at runtime that a value of the given type cannot contain @contract@ values.
+contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ ForbidContract t)
+contractTypeAbsense = fmap (\Refl -> Dict) . tAbsence SPSContract
+
+-- | Check at runtime that a value of the given type cannot containt @big_map@ values
+bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ ForbidBigMap t)
+bigMapAbsense = fmap (\Refl -> Dict) . tAbsence SPSBigMap
+
+-- | Check at runtime that a value of the given type cannot contain nested @big_map@s.
+nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ ForbidNestedBigMaps t)
+nestedBigMapsAbsense = fmap (\Refl -> Dict) . tAbsence SPSNestedBigMaps
+
+{-# DEPRECATED opAbsense, contractTypeAbsense, bigMapAbsense, nestedBigMapsAbsense
+ "Use tAbsence instead"
+ #-}
+
+-- | Inductive proof that 'Comparable' implies 'HasNoNestedBigMaps'. This is
+-- stubbed with an @unsafeCoerce Refl@ at runtime to avoid runtime traversals.
+comparabilityImpliesNoNestedBigMaps
+ :: forall t. (SingI t, IsComparable t ~ 'True) => ContainsNestedBigMaps t :~: 'False
+comparabilityImpliesNoNestedBigMaps = stubProof $ go (sing @t)
+ where
+ go :: IsComparable a ~ 'True => Sing a -> ContainsNestedBigMaps a :~: 'False
+ go = \case
+ STPair (a :: Sing a) (b :: Sing b) -> case (checkComparability a, checkComparability b) of
+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
+ STOr a b -> case (checkComparability a, checkComparability b) of
+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
+ STOption t -> Refl \\ go t
+ STNever -> Refl
+ STUnit -> Refl
+ STInt -> Refl
+ STNat -> Refl
+ STString -> Refl
+ STBytes -> Refl
+ STMutez -> Refl
+ STBool -> Refl
+ STKeyHash -> Refl
+ STTimestamp -> Refl
+ STAddress -> Refl
+ STKey -> Refl
+ STSignature -> Refl
+ STChainId -> Refl
+
+-- | Inductive proof that 'Comparable' implies 'HasNoOp'. This is
+-- stubbed with an @unsafeCoerce Refl@ at runtime to avoid runtime traversals.
+comparabilityImpliesNoOp
+ :: forall t. (SingI t, IsComparable t ~ 'True) => ContainsOp t :~: 'False
+comparabilityImpliesNoOp = stubProof $ go (sing @t)
+ where
+ go :: IsComparable a ~ 'True => Sing a -> ContainsOp a :~: 'False
+ go = \case
+ STPair (a :: Sing a) (b :: Sing b) -> case (checkComparability a, checkComparability b) of
+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
+ STOr a b -> case (checkComparability a, checkComparability b) of
+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b
+ STOption t -> Refl \\ go t
+ STNever -> Refl
+ STUnit -> Refl
+ STInt -> Refl
+ STNat -> Refl
+ STString -> Refl
+ STBytes -> Refl
+ STMutez -> Refl
+ STBool -> Refl
+ STKeyHash -> Refl
+ STTimestamp -> Refl
+ STAddress -> Refl
+ STKey -> Refl
+ STSignature -> Refl
+ STChainId -> Refl
+
+{-# DEPRECATED comparabilityImpliesNoNestedBigMaps, comparabilityImpliesNoOp
+ "Already implied by Comparable constraint" #-}
+
+getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))
+getComparableProofS = comparabilityPresence
+{-# DEPRECATED getComparableProofS "Use comparabilityPresence" #-}
+
+type IsComparable t = Not (ContainsT 'PSNonComparable t)
+{-# DEPRECATED IsComparable "Use 'Not (ContainsT PSNonComparable t)' instead" #-}
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/ForbidT.hs b/src/Morley/Michelson/Typed/Scope/Internal/ForbidT.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/ForbidT.hs
@@ -0,0 +1,225 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.ForbidT
+ ( module Morley.Michelson.Typed.Scope.Internal.ForbidT
+ ) where
+
+import Data.Type.Bool (type (||))
+import Fcf (Pure)
+import GHC.TypeLits (Symbol)
+import Type.Errors (DelayError, ErrorMessage(..), IfStuck)
+
+import Morley.Michelson.Typed.T (T(..))
+import Morley.Util.Sing
+import Morley.Util.Type (FailWhen)
+
+{- $setup
+>>> import Morley.Michelson.Typed (T(..), SingT(..))
+>>> import Morley.Util.Peano (pattern S, pattern Z)
+>>> import Data.Type.Equality ((:~:)(..))
+-}
+
+-- | Type-level symbol for type predicates used in 'ContainsT'
+data TPredicateSym
+ = PSOp -- ^ Contains @operation@
+ | PSContract -- ^ Contains @contract 'a@
+ | PSTicket -- ^ Contains @ticket 'a@
+ | PSBigMap -- ^ Contains @big_map 'k 'v@
+ | PSNestedBigMaps -- ^ Contains @big_map 'k (big_map 'k 'v)@
+ | PSSaplingState -- ^ Contains @sapling_state 'n@
+ | PSNonComparable -- ^ Contains non-comparable types
+
+genSingletonsType ''TPredicateSym
+
+type TPredicateSymTypeName :: TPredicateSym -> Symbol
+type family TPredicateSymTypeName p where
+ TPredicateSymTypeName 'PSOp = "`operation`"
+ TPredicateSymTypeName 'PSContract = "`contract`"
+ TPredicateSymTypeName 'PSTicket = "`ticket`"
+ TPredicateSymTypeName 'PSBigMap = "`big_map`"
+ TPredicateSymTypeName 'PSNestedBigMaps = "nested `big_map`s"
+ TPredicateSymTypeName 'PSSaplingState = "`sapling_state`"
+ TPredicateSymTypeName 'PSNonComparable = "non-comparable types"
+
+type ContainsT :: TPredicateSym -> T -> Bool
+type family ContainsT p t where
+ ContainsT 'PSOp 'TOperation = 'True
+ ContainsT 'PSContract ('TContract _) = 'True
+ ContainsT 'PSTicket ('TTicket _) = 'True
+ ContainsT 'PSBigMap ('TBigMap _ _) = 'True
+ ContainsT 'PSSaplingState ('TSaplingState _) = 'True
+ ContainsT 'PSNestedBigMaps ('TBigMap _ v) = ContainsT 'PSBigMap v
+ -- non-comparable
+ ContainsT 'PSNonComparable 'TBls12381Fr = 'True
+ ContainsT 'PSNonComparable 'TBls12381G1 = 'True
+ ContainsT 'PSNonComparable 'TBls12381G2 = 'True
+ ContainsT 'PSNonComparable ('TList _) = 'True
+ ContainsT 'PSNonComparable ('TSet _) = 'True
+ ContainsT 'PSNonComparable 'TOperation = 'True
+ ContainsT 'PSNonComparable ('TContract _) = 'True
+ ContainsT 'PSNonComparable ('TTicket _) = 'True
+ ContainsT 'PSNonComparable ('TLambda _ _) = 'True
+ ContainsT 'PSNonComparable ('TMap _ _) = 'True
+ ContainsT 'PSNonComparable ('TBigMap _ _) = 'True
+ ContainsT 'PSNonComparable 'TChest = 'True
+ ContainsT 'PSNonComparable 'TChestKey = 'True
+ ContainsT 'PSNonComparable ('TSaplingState _) = 'True
+ ContainsT 'PSNonComparable ('TSaplingTransaction _) = 'True
+ -- recursion
+ ContainsT p ('TOption t) = ContainsT p t
+ ContainsT p ('TList t) = ContainsT p t
+ ContainsT p ('TSet t) = ContainsT p t
+ ContainsT p ('TTicket t) = ContainsT p t
+ ContainsT p ('TPair a b) = ContainsT p a || ContainsT p b
+ ContainsT p ('TOr a b) = ContainsT p a || ContainsT p b
+ ContainsT p ('TBigMap k v) = ContainsT p k || ContainsT p v
+ ContainsT p ('TMap k v) = ContainsT p k || ContainsT p v
+ -- rest
+ ContainsT _ _ = 'False
+
+type ForbidTErrorMsg :: TPredicateSym -> T -> ErrorMessage
+type family ForbidTErrorMsg p t where
+ ForbidTErrorMsg 'PSNestedBigMaps t =
+ 'Text "Nested `big_map`s found in" ':$$: 'ShowType t ':$$: 'Text "are not allowed"
+ ForbidTErrorMsg 'PSNonComparable t =
+ 'Text "Non-comparable type"
+ ':$$: 'ShowType t
+ ':$$: 'Text "is not allowed in this scope"
+ ForbidTErrorMsg p t =
+ 'Text "Type " ':<>: 'Text (TPredicateSymTypeName p) ':<>: 'Text " found in"
+ ':$$: 'ShowType t
+ ':$$: 'Text "is not allowed in this scope"
+
+{- | Constraint for classes forbidding type presence based on predicate defined
+by 'TPredicateSym'.
+
+Not just a type alias in order to be able to partially apply it (e.g. in
+'Each').
+
+Reports errors when a type does not satisfy predicate:
+
+>>> () :: ForbidT PSOp TOperation => ()
+...
+... Type `operation` found in
+... 'TOperation
+... is not allowed in this scope
+...
+>>> () :: ForbidT PSContract (TContract TUnit) => ()
+...
+... Type `contract` found in
+... 'TContract 'TUnit
+... is not allowed in this scope
+...
+>>> () :: ForbidT PSTicket (TTicket TUnit) => ()
+...
+... Type `ticket` found in
+... 'TTicket 'TUnit
+... is not allowed in this scope
+...
+>>> () :: ForbidT PSBigMap (TBigMap TUnit TUnit) => ()
+...
+... Type `big_map` found in
+... 'TBigMap 'TUnit 'TUnit
+... is not allowed in this scope
+...
+>>> () :: ForbidT PSSaplingState (TSaplingState Z) => ()
+...
+... Type `sapling_state` found in
+... 'TSaplingState 'Z
+... is not allowed in this scope
+...
+>>> () :: ForbidT PSNestedBigMaps (TBigMap TUnit (TBigMap TUnit TUnit)) => ()
+...
+... Nested `big_map`s found in
+... 'TBigMap 'TUnit ('TBigMap 'TUnit 'TUnit)
+... are not allowed
+...
+
+When the type is ambiguous or polymorphic, suggests adding the corresponding
+constraint:
+
+>>> (const () :: ForbidOp t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`. Perhaps you need to add
+... ForbidT 'PSOp t0
+... constraint? You can also try adding a type annotation.
+...
+
+This constraint implies @ContainsT ~ False@:
+
+>>> :{
+foo :: ForbidT p t => ContainsT p t :~: False
+foo = Refl
+:}
+-}
+type ForbidT :: TPredicateSym -> T -> Constraint
+class ForbidManyT (ForbidT p t) '[p] t => ForbidT p t
+instance ForbidManyT (ForbidT p t) '[p] t => ForbidT p t
+
+type ForbidOp = ForbidT 'PSOp -- ^ Convenience synonym
+type ForbidContract = ForbidT 'PSContract -- ^ Convenience synonym
+type ForbidTicket = ForbidT 'PSTicket -- ^ Convenience synonym
+type ForbidSaplingState = ForbidT 'PSSaplingState -- ^ Convenience synonym
+type ForbidBigMap = ForbidT 'PSBigMap -- ^ Convenience synonym
+type ForbidNestedBigMaps = ForbidT 'PSNestedBigMaps -- ^ Convenience synonym
+type ForbidNonComparable = ForbidT 'PSNonComparable -- ^ Convenience synonym
+
+{- | Class abstracting multiple 'ForbidT' constraints.
+
+This version accepts a custom error message displayed if 'ContainsT' gets stuck.
+You likely want to use 'ForbidManyT', which sets this message.
+
+It's a class and not a recursive type family because recursive type families
+take noticeably longer to compile.
+-}
+type ForbidManyT' :: Constraint -> [TPredicateSym] -> [TPredicateSym] -> T -> Constraint
+class ForbidManySuperC ps t => ForbidManyT' c ps' ps t where
+ type ForbidManySuperC ps t :: Constraint
+
+instance ForbidManyT' c ps' '[] t where
+ type ForbidManySuperC '[] _ = ()
+instance
+ ( IfStuck (ContainsT p t) (DelayError (ForbidManyTStuckErr c ps' t)) (Pure (ForbidManyT' c ps' ps t))
+ , FailWhen (ContainsT p t) (ForbidTErrorMsg p t)
+ ) => ForbidManyT' c ps' (p : ps) t where
+ type ForbidManySuperC (p : ps) t =
+ -- NB: WhenStuck isn't in the superclass constraints by design, as
+ -- FailWhen unifies it with False.
+ ( ContainsT p t ~ 'False
+ , ForbidManySuperC ps t
+ )
+
+{- | Abstracts multiple 'ForbidT' constraints. Accepts a constraint that will be
+suggested in an error message in case 'ContainsT' gets stuck. This is used with
+scope constraints in "Morley.Michelson.Typed.Scope.Internal.Scopes".
+-}
+type ForbidManyT c ps = ForbidManyT' c ps ps
+
+-- | Given a list of 'TPredicateSym', pretty-print a list of corresponding type
+-- names. Uses 'TPredicateSymTypeName' for a single type, separates the last two
+-- types with @or@, others with @,@.
+--
+-- Doesn't do the oxford comma, because it's rather tricky to implement, and
+-- compilation types aren't great already.
+type TPredicateSymTypeNames :: [TPredicateSym] -> ErrorMessage
+type family TPredicateSymTypeNames ps where
+ TPredicateSymTypeNames '[] = 'Text ""
+ TPredicateSymTypeNames '[p] = 'Text (TPredicateSymTypeName p)
+ TPredicateSymTypeNames '[p, q] =
+ 'Text (TPredicateSymTypeName p) ':<>: 'Text " or " ':<>: 'Text (TPredicateSymTypeName q)
+ TPredicateSymTypeNames (p : ps) =
+ 'Text (TPredicateSymTypeName p) ':<>: 'Text ", " ':<>: TPredicateSymTypeNames ps
+
+type ForbidManyTStuckErr :: Constraint -> [TPredicateSym] -> T -> ErrorMessage
+type ForbidManyTStuckErr c ps t =
+ 'Text "Can't check if type" ':$$:
+ 'ShowType t ':$$:
+ 'Text "contains " ':<>: TPredicateSymTypeNames ps ':<>:
+ 'Text ". Perhaps you need to add" ':$$:
+ 'ShowType c ':$$:
+ 'Text "constraint? You can also try adding a type annotation."
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/Presence.hs b/src/Morley/Michelson/Typed/Scope/Internal/Presence.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/Presence.hs
@@ -0,0 +1,152 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.Presence
+ ( module Morley.Michelson.Typed.Scope.Internal.Presence
+ ) where
+
+import Data.Singletons (Sing)
+
+import Data.Type.Equality ((:~:)(..))
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.TH
+import Morley.Michelson.Typed.Sing (SingT(..))
+import Morley.Michelson.Typed.T (T(..))
+
+{- $setup
+>>> import Morley.Michelson.Typed (T(..), SingT(..), SingTPredicateSym(..))
+>>> import Morley.Util.Peano (pattern S, pattern Z)
+>>> import Data.Type.Equality ((:~:)(..))
+-}
+
+-- | Whether a value of this type _may_ contain a type defined by 'TPredicateSym'.
+type TPresence :: TPredicateSym -> T -> Type
+data TPresence p t where
+ TPresent :: ContainsT p t ~ 'True => TPresence p t
+ TAbsent :: ContainsT p t ~ 'False => TPresence p t
+
+deriving stock instance Show (TPresence t p)
+
+{- | Check for presence of type defined by 'TPredicateSym' at runtime. Use
+'TPredicateSym' singletons (i.e. 'SingTPredicateSym') as the first parameter,
+e.g.:
+
+>>> checkTPresence SPSOp STOperation
+TPresent
+>>> checkTPresence SPSOp STUnit
+TAbsent
+
+To only prove absence of some type, it is more efficient to use
+@deMorganForbidT@ or @withDeMorganScope@.
+-}
+checkTPresence
+ :: forall p ty. Sing p
+ -> Sing ty
+ -> TPresence p ty
+checkTPresence sp = \case
+ STOption t -> case checkTPresence sp t of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ STList t -> $(byTPredicateSymCases [|sp|]
+ [ ('SPSNonComparable, [|TPresent|]) ]
+ [|case checkTPresence sp t of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ |])
+ STSet t -> $(byTPredicateSymCases [|sp|]
+ [ ('SPSNonComparable, [|TPresent|]) ]
+ [|case checkTPresence sp t of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ |])
+ STTicket t -> $(byTPredicateSymCases [|sp|]
+ [ ('SPSTicket, [|TPresent|])
+ , ('SPSNonComparable, [|TPresent|])
+ ]
+ [|case checkTPresence sp t of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ |]
+ )
+ STPair a b -> case checkTPresence sp a of
+ TPresent -> TPresent
+ TAbsent -> case checkTPresence sp b of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ STOr a b -> case checkTPresence sp a of
+ TPresent -> TPresent
+ TAbsent -> case checkTPresence sp b of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ STMap a b -> $(byTPredicateSymCases [|sp|]
+ [ ('SPSNonComparable, [|TPresent|])]
+ [|case checkTPresence sp a of
+ TPresent -> TPresent
+ TAbsent -> case checkTPresence sp b of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ |])
+ STBigMap a b -> $(byTPredicateSymCases [|sp|]
+ [ ('SPSBigMap, [|TPresent|])
+ , ('SPSNonComparable, [|TPresent|])
+ , ('SPSNestedBigMaps, [|
+ case checkTPresence SPSBigMap b of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ |])
+ ]
+ [|case checkTPresence sp a of
+ TPresent -> TPresent
+ TAbsent -> case checkTPresence sp b of
+ TPresent -> TPresent
+ TAbsent -> TAbsent
+ |]
+ )
+ -- special cases
+ STOperation ->
+ $(byTPredicateSymCases [|sp|]
+ [('SPSOp, [|TPresent|]), ('SPSNonComparable, [|TPresent|])]
+ [|TAbsent|])
+ STContract{} ->
+ $(byTPredicateSymCases [|sp|]
+ [('SPSContract, [|TPresent|]), ('SPSNonComparable, [|TPresent|])]
+ [|TAbsent|])
+ STSaplingState{} ->
+ $(byTPredicateSymCases [|sp|]
+ [('SPSSaplingState, [|TPresent|]), ('SPSNonComparable, [|TPresent|])]
+ [|TAbsent|])
+ -- rest
+ STKey -> TAbsent
+ STUnit -> TAbsent
+ STSignature -> TAbsent
+ STChainId -> TAbsent
+ STInt -> TAbsent
+ STNat -> TAbsent
+ STString -> TAbsent
+ STBytes -> TAbsent
+ STMutez -> TAbsent
+ STBool -> TAbsent
+ STKeyHash -> TAbsent
+ STBls12381Fr -> $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+ STBls12381G1 -> $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+ STBls12381G2 -> $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+ STTimestamp -> TAbsent
+ STAddress -> TAbsent
+ STChest -> $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+ STChestKey -> $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+ STSaplingTransaction _ ->
+ $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+ STNever -> TAbsent
+ STLambda{} -> $(byTPredicateSymCases [|sp|] [('SPSNonComparable, [|TPresent|])] [|TAbsent|])
+
+tPresence :: Sing p -> Sing t -> Maybe (ContainsT p t :~: 'True)
+tPresence p t = case checkTPresence p t of
+ TPresent -> Just Refl
+ TAbsent -> Nothing
+
+tAbsence :: Sing p -> Sing t -> Maybe (ContainsT p t :~: 'False)
+tAbsence p t = case checkTPresence p t of
+ TPresent -> Nothing
+ TAbsent -> Just Refl
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/Scopes.hs b/src/Morley/Michelson/Typed/Scope/Internal/Scopes.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/Scopes.hs
@@ -0,0 +1,244 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.Scopes
+ ( module Morley.Michelson.Typed.Scope.Internal.Scopes
+ ) where
+
+import Data.Singletons (SingI)
+import Data.Type.Bool (Not)
+
+import Morley.Michelson.Typed.Scope.Internal.Comparable
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.WellTyped
+import Morley.Michelson.Typed.T (T(..))
+
+{- $setup
+>>> import Morley.Michelson.Typed.Scope
+>>> import Morley.Michelson.Typed (T(..), SingT(..))
+>>> import Morley.Util.Peano (pattern S, pattern Z)
+>>> import Data.Type.Equality ((:~:)(..))
+-}
+
+{-
+Note [WellTyped constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Try to put WellTyped constraint at the end of instance constraints. Because
+WellTyped is a recursive type class, it loses context when it recurses, unlike
+ForbidT constraints which do a type-family based check. The consequence is,
+ForbidT constraints produce error messages with more context. The intention is
+to show more informative errors first.
+
+-- @lierdakil
+-}
+
+-- | Common constraints used for scopes defined below.
+type CommonScopeC c ps t = (SingI t, ForbidManyT c ps t, WellTyped t)
+
+{- | Set of constraints that Michelson applies to parameters.
+
+Not just a type alias in order to be able to partially apply it
+
+Produces human-readable error messages:
+
+>>> () :: ParameterScope (TBigMap TUnit (TBigMap TUnit TOperation)) => ()
+...
+... Nested `big_map`s found in
+... 'TBigMap 'TUnit ('TBigMap 'TUnit 'TOperation)
+... are not allowed
+...
+... Type `operation` found in
+... 'TBigMap 'TUnit ('TBigMap 'TUnit 'TOperation)
+... is not allowed in this scope
+...
+>>> () :: ParameterScope (TBigMap TInt TNat) => ()
+()
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: ParameterScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation` or nested `big_map`s. Perhaps you need to add
+... ParameterScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class ParameterScopeC (ParameterScope t) t => ParameterScope t
+instance ParameterScopeC (ParameterScope t) t => ParameterScope t
+type ParameterScopeC c t = CommonScopeC c ['PSOp, 'PSNestedBigMaps] t
+
+{- | Set of constraints that Michelson applies to contract storage.
+
+Not just a type alias in order to be able to partially apply it
+
+Produces human-readable error messages:
+
+>>> () :: StorageScope (TContract TOperation) => ()
+...
+... Type `contract` found in
+... 'TContract 'TOperation
+... is not allowed in this scope
+...
+... Type `operation` found in
+... 'TOperation
+... is not allowed in this scope
+...
+>>> () :: StorageScope TUnit => ()
+()
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: StorageScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`, nested `big_map`s or `contract`. Perhaps you need to add
+... StorageScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class StorageScopeC (StorageScope t) t => StorageScope t
+instance StorageScopeC (StorageScope t) t => StorageScope t
+type StorageScopeC c t = CommonScopeC c ['PSOp, 'PSNestedBigMaps, 'PSContract] t
+
+{- | Set of constraints that Michelson applies to pushed constants.
+
+Not just a type alias in order to be able to partially apply it
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: ConstantScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`, `big_map`, `contract`, `ticket` or `sapling_state`. Perhaps you need to add
+... ConstantScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class ConstantScopeC (ConstantScope t) t => ConstantScope t
+instance ConstantScopeC (ConstantScope t) t => ConstantScope t
+type ConstantScopeC c t =
+ CommonScopeC c ['PSOp, 'PSBigMap, 'PSContract, 'PSTicket, 'PSSaplingState] t
+
+{- | Alias for constraints which Michelson requires in @DUP@ instruction.
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: DupableScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `ticket`. Perhaps you need to add
+... DupableScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class DupableScopeC (DupableScope t) t => DupableScope t
+instance DupableScopeC (DupableScope t) t => DupableScope t
+type DupableScopeC c t = (SingI t, ForbidManyT c '[ 'PSTicket] t)
+
+-- | Returns whether the type is dupable.
+type family IsDupableScope (t :: T) :: Bool where
+ IsDupableScope t = Not (ContainsT 'PSTicket t)
+
+{- | Set of constraints that Michelson applies to packed values.
+
+Not just a type alias in order to be able to partially apply it.
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: PackedValScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`, `big_map`, `ticket` or `sapling_state`. Perhaps you need to add
+... PackedValScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class PackedValScopeC (PackedValScope t) t => PackedValScope t
+instance PackedValScopeC (PackedValScope t) t => PackedValScope t
+type PackedValScopeC c t =
+ CommonScopeC c ['PSOp, 'PSBigMap, 'PSTicket, 'PSSaplingState] t
+
+{- | Set of constraints that Michelson applies to unpacked values.
+Same as 'ConstantScope'.
+
+Not just a type alias in order to show better errors on ambiguity or missing
+constraint.
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: UnpackedValScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`, `big_map`, `contract`, `ticket` or `sapling_state`. Perhaps you need to add
+... UnpackedValScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class UnpackedValScopeC (UnpackedValScope t) t => UnpackedValScope t
+instance UnpackedValScopeC (UnpackedValScope t) t => UnpackedValScope t
+type UnpackedValScopeC c t = ConstantScopeC c t
+
+{- | Set of constraints that Michelson applies to argument type and return type
+of views. All info related to views can be found in
+[TZIP](https://gitlab.com/tezos/tzip/-/blob/master/drafts/current/draft_views.md).
+
+Not just a type alias in order to be able to partially apply it.
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: ViewableScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`, `big_map` or `ticket`. Perhaps you need to add
+... ViewableScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class ViewableScopeC (ViewableScope t) t => ViewableScope t
+instance ViewableScopeC (ViewableScope t) t => ViewableScope t
+type ViewableScopeC c t = (SingI t, ForbidManyT c ['PSOp, 'PSBigMap, 'PSTicket] t)
+
+{- | Alias for constraints which are required for untyped representation.
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: UntypedValScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains `operation`. Perhaps you need to add
+... UntypedValScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class UntypedValScopeC (UntypedValScope t) t => UntypedValScope t
+instance UntypedValScopeC (UntypedValScope t) t => UntypedValScope t
+type UntypedValScopeC c t = (SingI t, ForbidManyT c '[ 'PSOp] t)
+
+{- | Alias for comparable types.
+
+On ambiguous or polymorphic types, suggests adding the constraint:
+
+>>> (const () :: ComparabilityScope t => f t -> ()) undefined
+...
+... Can't check if type
+... t0
+... contains non-comparable types. Perhaps you need to add
+... ComparabilityScope t0
+... constraint? You can also try adding a type annotation.
+...
+-}
+class ComparabilityScopeC (ComparabilityScope t) t => ComparabilityScope t
+instance ComparabilityScopeC (ComparabilityScope t) t => ComparabilityScope t
+type ComparabilityScopeC c t = (SingI t, ForbidManyT c '[ 'PSNonComparable ] t, Comparable t)
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/TH.hs b/src/Morley/Michelson/Typed/Scope/Internal/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/TH.hs
@@ -0,0 +1,26 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.TH
+ (module Morley.Michelson.Typed.Scope.Internal.TH
+ ) where
+
+import Debug qualified
+
+import Language.Haskell.TH qualified as TH
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+
+byTPredicateSymCases :: TH.ExpQ -> [(TH.Name, TH.ExpQ)] -> TH.ExpQ -> TH.ExpQ
+byTPredicateSymCases sp specific rest = do
+ TH.TyConI (TH.DataD _ _ _ _ cons' _) <- TH.reify ''SingTPredicateSym
+ let cons = cons' <&> \case
+ TH.NormalC nm _ -> nm
+ TH.GadtC [nm] _ _ -> nm
+ c -> error $ "unexpected constructor " <> Debug.show c
+ specCons = map fst specific
+ restCons = filter (`notElem` specCons) cons
+ cases = specific <> (restCons <&> (, rest))
+ matches = first (flip TH.conP []) <$> cases
+ TH.caseE sp [ TH.match pat (TH.normalB expr) [] | (pat, expr) <- matches ]
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/WellTyped.hs b/src/Morley/Michelson/Typed/Scope/Internal/WellTyped.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/WellTyped.hs
@@ -0,0 +1,169 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.WellTyped
+ ( module Morley.Michelson.Typed.Scope.Internal.WellTyped
+ ) where
+
+import Data.Constraint (Dict(..))
+import Data.Singletons (Sing, SingI(..), fromSing, withSingI)
+import Data.Type.Equality ((:~:)(..))
+import Fmt (Buildable(..), quoteOrIndentF, (++|), (|++^))
+
+import Morley.Michelson.Typed.Scope.Internal.Comparable
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.Presence
+import Morley.Michelson.Typed.Sing (SingT(..))
+import Morley.Michelson.Typed.T (T(..))
+
+{-$setup
+>>> import Morley.Michelson.Typed
+>>> import Fmt (pretty)
+-}
+
+data BadTypeForScope
+ = BtNotComparable
+ | BtIsOperation
+ | BtHasBigMap
+ | BtHasNestedBigMap
+ | BtHasContract
+ | BtHasTicket
+ | BtHasSaplingState
+ deriving stock (Show, Eq, Generic)
+ deriving anyclass (NFData)
+
+instance Buildable BadTypeForScope where
+ build = \case
+ BtNotComparable -> "is not comparable"
+ BtIsOperation -> "has 'operation' type"
+ BtHasBigMap -> "has 'big_map'"
+ BtHasNestedBigMap -> "has nested 'big_map'"
+ BtHasContract -> "has 'contract' type"
+ BtHasTicket -> "has 'ticket' type"
+ BtHasSaplingState -> "has 'sapling_state' type"
+
+-- | This class encodes Michelson rules w.r.t where it requires comparable
+-- types. Earlier we had a dedicated type for representing comparable types @CT@.
+-- But then we integreated those types into @T@. This meant that some of the
+-- types that could be formed with various combinations of @T@ would be
+-- illegal as per Michelson typing rule. Using this class, we inductively
+-- enforce that a type and all types it contains are well typed as per
+-- Michelson's rules.
+type WellTyped :: T -> Constraint
+class (SingI t, RecSuperC WellTyped t, WellTypedConstraints t) => WellTyped t
+instance (SingI t, RecSuperC WellTyped t, WellTypedConstraints t) => WellTyped t
+
+-- | Additional (non-recursive) constraints on type arguments for specific types
+type WellTypedConstraints :: T -> Constraint
+type family WellTypedConstraints t where
+ WellTypedConstraints ('TSet t) = Comparable t
+ WellTypedConstraints ('TContract t) = (ForbidOp t, ForbidNestedBigMaps t)
+ WellTypedConstraints ('TTicket t) = Comparable t
+ WellTypedConstraints ('TMap k _) = Comparable k
+ WellTypedConstraints ('TBigMap k v) = (Comparable k, ForbidBigMap v, ForbidOp v)
+ WellTypedConstraints _ = ()
+
+-- | Error type for when a value is not well-typed.
+data NotWellTyped = NotWellTyped
+ { nwtBadType :: T
+ , nwtCause :: BadTypeForScope
+ }
+
+instance Buildable NotWellTyped where
+ build (NotWellTyped t c) =
+ "Given type is not well typed because" ++| quoteOrIndentF t |++^ build c
+
+{- | Given a type, provide evidence that it is well typed w.r.t to the Michelson
+rules regarding where comparable types are required.
+
+>>> either pretty print $ getWTP @'TUnit
+Dict
+>>> either pretty print $ getWTP @('TSet 'TOperation)
+Given type is not well typed because 'operation' is not comparable
+>>> type Pairs a = 'TPair a a
+>>> type Pairs2 = Pairs (Pairs 'TUnit)
+>>> either pretty print $ getWTP @('TSet ('TPair Pairs2 'TOperation))
+Given type is not well typed because
+ pair (pair (pair unit unit) unit unit) operation
+is not comparable
+-}
+getWTP :: forall t. (SingI t) => Either NotWellTyped (Dict (WellTyped t))
+getWTP = getWTP' sing
+
+-- | Version of 'getWTP' that accepts 'Sing' at term-level.
+getWTP' :: Sing t -> Either NotWellTyped (Dict (WellTyped t))
+getWTP' = \case
+ STKey -> Right Dict
+ STUnit -> Right Dict
+ STSignature -> Right Dict
+ STChainId -> Right Dict
+ STOption s -> do
+ Dict <- getWTP' s
+ pure Dict
+ STList s -> do
+ Dict <- getWTP' s
+ pure Dict
+ STSet s -> do
+ Dict <- getWTP' s
+ Dict <- eitherWellTyped BtNotComparable s comparabilityPresence
+ pure Dict
+ STOperation -> Right Dict
+ STContract s -> do
+ Dict <- getWTP' s
+ Refl <- eitherWellTyped BtIsOperation s $ tAbsence SPSOp
+ Refl <- eitherWellTyped BtHasNestedBigMap s $ tAbsence SPSNestedBigMaps
+ pure Dict
+ STTicket s -> do
+ Dict <- getWTP' s
+ Dict <- eitherWellTyped BtNotComparable s comparabilityPresence
+ pure Dict
+ STPair s1 s2 -> do
+ Dict <- getWTP' s1
+ Dict <- getWTP' s2
+ pure Dict
+ STOr s1 s2 -> do
+ Dict <- getWTP' s1
+ Dict <- getWTP' s2
+ pure Dict
+ STLambda s1 s2 -> do
+ Dict <- getWTP' s1
+ Dict <- getWTP' s2
+ pure Dict
+ STMap s1 s2 -> do
+ Dict <- getWTP' s1
+ Dict <- getWTP' s2
+ Dict <- eitherWellTyped BtNotComparable s1 comparabilityPresence
+ pure Dict
+ STBigMap s1 s2 -> do
+ Dict <- getWTP' s1
+ Dict <- getWTP' s2
+ Dict <- eitherWellTyped BtNotComparable s1 $ comparabilityPresence
+ Refl <- eitherWellTyped BtIsOperation s2 $ tAbsence SPSOp
+ Refl <- eitherWellTyped BtHasBigMap s2 $ tAbsence SPSBigMap
+ pure Dict
+ STInt -> Right Dict
+ STNat -> Right Dict
+ STString -> Right Dict
+ STBytes -> Right Dict
+ STMutez -> Right Dict
+ STBool -> Right Dict
+ STKeyHash -> Right Dict
+ STBls12381Fr -> Right Dict
+ STBls12381G1 -> Right Dict
+ STBls12381G2 -> Right Dict
+ STTimestamp -> Right Dict
+ STAddress -> Right Dict
+ STChest -> Right Dict
+ STChestKey -> Right Dict
+ STNever -> Right Dict
+ STSaplingState s -> withSingI s $ Right Dict
+ STSaplingTransaction s -> withSingI s $ Right Dict
+ where
+ eitherWellTyped
+ :: BadTypeForScope
+ -> SingT t
+ -> (SingT t -> Maybe a)
+ -> Either NotWellTyped a
+ eitherWellTyped bt sng f = maybeToRight (NotWellTyped (fromSing sng) bt) $ f sng
diff --git a/src/Morley/Michelson/Typed/Scope/Internal/WithDeMorganScope.hs b/src/Morley/Michelson/Typed/Scope/Internal/WithDeMorganScope.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/Scope/Internal/WithDeMorganScope.hs
@@ -0,0 +1,147 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Morley.Michelson.Typed.Scope.Internal.WithDeMorganScope
+ ( module Morley.Michelson.Typed.Scope.Internal.WithDeMorganScope
+ ) where
+
+import Data.Constraint ((\\))
+import Data.Singletons (Sing, SingI(..))
+import Data.Type.Bool (type (||))
+
+import Data.Type.Equality ((:~:)(..))
+import Morley.Michelson.Typed.Scope.Internal.ForbidT
+import Morley.Michelson.Typed.Scope.Internal.Presence
+import Morley.Michelson.Typed.Scope.Internal.Scopes
+import Morley.Michelson.Typed.Scope.Internal.WellTyped
+import Morley.Michelson.Typed.T (T(..))
+import Morley.Util.StubbedProof (stubProof)
+
+-- | Allows using a scope that can be proven true with a De Morgan law.
+--
+-- Many scopes are defined as @not a@ (or rather @a ~ 'False@) where @a@ is a
+-- negative property we want to avoid as a 'Constraint'.
+-- The negative constraints are implemented with a type family that for some
+-- combination types resolves to itself applied to the type arguments in an @or@,
+-- e.g. A @pair l r@ has @x@ if @l@ or @r@ contain @x@.
+--
+-- Because of the De Morgan laws @not (a or b)@ implies @(not a) and (not b)@
+-- or in our case: @pair@ does not contain @x@ -> @a@ and @b@ don't contain @x@.
+class WithDeMorganScope (c :: T -> Constraint) t a b where
+ withDeMorganScope :: c (t a b) => ((c a, c b) => ret) -> ret
+
+-- | When a class looks like
+--
+-- @
+-- class (SomeTypeFamily t ~ 'False, ...) => TheClass t
+-- instance (SomeTypeFamily t ~ 'False, ...) => TheClass t
+-- @
+--
+-- and the additional constraints are satisfied by the instance constraints of
+-- the 'WithDeMorganScope' instance for @TheClass@, we can use
+-- `simpleWithDeMorgan` to define 'withDeMorganScope' for the instance.
+simpleWithDeMorgan
+ :: forall a b ret op.
+ ((ContainsT op a || ContainsT op b) ~ 'False, SingI a)
+ => Sing op
+ -> ((ContainsT op a ~ 'False, ContainsT op b ~ 'False) => ret)
+ -> ret
+-- Note: If we're lucky, GHC might not build `SingI a` and `SingI op` dictionaries.
+simpleWithDeMorgan sop = simpleWithDeMorgan' @b sop (sing @a)
+
+simpleWithDeMorgan'
+ :: forall b ret op a.
+ ((ContainsT op a || ContainsT op b) ~ 'False)
+ => Sing op
+ -> Sing a
+ -> ((ContainsT op a ~ 'False, ContainsT op b ~ 'False) => ret)
+ -> ret
+simpleWithDeMorgan' sop sa f = f \\
+ stubProof @(ContainsT op b) @'False
+ case checkTPresence sop sa of
+ TAbsent -> Refl
+
+-- | Simpler version of 'withDeMorganScope' for 'ForbidT' constraints.
+deMorganForbidT
+ :: forall a b r p. (ContainsT p a || ContainsT p b) ~ 'False
+ => Sing p
+ -> Sing a
+ -> Sing b
+ -> ((ForbidT p a, ForbidT p b) => r)
+ -> r
+deMorganForbidT p a _ f = simpleWithDeMorgan' @b p a f
+
+instance (SingI a, SingI p) => WithDeMorganScope (ForbidT p) 'TPair a b where
+ withDeMorganScope f = simpleWithDeMorgan @a @b (sing @p) f
+instance (SingI a, SingI p) => WithDeMorganScope (ForbidT p) 'TOr a b where
+ withDeMorganScope f = simpleWithDeMorgan @a @b (sing @p) f
+instance (SingI k, SingI p) => WithDeMorganScope (ForbidT p) 'TMap k v where
+ withDeMorganScope f = case sp of
+ SPSOp -> simpleWithDeMorgan @k @v sp f
+ SPSContract -> simpleWithDeMorgan @k @v sp f
+ SPSTicket -> simpleWithDeMorgan @k @v sp f
+ SPSBigMap -> simpleWithDeMorgan @k @v sp f
+ SPSNestedBigMaps -> simpleWithDeMorgan @k @v sp f
+ SPSSaplingState -> simpleWithDeMorgan @k @v sp f
+ where sp = sing @p
+
+-- NB: BigMap is special because de Morgan rule not applicable to NestedBigMaps
+-- here.
+instance (SingI k) => WithDeMorganScope ForbidOp 'TBigMap k v where
+ withDeMorganScope f = simpleWithDeMorgan @k @v SPSOp f
+instance (SingI k) => WithDeMorganScope ForbidContract 'TBigMap k v where
+ withDeMorganScope f = simpleWithDeMorgan @k @v SPSContract f
+instance (SingI k) => WithDeMorganScope ForbidTicket 'TBigMap k v where
+ withDeMorganScope f = simpleWithDeMorgan @k @v SPSTicket f
+instance (SingI k) => WithDeMorganScope ForbidSaplingState 'TBigMap k v where
+ withDeMorganScope f = simpleWithDeMorgan @k @v SPSSaplingState f
+
+instance
+ ( WithDeMorganScope ForbidOp t a b
+ , WithDeMorganScope ForbidNestedBigMaps t a b
+ , WellTyped a, WellTyped b
+ ) => WithDeMorganScope ParameterScope t a b where
+ withDeMorganScope f =
+ withDeMorganScope @ForbidOp @t @a @b $
+ withDeMorganScope @ForbidNestedBigMaps @t @a @b f
+
+instance
+ ( WithDeMorganScope ForbidOp t a b
+ , WithDeMorganScope ForbidNestedBigMaps t a b
+ , WithDeMorganScope ForbidContract t a b
+ , WellTyped a, WellTyped b
+ ) => WithDeMorganScope StorageScope t a b where
+ withDeMorganScope f =
+ withDeMorganScope @ForbidOp @t @a @b $
+ withDeMorganScope @ForbidNestedBigMaps @t @a @b $
+ withDeMorganScope @ForbidContract @t @a @b f
+
+instance
+ ( WithDeMorganScope ForbidOp t a b
+ , WithDeMorganScope ForbidBigMap t a b
+ , WithDeMorganScope ForbidContract t a b
+ , WithDeMorganScope ForbidTicket t a b
+ , WithDeMorganScope ForbidSaplingState t a b
+ , WellTyped a, WellTyped b
+ ) => WithDeMorganScope ConstantScope t a b where
+ withDeMorganScope f =
+ withDeMorganScope @ForbidOp @t @a @b $
+ withDeMorganScope @ForbidBigMap @t @a @b $
+ withDeMorganScope @ForbidContract @t @a @b $
+ withDeMorganScope @ForbidTicket @t @a @b $
+ withDeMorganScope @ForbidSaplingState @t @a @b f
+
+instance
+ ( WithDeMorganScope ForbidOp t a b
+ , WithDeMorganScope ForbidBigMap t a b
+ , WithDeMorganScope ForbidTicket t a b
+ , WithDeMorganScope ForbidSaplingState t a b
+ , WellTyped a, WellTyped b
+ ) => WithDeMorganScope PackedValScope t a b where
+ withDeMorganScope f =
+ withDeMorganScope @ForbidOp @t @a @b $
+ withDeMorganScope @ForbidBigMap @t @a @b $
+ withDeMorganScope @ForbidTicket @t @a @b $
+ withDeMorganScope @ForbidSaplingState @t @a @b f
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
@@ -20,9 +20,8 @@
import Data.Singletons (SingI(..), demote, fromSing)
import Data.Type.Equality ((:~:)(..))
-import Fmt ((+|), (|+))
+import Fmt (Buildable(..), fmt, nameF)
-import Morley.Michelson.Printer.Util (RenderDoc(..))
import Morley.Michelson.Typed.T (T(..))
import Morley.Util.MismatchError
import Morley.Util.Sing (castSing, eqI, genSingletonsType)
@@ -50,8 +49,9 @@
=> t a -> Either Text (t b)
castSingE = maybeToRight errMsg . castSing
where
- errMsg = "Type mismatch: expected '" +| demote @a |+
- "', but got '" +| demote @b |+ "'"
+ errMsg = fmt
+ $ nameF "Type mismatch"
+ $ build MkMismatchError{ meExpected = demote @a, meActual = demote @b }
-- | Monadic version of 'castSing'.
-- Throws an error using the given function if the cast fails.
@@ -86,5 +86,5 @@
deriveGADTNFData ''SingT
-instance RenderDoc (SingT t) where
- renderDoc pn s = renderDoc pn $ fromSing s
+instance Buildable (SingT t) where
+ build = build . fromSing
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
@@ -10,9 +10,9 @@
) where
import Data.Data (Data)
-import Fmt (Buildable(..), Builder, listF)
+import Fmt (Buildable(..), Doc, listF)
-import Morley.Michelson.Printer.Util (Prettier(..), RenderDoc(..), buildRenderDocExtended)
+import Morley.Michelson.Printer.Util (RenderDoc(..))
import Morley.Michelson.Untyped.Annotation qualified as Un
import Morley.Michelson.Untyped.Type qualified as Un
import Morley.Util.MismatchError
@@ -103,23 +103,14 @@
build = build . toUType
instance Buildable (MismatchError T) where
- build = buildRenderDocExtended
+ build = buildDocDiff
instance Buildable (MismatchError [T]) where
- build = buildRenderDocExtended
+ build = buildDocDiffList
instance RenderDoc T where
renderDoc context = renderDoc context . toUType
-instance RenderDoc (Prettier T) where
- renderDoc context = renderDoc context . fmap toUType
-
-instance RenderDoc (MismatchError T) where
- renderDoc ctx = renderDocDiff ctx . fmap Prettier
-
-instance RenderDoc (MismatchError [T]) where
- renderDoc ctx = renderDocDiffList ctx . (fmap . fmap) Prettier
-
-- | Format type stack in a pretty way.
-buildStack :: [T] -> Builder
+buildStack :: [T] -> Doc
buildStack = listF
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
@@ -41,12 +41,11 @@
import Prelude hiding (Ordering(..))
import Control.Monad.Writer.Strict (Writer, execWriterT, runWriter, tell, writer)
-import Data.Constraint (Dict(..))
+import Data.Constraint (Dict(..), (\\))
import Data.Default (Default(..))
import Data.Generics (listify)
import Data.Map qualified as M
import Data.Set qualified as S
-import Data.Text.Internal.Builder (fromText)
import Fmt (Buildable(..))
import Language.Haskell.TH qualified as TH
@@ -93,7 +92,7 @@
}
instance Buildable (CtorEffectsApp x) where
- build CtorEffectsApp{..} = fromText ceaName
+ build CtorEffectsApp{..} = build ceaName
instance (Applicative x) => Default (DfsSettings x) where
def = DfsSettings
@@ -161,7 +160,7 @@
pure $ SomeView v{ vCode = code }
dsInstrStep $ AnnCREATE_CONTRACT ann $ contract
{ cCode = ContractCode codeI
- , cViews = UnsafeViewsSet viewsI
+ , cViews = ViewsSet viewsI
}
| otherwise -> const $ recursion0 i
SNoChildren -> const $ recursion0 i
@@ -528,7 +527,7 @@
in maybe (PartlyPushableStorage v Nop) PushableValueStorage $
foldM handleList NIL vals
- VSet{} -> ConstantStorage v
+ VSet (_ :: Set (Value t)) -> ConstantStorage v \\ comparableImplies (Proxy @t)
VPair (v1 :: Value t1, v2 :: Value t2) ->
withValueTypeSanity v1 $ withValueTypeSanity v2 $
@@ -577,17 +576,10 @@
PushableValueStorage instr -> PushableValueStorage $ instr `Seq` RIGHT
PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` RIGHT
- VMap (vMap :: (Map (Value tk) (Value tv))) -> case checkScope @(ConstantScope tk) of
- Left _ ->
- -- NOTE: all keys for a map need to be comparable and (even tho it's
- -- not a superclass) that means they have to be constants.
- -- I (@pasqu4le) found no exception to this rule, perhaps it should be
- -- enforced in the type system as well, but it may have more
- -- downsides than it's worth accepting.
- error "impossible: all map keys should be PUSHable"
- Right Dict -> case checkScope @(ConstantScope tv) of
+ VMap (vMap :: (Map (Value tk) (Value tv))) | Dict <- comparableImplies (Proxy @tk) ->
+ case checkScope @(ConstantScope tv) of
Right Dict -> ConstantStorage v
- _ -> withDeMorganScope @HasNoOp @'T.TMap @tk @tv $
+ _ -> withDeMorganScope @ForbidOp @'T.TMap @tk @tv $
-- Similarly as for lists, here we check that even tho the value type
-- contains a big_map, we actually have big_maps in (one or more of) them.
let handleMap
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
@@ -32,7 +32,7 @@
import Control.Lens (At(..), Index, IxValue, Ixed(..))
import Data.Constraint (Dict(..), (\\))
import Data.GADT.Compare (GEq(..))
-import Fmt (Buildable(build), Builder, (+|), (|+))
+import Fmt (Buildable(build), Doc, (+|), (|+))
import Morley.Michelson.Text (MText)
import Morley.Michelson.Typed.Annotation (Notes)
@@ -210,11 +210,21 @@
instance (Comparable t) => Ord (Value' instr t) where
compare = tcompare @t
--- | Representation of Michelson value.
---
--- Type parameter @instr@ stands for Michelson instruction
--- type, i.e. data type to represent an instruction of language.
+{- | Representation of a Michelson value.
+Since values (i.e. lambdas, operations) can include instructions, this type
+depends on the type used to represent instructions, which is the parameter
+@instr@. It is itself a polymorphic type, parametrized by the Michelson types of
+its input and output stacks.
+
+The primary motivator for polymorphism is breaking cyclic dependencies between
+this module and "Morley.Michelson.Typed.Instr". In principle @instr@ can also be
+used as an extension point, but at the time of writing it isn't used as such, it
+is always eventually unified with @Instr@.
+
+@t@ is the value's Michelson type.
+-}
+type Value' :: ([T] -> [T] -> Type) -> T -> Type
data Value' instr t where
VKey :: PublicKey -> Value' instr 'TKey
VUnit :: Value' instr 'TUnit
@@ -230,13 +240,13 @@
=> [Value' instr t] -> Value' instr ('TList t)
VSet
:: forall t instr.
- (SingI t, Comparable t)
+ Comparable t
=> Set (Value' instr t) -> Value' instr ('TSet t)
VOp
:: Operation' instr -> Value' instr 'TOperation
VContract
:: forall arg instr.
- (SingI arg, HasNoOp arg)
+ (SingI arg, ForbidOp arg)
=> Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)
VTicket
:: forall arg instr.
@@ -250,21 +260,16 @@
(SingI l, SingI r)
=> Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)
VLam
- :: 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)
- )
+ :: forall inp out instr. (SingI inp, SingI out)
=> LambdaCode' instr inp out
-> Value' instr ('TLambda inp out)
VMap
:: forall k v instr.
- (SingI k, SingI v, Comparable k)
+ (SingI v, Comparable k)
=> Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)
VBigMap
:: forall k v instr.
- (SingI k, SingI v, Comparable k, HasNoBigMap v)
+ (SingI v, Comparable k, ForbidBigMap v)
=> Maybe Natural -- ^ The big_map's ID. This is only used in the interpreter.
-> Map (Value' instr k) (Value' instr v)
-> Value' instr ('TBigMap k v)
@@ -286,6 +291,13 @@
deriving stock instance Show (Value' instr t)
deriving stock instance Eq (Value' instr t)
+{- | Code of a lambda value, either recursive or non-recursive.
+
+Note the quantified constraints on the constructors. We opt to carry those here
+and not on the respective instances for the sake of simplifying downstream
+instance definitions. Constraining each instance with quantified constraints
+gets very long-winded very fast, and it wouldn't work with 'deriveGADTNFData'.
+-}
data LambdaCode' instr inp out where
LambdaCode
:: ( forall i o. Show (instr i o)
@@ -314,7 +326,7 @@
=> KindedAddress kind -> Value' instr ('TContract t)
addressToVContract addr = VContract (MkAddress addr) sepcPrimitive
-buildVContract :: Value' instr ('TContract arg) -> Builder
+buildVContract :: Value' instr ('TContract arg) -> Doc
buildVContract = \case
VContract addr epc -> "Contract " +| addr |+ " call " +| epc |+ ""
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
@@ -18,7 +18,7 @@
, someViewName
-- * Views set
- , ViewsSet' (.., ViewsList)
+ , ViewsSet' (.., ViewsList, UnsafeViewsSet)
, VS.ViewsSetError (..)
, mkViewsSet
, emptyViewsSet
@@ -80,9 +80,14 @@
----------------------------------------------------------------------------
-- | Views that belong to one contract.
-newtype ViewsSet' instr st = UnsafeViewsSet { unViewsSet :: Map ViewName (SomeView' instr st) }
+newtype ViewsSet' instr st = ViewsSet { unViewsSet :: Map ViewName (SomeView' instr st) }
deriving newtype (Default, Container)
+pattern UnsafeViewsSet :: Map ViewName (SomeView' instr st) -> ViewsSet' instr st
+pattern UnsafeViewsSet x = ViewsSet x
+{-# COMPLETE UnsafeViewsSet #-}
+{-# DEPRECATED UnsafeViewsSet "Use ViewsSet instead" #-}
+
deriving stock instance
(forall i o. Show (instr i o)) =>
Show (ViewsSet' instr st)
@@ -92,10 +97,10 @@
instance
(forall i o. NFData (instr i o)) =>
NFData (ViewsSet' instr st) where
- rnf (UnsafeViewsSet vs) = rnf vs
+ rnf (ViewsSet vs) = rnf vs
pattern ViewsList :: [SomeView' instr st] -> ViewsSet' instr st
-pattern ViewsList views <- UnsafeViewsSet (toList -> views)
+pattern ViewsList views <- ViewsSet (toList -> views)
{-# COMPLETE ViewsList #-}
-- | Construct views set.
diff --git a/src/Morley/Michelson/Untyped/Aliases.hs b/src/Morley/Michelson/Untyped/Aliases.hs
--- a/src/Morley/Michelson/Untyped/Aliases.hs
+++ b/src/Morley/Michelson/Untyped/Aliases.hs
@@ -15,7 +15,7 @@
import Morley.Michelson.Untyped.Instr qualified as Untyped
import Morley.Michelson.Untyped.Value qualified as Untyped
-type Value = Untyped.Value' Untyped.ExpandedOp
+type Value = Untyped.Value' [] Untyped.ExpandedOp
type View = Untyped.View' Untyped.ExpandedOp
type Contract = Untyped.Contract' Untyped.ExpandedOp
-type ExpandedExtInstr = Untyped.ExtInstrAbstract Untyped.ExpandedOp
+type ExpandedExtInstr = Untyped.ExtInstrAbstract [] Untyped.ExpandedOp
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
@@ -54,16 +54,16 @@
import Data.Default (Default(..))
import Data.Text qualified as T
import Data.Typeable (eqT, (:~:)(..))
-import Fmt (Buildable(build))
+import Fmt (Doc, build, (<+>))
import Instances.TH.Lift ()
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax (Lift)
-import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>))
+import Prettyprinter (hsep)
import Text.Show qualified as T
import Type.Reflection (tyConName, typeRep, typeRepTyCon)
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)
+import Morley.Michelson.Printer.Util (RenderDoc(..))
import Morley.Util.Aeson
-- | Generic Type/Field/Variable Annotation
@@ -253,22 +253,16 @@
instance RenderDoc AnyAnn where
renderDoc _ = renderAnyAnn
-instance KnownAnnTag tag => Buildable (Annotation tag) where
- build = buildRenderDoc
-
instance RenderDoc AnnotationSet where
renderDoc _ (AnnotationSet {..}) =
renderAnnGroup asTypes <+> renderAnnGroup asFields <+> renderAnnGroup asVars
-instance Buildable AnnotationSet where
- build = buildRenderDoc
-
-- | Renders a single t'Annotation', this is used in every rendering instance of it.
-- Note that this also renders empty ones/'noAnn's because a single t'Annotation'
-- does not have enough context to know if it can be omitted, use 'singleAnnSet'
-- if you want to hide it instead.
renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc
-renderAnn (Annotation text) = textStrict $ annPrefix @tag <> text
+renderAnn (Annotation text) = build $ annPrefix @tag <> text
renderAnyAnn :: AnyAnn -> Doc
renderAnyAnn = \case
diff --git a/src/Morley/Michelson/Untyped/Contract.hs b/src/Morley/Michelson/Untyped/Contract.hs
--- a/src/Morley/Michelson/Untyped/Contract.hs
+++ b/src/Morley/Michelson/Untyped/Contract.hs
@@ -11,28 +11,29 @@
, mkEntriesOrder
, ContractBlock (..)
+ , ContractBlockError (..)
, orderContractBlock
, Contract' (..)
, View' (..)
, Storage
- , mapContractCode
) where
-import Control.Lens (folded, makePrisms)
+import Control.Lens (Prism', makePrisms)
import Data.Aeson (FromJSON, FromJSONKey(..), ToJSON, ToJSONKey(..))
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Types qualified as AesonTypes
+import Data.Bitraversable (bitraverse)
import Data.Data (Data(..))
import Data.Default (Default(..))
import Data.Map qualified as Map
import Data.Text (stripPrefix)
-import Fmt (Buildable(build), pretty)
-import Text.PrettyPrint.Leijen.Text (nest, semi, text, (<$$>), (<+>))
-import Text.PrettyPrint.Leijen.Text qualified as PP
+import Fmt (Buildable(build), listF, nameF, pretty, (<$$>), (<+>))
+import Fmt.Operators qualified as PP
+import Prettyprinter (semi)
+import Prettyprinter qualified as PP
import Morley.Michelson.Printer.Util
- (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList)
import Morley.Michelson.Untyped.Type (ParameterType(..), Ty(..))
import Morley.Michelson.Untyped.View
import Morley.Util.Aeson
@@ -44,6 +45,13 @@
| EntryView ViewName
deriving stock (Eq, Ord, Show, Data, Generic)
+instance Buildable Entry where
+ build = \case
+ EntryParameter -> "parameter"
+ EntryStorage -> "storage"
+ EntryCode -> "code"
+ EntryView name -> nameF "view" $ build name
+
deriveJSON morleyAesonOptions ''Entry
instance ToJSONKey Entry where
@@ -88,34 +96,71 @@
data ContractBlock op
= CBParam ParameterType
| CBStorage Ty
- | CBCode [op]
+ | CBCode op
| CBView (View' op)
deriving stock (Eq, Show, Functor)
makePrisms ''ContractBlock
+makePrisms ''Entry
+data ContractBlockError
+ = CBEDuplicate (NonEmpty Entry)
+ | CBEMissing Entry
+ deriving stock (Eq, Show)
+
+instance Buildable ContractBlockError where
+ build = \case
+ CBEDuplicate (b :| []) -> nameF "Duplicate contract field" $ build b
+ CBEDuplicate bs -> nameF "Duplicate contract fields" $ listF bs
+ CBEMissing entry -> nameF "Missing contract field" $ build entry
+
+newtype Validation e a = Validation { unValidation :: Either e a }
+ deriving stock (Show, Eq)
+ deriving newtype (Functor)
+
+instance Semigroup e => Applicative (Validation e) where
+ pure = Validation . Right
+ Validation (Left e1) <*> Validation r = Validation $ Left $ either (e1 <>) (const e1) r
+ Validation (Right f) <*> x = f <$> x
+
-- | Construct a contract representation from the contract blocks (i.e. parameters,
-- storage, code blocks, etc.) in arbitrary order.
-- This makes sure that unique blocks like @code@ do not duplicate, and saves the
-- order in the contract so that it can print the contract blocks in the same
-- order it was parsed.
-orderContractBlock :: [ContractBlock op] -> Maybe (Contract' op)
+orderContractBlock
+ :: forall op. [ContractBlock op]
+ -> Either (NonEmpty ContractBlockError) (Contract' op)
orderContractBlock blocks =
let
- -- we are sure there are no duplicate view names due to the guard below, so
- -- we can construct a Map right away
- contractViews = unsafe . mkViewsSet $ blocks ^.. folded . _CBView
- blockTypes = blocks <&> \case
+ blockToBlockType = \case
CBParam{} -> EntryParameter
CBStorage{} -> EntryStorage
CBCode{} -> EntryCode
CBView View{..} -> EntryView viewName
- entriesOrder = mkEntriesOrder blockTypes
- in do
- guard $ blockTypes == ordNub blockTypes -- must have no duplicates
- contractParameter <- blocks ^? folded . _CBParam
- contractStorage <- blocks ^? folded . _CBStorage
- contractCode <- blocks ^? folded . _CBCode
+ duplicates :: [Entry]
+ blockMap :: Map Entry (Word, ContractBlock op)
+ (duplicates, blockMap) =
+ foldr go (mempty, mempty) (zip blocks [0..])
+ where
+ go (b, n) (!dups, !seen) =
+ let blockType = blockToBlockType b
+ dups' | Map.member blockType seen = blockType:dups
+ | otherwise = dups
+ in (dups', Map.insert blockType (n, b) seen)
+ entriesOrder = EntriesOrder $ fst <$> blockMap
+ getBlock :: Entry -> Prism' (ContractBlock op) a -> Validation (NonEmpty ContractBlockError) a
+ getBlock ty prism = Validation $ maybeToRight (one $ CBEMissing ty) $
+ Map.lookup ty blockMap >>= preview (_2 . prism)
+ contractViews = ViewsSet
+ . Map.fromDistinctAscList -- we know that keys are still unique and sorted
+ . mapMaybe (bitraverse (preview _EntryView) (preview $ _2 . _CBView))
+ $ toPairs blockMap
+ in unValidation do
+ Validation $ nonEmpty duplicates & maybeToLeft () . fmap (one . CBEDuplicate)
+ contractParameter <- getBlock EntryParameter _CBParam
+ contractStorage <- getBlock EntryStorage _CBStorage
+ contractCode <- getBlock EntryCode _CBCode
pure Contract{..}
instance Buildable (ContractBlock op) where
@@ -130,7 +175,7 @@
:: Contract' op
-> (ParameterType -> a)
-> (Storage -> a)
- -> ([op] -> a)
+ -> (op -> a)
-> (View' op -> a)
-> [a]
mapEntriesOrdered Contract{..} fParam fStorage fCode fView = snd <$> sortWith fst elements
@@ -152,7 +197,7 @@
-- ^ Contract parameter type
, contractStorage :: Storage
-- ^ Contract storage type
- , contractCode :: [op]
+ , contractCode :: op
-- ^ Contract code as a list of operations
, entriesOrder :: EntriesOrder
-- ^ Original order of contract blocks, so that we can print them
@@ -166,26 +211,18 @@
instance (RenderDoc op) => RenderDoc (Contract' op) where
renderDoc pn contract =
assertParensNotNeeded pn
- $ foldr (<$$>) (text "")
+ $ foldr (<$$>) mempty
$ mapEntriesOrdered contract
- (\parameter -> "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi)
- (\storage -> "storage" <+> renderDoc needsParens (Prettier storage) <> semi)
- (\code -> "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi))
+ (\parameter -> "parameter" <+> renderDoc needsParens parameter <> semi)
+ (\storage -> "storage" <+> renderDoc needsParens storage <> semi)
+ (\code -> "code" <+> PP.align (renderDoc doesntNeedParens code <> semi))
(\View{..} -> PP.group $ "view" <+> PP.align (
PP.sep
[ renderViewName viewName
, renderDoc needsParens viewArgument
, renderDoc needsParens viewReturn
]
- PP.<$> renderOpsList False viewCode <> semi
- ))
-
-instance RenderDoc op => Buildable (Contract' op) where
- build = buildRenderDoc
-
--- | Map all the instructions appearing in the contract.
-mapContractCode :: (op -> op) -> Contract' op -> Contract' op
-mapContractCode f = fmap f
-{-# DEPRECATED mapContractCode "Use fmap instead" #-}
+ PP.<$> renderDoc doesntNeedParens viewCode <> semi
+ ))
deriveJSON morleyAesonOptions ''Contract'
diff --git a/src/Morley/Michelson/Untyped/Entrypoints.hs b/src/Morley/Michelson/Untyped/Entrypoints.hs
--- a/src/Morley/Michelson/Untyped/Entrypoints.hs
+++ b/src/Morley/Michelson/Untyped/Entrypoints.hs
@@ -18,14 +18,13 @@
import Data.Aeson.TH (deriveJSON)
import Data.Map qualified as Map
-import Fmt (Buildable(..), pretty)
+import Fmt (Buildable(..), pretty, (<+>))
+import Prettyprinter (enclose)
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)
import Morley.Michelson.Untyped.Annotation
import Morley.Michelson.Untyped.Type
import Morley.Util.Aeson
import Morley.Util.CLI
-import Text.PrettyPrint.Leijen.Text (enclose, (<+>))
-- | Entrypoint name.
--
@@ -109,12 +108,9 @@
instance NFData EpNameFromRefAnnError
instance Buildable EpNameFromRefAnnError where
- build = buildRenderDoc
-
-instance RenderDoc EpNameFromRefAnnError where
- renderDoc _ = \case
+ build = \case
InEpNameBadAnnotation (Annotation an) ->
- "Invalid entrypoint reference" <+> (enclose "`" "`" $ renderAnyBuildable an)
+ "Invalid entrypoint reference" <+> enclose "`" "`" (build an)
-- | Make up 'EpName' from annotation which is reference to an entrypoint.
-- Note that it's more common for Michelson to prohibit explicit @default@
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
@@ -15,13 +15,16 @@
) where
import Data.Aeson.TH (deriveJSON)
+import Data.Aeson.Types
+ (FromJSON(..), ToJSON(..), genericParseJSON, genericToEncoding, genericToJSON)
import Data.Data (Data(..))
import Data.Set qualified as Set
import Data.Text qualified as T
-import Fmt (Buildable(build), Builder, GenericBuildable(..), listF)
-import Text.PrettyPrint.Leijen.Text (textStrict)
+import Fmt (Buildable(build), Doc, blockListF, blockMapF, listF, nameF)
+import Prettyprinter (align, enclose)
import Morley.Michelson.Printer.Util (RenderDoc(..))
+import Morley.Michelson.Untyped.HoistInstr
import Morley.Michelson.Untyped.Type
import Morley.Util.Aeson
@@ -35,21 +38,28 @@
-- Additionaly, some implementation-specific language features such as
-- type-checking of @LetMacro@s are implemented using this mechanism
-- (specifically @FN@ and @FN_END@).
-data ExtInstrAbstract op =
+data ExtInstrAbstract f op =
STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern
- | UTEST_ASSERT (TestAssert op) -- ^ Copy the current stack and run an inline assertion on it
+ | UTEST_ASSERT (TestAssert f 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)
-deriving via GenericBuildable (ExtInstrAbstract op) instance Buildable op => Buildable (ExtInstrAbstract op)
+instance HoistInstr ExtInstrAbstract where
+ hoistInstr f = \case
+ STACKTYPE x -> STACKTYPE x
+ UTEST_ASSERT x -> UTEST_ASSERT $ hoistInstr f x
+ UPRINT x -> UPRINT x
+ UCOMMENT x -> UCOMMENT x
-instance NFData op => NFData (ExtInstrAbstract op)
+instance (Foldable f, Buildable op) => Buildable (ExtInstrAbstract f op)
-instance RenderDoc (ExtInstrAbstract op) where
+instance NFData (f op) => NFData (ExtInstrAbstract f op)
+
+instance RenderDoc (ExtInstrAbstract f op) where
renderDoc _ =
\case
- UCOMMENT t -> textStrict ("/* " <> t <> " */")
+ UCOMMENT t -> enclose "/* " " */" $ align $ build t
_ -> mempty
isRenderable =
\case
@@ -68,7 +78,7 @@
-- | A (named) type variable
newtype Var = Var T.Text
deriving stock (Eq, Show, Ord, Data, Generic)
- deriving Buildable via GenericBuildable Var
+ deriving anyclass Buildable
instance NFData Var
@@ -77,7 +87,7 @@
VarID Var
| TyCon Ty
deriving stock (Eq, Show, Data, Generic)
- deriving Buildable via GenericBuildable TyVar
+ deriving anyclass Buildable
instance NFData TyVar
@@ -102,7 +112,7 @@
instance Buildable StackTypePattern where
build = listF . pairToList . stackTypePatternToList
where
- pairToList :: ([TyVar], Bool) -> [Builder]
+ pairToList :: ([TyVar], Bool) -> [Doc]
pairToList (types, fixed)
| fixed = map build types
| otherwise = map build types ++ ["..."]
@@ -126,25 +136,45 @@
build = foldMap (either build build) . unUPrintComment
-- | An inline test assertion
-data TestAssert op = TestAssert
+data TestAssert f (op :: Type) = TestAssert
{ tassName :: T.Text
, tassComment :: PrintComment
- , tassInstrs :: [op]
+ , tassInstrs :: f op
} deriving stock (Eq, Show, Functor, Data, Generic)
-instance NFData op => NFData (TestAssert op)
+instance HoistInstr TestAssert where
+ hoistInstr f TestAssert{..} = TestAssert{tassInstrs = f tassInstrs, ..}
-deriving via GenericBuildable (TestAssert op) instance Buildable op => Buildable (TestAssert op)
+instance NFData (f op) => NFData (TestAssert f op)
+instance (Foldable f, Buildable op) => Buildable (TestAssert f op) where
+ build (TestAssert name comment instrs) =
+ nameF "TestAssert" $ blockMapF
+ [ ("Name" :: Text, build name)
+ , ("Comment", build comment)
+ , ("Instrs", blockListF instrs)
+ ]
+
-------------------------------------
-- Aeson instances
-------------------------------------
deriveJSON morleyAesonOptions ''StackRef
deriveJSON morleyAesonOptions ''PrintComment
-deriveJSON morleyAesonOptions ''TestAssert
+
+instance FromJSON (f op) => FromJSON (TestAssert f op) where
+ parseJSON = genericParseJSON morleyAesonOptions
+instance ToJSON (f op) => ToJSON (TestAssert f op) where
+ toJSON = genericToJSON morleyAesonOptions
+ toEncoding = genericToEncoding morleyAesonOptions
+
deriveJSON morleyAesonOptions ''Var
deriveJSON morleyAesonOptions ''TyVar
deriveJSON morleyAesonOptions ''StackTypePattern
-deriveJSON morleyAesonOptions ''ExtInstrAbstract
+
+instance FromJSON (f op) => FromJSON (ExtInstrAbstract f op) where
+ parseJSON = genericParseJSON morleyAesonOptions
+instance ToJSON (f op) => ToJSON (ExtInstrAbstract f op) where
+ toJSON = genericToJSON morleyAesonOptions
+ toEncoding = genericToEncoding morleyAesonOptions
diff --git a/src/Morley/Michelson/Untyped/HoistInstr.hs b/src/Morley/Michelson/Untyped/HoistInstr.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Untyped/HoistInstr.hs
@@ -0,0 +1,10 @@
+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+module Morley.Michelson.Untyped.HoistInstr
+ ( HoistInstr(..)
+ ) where
+
+-- | Helper class used to change underlying sequence functor in instructions.
+class HoistInstr n where
+ hoistInstr :: (f a -> g a) -> n f a -> n g a
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
@@ -13,20 +13,22 @@
import Prelude hiding (EQ, GT, LT, group)
import Data.Aeson.TH (deriveJSON)
+import Data.Aeson.Types
+ (FromJSON(..), ToJSON(..), genericParseJSON, genericToEncoding, genericToJSON)
import Data.Data (Data(..))
-import Fmt (Buildable(build), (+|), (|+))
+import Fmt (Buildable(build), Doc, isEmpty, (+|), (<+>), (|+))
import Generics.SYB (everywhere, mkT)
-import Text.PrettyPrint.Leijen.Text (Doc, align, braces, enclose, group, integer, space, (<+>))
-import Text.PrettyPrint.Leijen.Text qualified as PP
+import Prettyprinter (align, braces, enclose, group, space)
+import Prettyprinter qualified as PP
import Morley.Michelson.ErrorPos (ErrorSrcPos)
-import Morley.Michelson.Printer.Util
- (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, renderOpsList)
+import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, needsParens, renderOpsList)
import Morley.Michelson.Untyped.Annotation
(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.Ext
+import Morley.Michelson.Untyped.HoistInstr
import Morley.Michelson.Untyped.Type (Ty)
import Morley.Michelson.Untyped.Value (Value'(..))
import Morley.Michelson.Untyped.View
@@ -36,7 +38,7 @@
-- Types after macroexpander
-------------------------------------
-type ExpandedInstr = InstrAbstract ExpandedOp
+type ExpandedInstr = InstrAbstract [] ExpandedOp
data ExpandedOp
= PrimEx ExpandedInstr
@@ -85,13 +87,131 @@
-- Abstract instruction
-------------------------------------
+instance HoistInstr InstrAbstract where
+ hoistInstr f = \case
+ EXT x -> EXT $ hoistInstr f x
+ IF_NONE l r -> IF_NONE (f l) (f r)
+ IF_LEFT l r -> IF_LEFT (f l) (f r)
+ IF_CONS l r -> IF_CONS (f l) (f r)
+ MAP ann r -> MAP ann (f r)
+ ITER l -> ITER (f l)
+ IF l r -> IF (f l) (f r)
+ LOOP l -> LOOP (f l)
+ LOOP_LEFT l -> LOOP_LEFT (f l)
+ LAMBDA ann tl tr r -> LAMBDA ann tl tr (f r)
+ LAMBDA_REC ann tl tr r -> LAMBDA_REC ann tl tr (f r)
+ DIP l -> DIP (f l)
+ DIPN w r -> DIPN w (f r)
+ PUSH va x y -> PUSH va x $ hoistInstr f y
+ ---
+ DROPN va -> DROPN va
+ DROP -> DROP
+ DUP va -> DUP va
+ DUPN va x -> DUPN va x
+ SWAP -> SWAP
+ DIG va -> DIG va
+ DUG va -> DUG va
+ SOME va x -> SOME va x
+ NONE va x y -> NONE va x y
+ UNIT va x -> UNIT va x
+ PAIR va x y z -> PAIR va x y z
+ UNPAIR va x y z -> UNPAIR va x y z
+ PAIRN va x -> PAIRN va x
+ UNPAIRN va -> UNPAIRN va
+ CAR va x -> CAR va x
+ CDR va x -> CDR va x
+ LEFT va x y z w -> LEFT va x y z w
+ RIGHT va x y z w -> RIGHT va x y z w
+ NIL va x y -> NIL va x y
+ CONS va -> CONS va
+ SIZE va -> SIZE va
+ EMPTY_SET va x y -> EMPTY_SET va x y
+ EMPTY_MAP va x y z -> EMPTY_MAP va x y z
+ EMPTY_BIG_MAP va x y z -> EMPTY_BIG_MAP va x y z
+ MEM va -> MEM va
+ GET va -> GET va
+ GETN va x -> GETN va x
+ UPDATE va -> UPDATE va
+ UPDATEN va x -> UPDATEN va x
+ GET_AND_UPDATE va -> GET_AND_UPDATE va
+ EXEC va -> EXEC va
+ APPLY va -> APPLY va
+ FAILWITH -> FAILWITH
+ CAST va x -> CAST va x
+ RENAME va -> RENAME va
+ PACK va -> PACK va
+ UNPACK va x y -> UNPACK va x y
+ CONCAT va -> CONCAT va
+ SLICE va -> SLICE va
+ ISNAT va -> ISNAT va
+ ADD va -> ADD va
+ SUB va -> SUB va
+ SUB_MUTEZ va -> SUB_MUTEZ va
+ MUL va -> MUL va
+ EDIV va -> EDIV va
+ ABS va -> ABS va
+ NEG va -> NEG va
+ LSL va -> LSL va
+ LSR va -> LSR va
+ OR va -> OR va
+ AND va -> AND va
+ XOR va -> XOR va
+ NOT va -> NOT va
+ COMPARE va -> COMPARE va
+ EQ va -> EQ va
+ NEQ va -> NEQ va
+ LT va -> LT va
+ GT va -> GT va
+ LE va -> LE va
+ GE va -> GE va
+ INT va -> INT va
+ VIEW va x y -> VIEW va x y
+ SELF va x -> SELF va x
+ CONTRACT va x y -> CONTRACT va x y
+ TRANSFER_TOKENS va -> TRANSFER_TOKENS va
+ SET_DELEGATE va -> SET_DELEGATE va
+ CREATE_CONTRACT va x y -> CREATE_CONTRACT va x y
+ IMPLICIT_ACCOUNT va -> IMPLICIT_ACCOUNT va
+ NOW va -> NOW va
+ AMOUNT va -> AMOUNT va
+ BALANCE va -> BALANCE va
+ VOTING_POWER va -> VOTING_POWER va
+ TOTAL_VOTING_POWER va -> TOTAL_VOTING_POWER va
+ CHECK_SIGNATURE va -> CHECK_SIGNATURE va
+ SHA256 va -> SHA256 va
+ SHA512 va -> SHA512 va
+ BLAKE2B va -> BLAKE2B va
+ SHA3 va -> SHA3 va
+ KECCAK va -> KECCAK va
+ HASH_KEY va -> HASH_KEY va
+ PAIRING_CHECK va -> PAIRING_CHECK va
+ SOURCE va -> SOURCE va
+ SENDER va -> SENDER va
+ ADDRESS va -> ADDRESS va
+ CHAIN_ID va -> CHAIN_ID va
+ LEVEL va -> LEVEL va
+ SELF_ADDRESS va -> SELF_ADDRESS va
+ NEVER -> NEVER
+ TICKET va -> TICKET va
+ TICKET_DEPRECATED va -> TICKET_DEPRECATED va
+ READ_TICKET va -> READ_TICKET va
+ SPLIT_TICKET va -> SPLIT_TICKET va
+ JOIN_TICKETS va -> JOIN_TICKETS va
+ OPEN_CHEST va -> OPEN_CHEST va
+ SAPLING_EMPTY_STATE va x -> SAPLING_EMPTY_STATE va x
+ SAPLING_VERIFY_UPDATE va -> SAPLING_VERIFY_UPDATE va
+ MIN_BLOCK_TIME va -> MIN_BLOCK_TIME va
+ EMIT va x y -> EMIT va x y
+ BYTES va -> BYTES va
+ NAT va -> NAT va
+
-- | Michelson instruction with abstract parameter @op@. This
-- parameter is necessary, because at different stages of our pipeline
-- it will be different. Initially it can contain macros and
-- non-flattened instructions, but then it contains only vanilla
-- Michelson instructions.
-data InstrAbstract op
- = EXT (ExtInstrAbstract op)
+data InstrAbstract f op
+ = EXT (ExtInstrAbstract f op)
| DROPN Word
-- ^ "DROP n" instruction.
-- Note: reference implementation permits int16 here.
@@ -111,11 +231,11 @@
| SWAP
| DIG Word
| DUG Word
- | PUSH VarAnn Ty (Value' op)
+ | PUSH VarAnn Ty (Value' f op)
| SOME TypeAnn VarAnn
| NONE TypeAnn VarAnn Ty
| UNIT TypeAnn VarAnn
- | IF_NONE [op] [op]
+ | IF_NONE (f op) (f op)
| PAIR TypeAnn VarAnn FieldAnn FieldAnn
| UNPAIR VarAnn VarAnn FieldAnn FieldAnn
| PAIRN VarAnn Word
@@ -124,31 +244,31 @@
| CDR VarAnn FieldAnn
| LEFT TypeAnn VarAnn FieldAnn FieldAnn Ty
| RIGHT TypeAnn VarAnn FieldAnn FieldAnn Ty
- | IF_LEFT [op] [op]
+ | IF_LEFT (f op) (f op)
| NIL TypeAnn VarAnn Ty
| CONS VarAnn
- | IF_CONS [op] [op]
+ | IF_CONS (f op) (f op)
| SIZE VarAnn
| EMPTY_SET TypeAnn VarAnn Ty
| EMPTY_MAP TypeAnn VarAnn Ty Ty
| EMPTY_BIG_MAP TypeAnn VarAnn Ty Ty
- | MAP VarAnn [op]
- | ITER [op]
+ | MAP VarAnn (f op)
+ | ITER (f op)
| MEM VarAnn
| GET VarAnn
| GETN VarAnn Word
| UPDATE VarAnn
| UPDATEN VarAnn Word
| GET_AND_UPDATE VarAnn
- | IF [op] [op]
- | LOOP [op]
- | LOOP_LEFT [op]
- | LAMBDA VarAnn Ty Ty [op]
- | LAMBDA_REC VarAnn Ty Ty [op]
+ | IF (f op) (f op)
+ | LOOP (f op)
+ | LOOP_LEFT (f op)
+ | LAMBDA VarAnn Ty Ty (f op)
+ | LAMBDA_REC VarAnn Ty Ty (f op)
| EXEC VarAnn
| APPLY VarAnn
- | DIP [op]
- | DIPN Word [op]
+ | DIP (f op)
+ | DIPN Word (f op)
| FAILWITH
| CAST VarAnn Ty
| RENAME VarAnn
@@ -219,18 +339,18 @@
| NAT VarAnn
deriving stock (Eq, Functor, Data, Generic, Show)
-instance NFData op => NFData (InstrAbstract op)
+instance (NFData op, NFData (f op)) => NFData (InstrAbstract f op)
-instance (RenderDoc op) => RenderDoc (InstrAbstract op) where
+instance (RenderDoc op, Foldable f) => RenderDoc (InstrAbstract f op) where
renderDoc pn = \case
EXT extInstr -> renderDoc pn extInstr
DROP -> "DROP"
- DROPN n -> "DROP" <+> integral n
+ DROPN n -> "DROP" <+> build n
DUP va -> "DUP" <+> renderAnnot va
- DUPN va n -> "DUP" <+> renderAnnot va <+> integral n
+ DUPN va n -> "DUP" <+> renderAnnot va <+> build n
SWAP -> "SWAP"
- DIG n -> "DIG" <+> integral n
- DUG n -> "DUG" <+> integral n
+ DIG n -> "DIG" <+> build n
+ DUG n -> "DUG" <+> build n
PUSH va t v ->
renderArgs "PUSH" (renderAnnot va) [renderTy t, renderDoc needsParens v]
SOME ta va -> "SOME" <+> renderAnnots [ta] [] [va]
@@ -239,8 +359,8 @@
IF_NONE x y -> renderArgs "IF_NONE" mempty [renderOps x, renderOps y]
PAIR ta va fa1 fa2 -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]
UNPAIR va1 va2 fa1 fa2 -> "UNPAIR" <+> renderAnnots [] [fa1, fa2] [va1, va2]
- PAIRN va n -> "PAIR" <+> renderAnnots [] [] [va] <+> integral n
- UNPAIRN n -> "UNPAIR" <+> integral n
+ PAIRN va n -> "PAIR" <+> renderAnnots [] [] [va] <+> build n
+ UNPAIRN n -> "UNPAIR" <+> build n
CAR va fa -> "CAR" <+> renderAnnots [] [fa] [va]
CDR va fa -> "CDR" <+> renderAnnots [] [fa] [va]
LEFT ta va fa1 fa2 t -> renderArgs "LEFT" (renderAnnots [ta] [fa1, fa2] [va]) [renderTy t]
@@ -259,9 +379,9 @@
ITER s -> renderArgs "ITER" mempty [renderOps s]
MEM va -> "MEM" <+> renderAnnot va
GET va -> "GET" <+> renderAnnot va
- GETN va n -> "GET" <+> renderAnnot va <+> integral n
+ GETN va n -> "GET" <+> renderAnnot va <+> build n
UPDATE va -> "UPDATE" <+> renderAnnot va
- UPDATEN va n -> "UPDATE" <+> renderAnnot va <+> integral n
+ UPDATEN va n -> "UPDATE" <+> renderAnnot va <+> build n
GET_AND_UPDATE va -> "GET_AND_UPDATE" <+> renderAnnot va
IF x y -> renderArgs "IF" mempty [renderOps x, renderOps y]
LOOP s -> renderArgs "LOOP" mempty [renderOps s]
@@ -273,7 +393,7 @@
EXEC va -> "EXEC" <+> renderAnnot va
APPLY va -> "APPLY" <+> renderAnnot va
DIP s -> renderArgs "DIP" mempty [renderOps s]
- DIPN n s -> renderArgs "DIP" mempty [integral n, renderOps s]
+ DIPN n s -> renderArgs "DIP" mempty [build n, renderOps s]
FAILWITH -> "FAILWITH"
CAST va t -> renderArgs "CAST" (renderAnnot va) [renderTy t]
RENAME va -> "RENAME" <+> renderAnnot va
@@ -341,7 +461,7 @@
OPEN_CHEST va -> "OPEN_CHEST" <+> renderAnnot va
EMIT va fa ty ->
renderArgs "EMIT" (renderAnnots [] [fa] [va]) $ maybeToList $ renderTy <$> ty
- SAPLING_EMPTY_STATE va n -> "SAPLING_EMPTY_STATE" <+> renderAnnot va <+> integral n
+ SAPLING_EMPTY_STATE va n -> "SAPLING_EMPTY_STATE" <+> renderAnnot va <+> build n
SAPLING_VERIFY_UPDATE va -> "SAPLING_VERIFY_UPDATE" <+> renderAnnot va
MIN_BLOCK_TIME anns -> "MIN_BLOCK_TIME" <+> renderAnyAnns anns
BYTES va -> "BYTES" <+> renderAnnot va
@@ -357,28 +477,31 @@
renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc
renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs
- integral :: Integral a => a -> Doc
- integral = integer . toInteger
-
renderArgs :: Text -> Doc -> [Doc] -> Doc
renderArgs name annots args
- | PP.isEmpty annots && length name <= 3
- = group $ PP.textStrict name <+> annots <+> PP.align (PP.vsep args)
+ | isEmpty annots && length name <= 3
+ = group $ build name <+> annots <+> PP.align (PP.vsep args)
| otherwise
- = group $ PP.hang 2 $ PP.vsep $ PP.textStrict name <+> annots : args
+ = group $ PP.hang 2 $ PP.vsep $ build name <+> annots : args
isRenderable = \case
EXT extInstr -> isRenderable extInstr
_ -> True
-instance (RenderDoc op, Buildable op) => Buildable (InstrAbstract op) where
+instance (Foldable f, RenderDoc op, Buildable op)
+ => Buildable (InstrAbstract f op) where
build = \case
EXT ext -> build ext
- mi -> buildRenderDoc mi
+ mi -> group $ renderDoc doesntNeedParens mi
----------------------------------------------------------------------------
-- JSON serialization
----------------------------------------------------------------------------
-deriveJSON morleyAesonOptions ''InstrAbstract
+instance (FromJSON op, FromJSON (f op)) => FromJSON (InstrAbstract f op) where
+ parseJSON = genericParseJSON morleyAesonOptions
+instance (ToJSON op, ToJSON (f op)) => ToJSON (InstrAbstract f op) where
+ toJSON = genericToJSON morleyAesonOptions
+ toEncoding = genericToEncoding morleyAesonOptions
+
deriveJSON morleyAesonOptions ''ExpandedOp
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
@@ -39,15 +39,12 @@
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Data.List.NonEmpty ((<|))
-import Fmt (Buildable(build))
+import Fmt (Buildable(..), Doc, isEmpty, (<+>))
import Language.Haskell.TH.Syntax (Lift)
import Prelude hiding ((<$>))
-import Text.PrettyPrint.Leijen.Text (Doc, integer, (<+>))
-import Text.PrettyPrint.Leijen.Text qualified as PP
+import Prettyprinter qualified as PP
import Morley.Michelson.Printer.Util
- (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, buildRenderDocExtended,
- doesntNeedParens, needsParens, wrapInParens)
import Morley.Michelson.Untyped.Annotation
(AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn,
pattern Annotation, singleAnnSet)
@@ -59,25 +56,20 @@
data Ty
= Ty ~T TypeAnn
deriving stock (Eq, Show, Data, Generic, Lift)
+ deriving anyclass NFData
-- | Extract a raw Michelson type from an annotated one
unwrapT :: Ty -> T
unwrapT (Ty t _) = t
-instance NFData Ty
-
-instance RenderDoc (Prettier Ty) where
- renderDoc pn (Prettier w) = case w of
- (Ty t ta) -> renderType t False pn (singleAnnSet ta)
-
instance RenderDoc Ty where
- renderDoc pn (Ty t ta) = renderType t True pn (singleAnnSet ta)
+ renderDoc pn (Ty t ta) = renderType t pn (singleAnnSet ta)
-instance RenderDoc (MismatchError Ty) where
- renderDoc ctx = renderDocDiff ctx . fmap Prettier
+instance Buildable (MismatchError Ty) where
+ build = buildDocDiff
instance RenderDoc T where
- renderDoc pn t = renderType t True pn emptyAnnSet
+ renderDoc pn t = renderType t pn emptyAnnSet
-- | Since Babylon parameter type can have special root annotation.
data ParameterType = ParameterType Ty RootAnn
@@ -85,14 +77,9 @@
instance NFData ParameterType
-instance RenderDoc (Prettier ParameterType) where
- renderDoc pn (Prettier w) = case w of
- ParameterType (Ty t ta) ra ->
- renderType t False pn (fullAnnSet [ta] [ra] [])
-
instance RenderDoc ParameterType where
renderDoc pn (ParameterType (Ty t ta) ra) =
- renderType t True pn (fullAnnSet [ta] [ra] [])
+ renderType t pn (fullAnnSet [ta] [ra] [])
-- | Render a type representation
--
@@ -108,18 +95,17 @@
-- > PAIR %x %y :t @my_pair
renderType
:: T
- -> Bool
-> RenderContext
-> AnnotationSet
-> Doc
-renderType t forceSingleLine pn annSet =
+renderType t pn annSet =
let annDoc = renderDoc doesntNeedParens annSet
- recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet'
+ recRenderer t' annSet' = renderType t' needsParens annSet'
renderParametric :: Text -> [Doc] -> Doc
renderParametric name args = PP.group $
- if PP.isEmpty annDoc && length name < 3
- then addParens pn $ PP.textStrict name <+> PP.align (PP.vsep args)
- else PP.hang 2 $ addParens pn $ PP.vsep $ PP.textStrict name <+> annDoc : args
+ if isEmpty annDoc && length name < 3
+ then addParens pn $ build name <+> PP.align (PP.vsep args)
+ else PP.hang 2 $ addParens pn $ PP.vsep $ build name <+> annDoc : args
collectBranches :: T -> TypeAnn -> FieldAnn -> NonEmpty Doc
collectBranches (TPair fa1 fa2 va1 _ (Ty t1 ta1) (Ty t2 ta2)) _ (Annotation "")
@@ -148,8 +134,8 @@
TChest -> wrapInParens pn $ "chest" :| [annDoc]
TChestKey -> wrapInParens pn $ "chest_key" :| [annDoc]
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)
+ TSaplingState n -> addParens pn $ "sapling_state" <+> annDoc <+> build n
+ TSaplingTransaction n -> addParens pn $ "sapling_transaction" <+> annDoc <+> build n
TOption (Ty t1 ta1) ->
renderParametric "option" [recRenderer t1 (singleAnnSet ta1)]
@@ -201,15 +187,6 @@
, recRenderer t2 $ singleAnnSet ta2
]
-instance Buildable Ty where
- build = buildRenderDoc
-
-instance Buildable (MismatchError Ty) where
- build = buildRenderDocExtended
-
-instance Buildable ParameterType where
- build = buildRenderDoc
-
-- | Michelson Type
data T =
TKey
@@ -245,11 +222,7 @@
| TSaplingTransaction Natural
| TNever
deriving stock (Eq, Show, Data, Generic, Lift)
-
-instance Buildable T where
- build = buildRenderDoc
-
-instance NFData T
+ deriving anyclass NFData
-- | Construct non-annotated @option@ type from an annotated type
toption :: Ty -> T
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
@@ -9,7 +9,6 @@
-- Internal types to avoid orphan instances
, InternalByteString(..)
, unInternalByteString
- , linearizeRightCombValuePair
, renderValuesList
, renderSome
, renderNone
@@ -22,50 +21,71 @@
import Prelude hiding (group)
import Data.Aeson (FromJSON(..), ToJSON(..), withText)
-import Data.Aeson.TH (deriveJSON)
+import Data.Aeson.Types (genericParseJSON, genericToEncoding, genericToJSON)
import Data.Data (Data(..))
-import Data.List.NonEmpty ((<|))
-import Fmt (Buildable(build))
+import Fmt (Doc, build, hexF, (<+>))
+import Fmt qualified as PP ((<$>))
+import Prettyprinter
+ (align, dquotes, encloseSep, group, hang, lbrace, rbrace, semi, sep, softline, space)
import Text.Hex (decodeHex, encodeHex)
-import Text.PrettyPrint.Leijen.Text
- (Doc, align, dquotes, encloseSep, group, hang, lbrace, rbrace, semi, sep, softline, space, text,
- textStrict, (<+>))
-import Text.PrettyPrint.Leijen.Text qualified as PP
import Morley.Michelson.Printer.Util
- (RenderContext, RenderDoc(..), addParensMultiline, buildRenderDoc, doesntNeedParens, needsParens,
- renderOps)
import Morley.Michelson.Text
+import Morley.Michelson.Untyped.HoistInstr
import Morley.Util.Aeson
-data Value' op =
+data Value' f op =
ValueInt Integer
| ValueString MText
| ValueBytes InternalByteString
| ValueUnit
| ValueTrue
| ValueFalse
- | ValuePair (Value' op) (Value' op)
- | ValueLeft (Value' op)
- | ValueRight (Value' op)
- | ValueSome (Value' op)
+ | ValuePair (Value' f op) (Value' f op)
+ | ValueLeft (Value' f op)
+ | ValueRight (Value' f op)
+ | ValueSome (Value' f op)
| ValueNone
| ValueNil
- | ValueSeq (NonEmpty $ Value' op)
+ | ValueSeq (NonEmpty $ Value' f op)
-- ^ A sequence of elements: can be a list, a set or a pair.
-- We can't distinguish lists and sets during parsing.
- | ValueMap (NonEmpty $ Elt op)
- | ValueLambda (NonEmpty op)
- | ValueLamRec (NonEmpty op)
+ | ValueMap (NonEmpty $ Elt f op)
+ | ValueLambda (f op)
+ -- ^ Invariant: contains non-empty list of instructions. For an empty list,
+ -- use 'ValueNil'.
+ | ValueLamRec (f op)
deriving stock (Eq, Show, Functor, Data, Generic)
-instance NFData op => NFData (Value' op)
+instance HoistInstr Value' where
+ hoistInstr f = \case
+ ValueInt n -> ValueInt n
+ ValueString t -> ValueString t
+ ValueBytes bs -> ValueBytes bs
+ ValueUnit -> ValueUnit
+ ValueTrue -> ValueTrue
+ ValueFalse -> ValueFalse
+ ValueNone -> ValueNone
+ ValueNil -> ValueNil
+ ValuePair l r -> ValuePair (hoistInstr f l) (hoistInstr f r)
+ ValueLeft l -> ValueLeft $ hoistInstr f l
+ ValueRight l -> ValueRight $ hoistInstr f l
+ ValueSome l -> ValueSome $ hoistInstr f l
+ ValueSeq vs -> ValueSeq $ hoistInstr f <$> vs
+ ValueMap els -> ValueMap $ hoistInstr f <$> els
+ ValueLambda ops -> ValueLambda $ f ops
+ ValueLamRec ops -> ValueLamRec $ f ops
-data Elt op = Elt (Value' op) (Value' op)
+instance NFData (f op) => NFData (Value' f op)
+
+data Elt f op = Elt (Value' f op) (Value' f op)
deriving stock (Eq, Show, Functor, Data, Generic)
-instance NFData op => NFData (Elt op)
+instance HoistInstr Elt where
+ hoistInstr f (Elt l r) = Elt (hoistInstr f l) (hoistInstr f r)
+instance NFData (f op) => NFData (Elt f op)
+
-- | ByteString does not have an instance for ToJSON and FromJSON, to
-- avoid orphan type class instances, make a new type wrapper around it.
newtype InternalByteString = InternalByteString ByteString
@@ -76,13 +96,13 @@
unInternalByteString :: InternalByteString -> ByteString
unInternalByteString (InternalByteString bs) = bs
-instance RenderDoc op => RenderDoc (Value' op) where
+instance (Foldable f, RenderDoc op) => RenderDoc (Value' f op) where
renderDoc pn =
\case
ValueNil -> "{ }"
- ValueInt x -> text . show $ x
- ValueString x -> dquotes (textStrict $ writeMText x)
- ValueBytes xs -> "0x" <> (textStrict . encodeHex . unInternalByteString $ xs)
+ ValueInt x -> build x
+ ValueString x -> dquotes (build $ writeMText x)
+ ValueBytes xs -> "0x" <> (hexF . unInternalByteString $ xs)
ValueUnit -> "Unit"
ValueTrue -> "True"
ValueFalse -> "False"
@@ -93,8 +113,8 @@
ValueNone -> renderNone
ValueSeq xs -> renderValuesList (renderDoc doesntNeedParens) xs
ValueMap xs -> renderValuesList renderElt xs
- ValueLambda xs -> renderOps False xs
- ValueLamRec xs -> "Lambda_rec" <+> PP.align (renderOps False xs)
+ ValueLambda xs -> renderOpsList False xs
+ ValueLamRec xs -> "Lambda_rec" <+> align (renderOpsList False xs)
-- | Helper function to render @None@ @Value@
renderNone :: Doc
@@ -119,18 +139,10 @@
renderElt' :: (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc
renderElt' l r = "Elt" <+> l needsParens <+> r needsParens
--- | Converts @Pair a (Pair b c)@ to @[a, b, c]@.
-linearizeRightCombValuePair :: (Value' op) -> NonEmpty (Value' op)
-linearizeRightCombValuePair (ValuePair l r) = l <| linearizeRightCombValuePair r
-linearizeRightCombValuePair v = v :| []
-{-# DEPRECATED linearizeRightCombValuePair
- "This transformation is not necessarily valid. \
- \The correct way to go about this is typecheck then print optimized representation." #-}
-
-renderElt :: RenderDoc op => Elt op -> Doc
+renderElt :: (Foldable f, RenderDoc op) => Elt f op -> Doc
renderElt (Elt k v) = renderElt' (flip renderDoc k) (flip renderDoc v)
-instance RenderDoc op => RenderDoc (Elt op) where
+instance (Foldable f, RenderDoc op) => RenderDoc (Elt f op) where
renderDoc _ = renderElt
-- | A helper function that renders a 'NonEmpty' list of items in Michelson-readable format,
@@ -140,12 +152,6 @@
align $ encloseSep (lbrace <> space) (softline <> rbrace) (semi <> space) $
renderElem <$> es
-instance (RenderDoc op) => Buildable (Value' op) where
- build = buildRenderDoc
-
-instance (RenderDoc op) => Buildable (Elt op) where
- build = buildRenderDoc
-
----------------------------------------------------------------------------
-- JSON serialization
----------------------------------------------------------------------------
@@ -163,7 +169,15 @@
Nothing -> fail "Invalid hex encoding"
Just res -> pure (InternalByteString res)
-$(mconcat
- [ deriveJSON morleyAesonOptions ''Value'
- , deriveJSON morleyAesonOptions ''Elt
- ])
+
+instance FromJSON (f op) => FromJSON (Value' f op) where
+ parseJSON = genericParseJSON morleyAesonOptions
+instance ToJSON (f op) => ToJSON (Value' f op) where
+ toJSON = genericToJSON morleyAesonOptions
+ toEncoding = genericToEncoding morleyAesonOptions
+
+instance FromJSON (f op) => FromJSON (Elt f op) where
+ parseJSON = genericParseJSON morleyAesonOptions
+instance ToJSON (f op) => ToJSON (Elt f op) where
+ toJSON = genericToJSON morleyAesonOptions
+ toEncoding = genericToEncoding morleyAesonOptions
diff --git a/src/Morley/Michelson/Untyped/View.hs b/src/Morley/Michelson/Untyped/View.hs
--- a/src/Morley/Michelson/Untyped/View.hs
+++ b/src/Morley/Michelson/Untyped/View.hs
@@ -12,7 +12,7 @@
, viewNameToMText
, View' (..)
- , ViewsSet (..)
+ , ViewsSet (.., UnsafeViewsSet)
, mkViewsSet
, VS.ViewsSetError (..)
@@ -42,7 +42,7 @@
-- ^ View argument type
, viewReturn :: Ty
-- ^ View return type
- , viewCode :: [op]
+ , viewCode :: op
-- ^ View code
} deriving stock (Eq, Show, Functor, Data, Generic)
@@ -50,9 +50,14 @@
deriveJSON morleyAesonOptions ''View'
-newtype ViewsSet instr = UnsafeViewsSet { unViewsSet :: Map ViewName (View' instr) }
+newtype ViewsSet instr = ViewsSet { unViewsSet :: Map ViewName (View' instr) }
deriving newtype (FromJSON, ToJSON, Default, NFData, Container)
deriving stock (Eq, Show, Data, Functor)
+
+pattern UnsafeViewsSet :: Map ViewName (View' instr) -> ViewsSet instr
+pattern UnsafeViewsSet x = ViewsSet x
+{-# COMPLETE UnsafeViewsSet #-}
+{-# DEPRECATED UnsafeViewsSet "Use ViewsSet instead" #-}
mkViewsSet :: [View' instr] -> Either VS.ViewsSetError (ViewsSet instr)
mkViewsSet = coerce ... VS.mkViewsSet viewName
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
@@ -60,15 +60,14 @@
import Data.Some (Some(..))
import Data.Text (strip)
import Data.Type.Equality (testEquality, (:~:)(..))
-import Fmt (Buildable(build), hexF, pretty)
+import Fmt (Buildable(build), hexF, nameF, pretty, unwordsF, (<+>))
import Instances.TH.Lift ()
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax (Lift)
import Language.Haskell.TH.Syntax qualified as TH
import Options.Applicative (ReadM)
-import Text.PrettyPrint.Leijen.Text (backslash, dquotes, int, (<+>))
+import Prettyprinter (backslash, dquotes)
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)
import Morley.Michelson.Text
import Morley.Tezos.Address.Kinds
import Morley.Tezos.Crypto
@@ -240,18 +239,14 @@
instance NFData ParseAddressError
instance Buildable ParseAddressError where
- build = buildRenderDoc
-
-instance RenderDoc ParseAddressError where
- renderDoc context =
- \case
- ParseAddressCryptoError pkErr -> "Address failed to parse: " <> renderDoc context pkErr
- ParseAddressWrongKind expected (Constrained a) -> mconcat
- [ "Expected address of kind ", renderAddressKinds expected
- , ", but got ", renderAnyBuildable a
- ]
+ build = \case
+ ParseAddressCryptoError pkErr -> nameF "Address failed to parse" $ build pkErr
+ ParseAddressWrongKind expected (Constrained a) -> unwordsF
+ [ "Expected address of kind", renderAddressKinds expected
+ , ", but got", build a
+ ]
where
- renderAddressKinds as = mconcat $ intersperse ", " (renderAnyBuildable <$> as)
+ renderAddressKinds as = mconcat $ intersperse ", " (build <$> as)
-- | Parse an address of a particular kind from its human-readable textual
-- representation used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU").
@@ -322,23 +317,20 @@
instance NFData ParseAddressRawError
-instance RenderDoc ParseAddressRawError where
- renderDoc _ =
+instance Buildable ParseAddressRawError where
+ build =
\case
ParseAddressRawInvalidPrefix prefix ->
- "Invalid prefix for raw address" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"
+ "Invalid prefix for raw address" <+> dquotes (hexF prefix) <+> "provided"
ParseAddressRawUnsupportedPrefix name prefix ->
- "Unsupported raw address prefix type" <+> renderAnyBuildable name
- <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "found"
+ "Unsupported raw address prefix type" <+> build name
+ <+> dquotes (hexF prefix) <+> "found"
ParseAddressRawWrongSize addr -> "Given raw address+" <+>
- (renderAnyBuildable $ hexF addr) <+> "has invalid length" <+> int (length addr)
- ParseAddressRawMalformedSeparator addr -> "Given raw address" <+> (renderAnyBuildable $ hexF addr) <+>
+ hexF addr <+> "has invalid length" <+> build (length addr)
+ ParseAddressRawMalformedSeparator addr -> "Given raw address" <+> dquotes (hexF addr) <+>
"does not end with" <+> dquotes (backslash <> "00")
- ParseAddressRawBinaryError err -> "Binary error during decoding address:" <+> renderAnyBuildable err
- ParseAddressRawCryptoError err -> "Key hash decoding error:" <+> renderAnyBuildable err
-
-instance Buildable ParseAddressRawError where
- build = buildRenderDoc
+ ParseAddressRawBinaryError err -> "Binary error during decoding address:" <+> build err
+ ParseAddressRawCryptoError err -> "Key hash decoding error:" <+> build err
-- | Parse the given address in its raw byte form used by Tezos
-- (e.g "01521139f84791537d54575df0c74a8084cc68861c00")) . Or fail otherwise
diff --git a/src/Morley/Tezos/Address/Alias.hs b/src/Morley/Tezos/Address/Alias.hs
--- a/src/Morley/Tezos/Address/Alias.hs
+++ b/src/Morley/Tezos/Address/Alias.hs
@@ -28,7 +28,7 @@
import Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
import Data.Singletons (SingI(..), demote)
import Data.Text qualified as T
-import Fmt (Buildable(..), Builder, pretty)
+import Fmt (Buildable(..), Doc, pretty)
import Options.Applicative qualified as Opt
import Data.Char qualified as Char
@@ -241,11 +241,11 @@
SAOAKindSpecified $ AddressAlias $ mkAlias @kind alias
-- | The prefix used to specify whether an alias belongs to a contract or an implicit account.
-aliasPrefix :: forall addressKind. (L1AddressKind addressKind, SingI addressKind) => Builder
+aliasPrefix :: forall addressKind. (L1AddressKind addressKind, SingI addressKind) => Doc
aliasPrefix =
usingImplicitOrContractKind @addressKind $
build $ demote @addressKind
-contractPrefix, implicitPrefix :: Builder
+contractPrefix, implicitPrefix :: Doc
contractPrefix = aliasPrefix @'AddressKindContract
implicitPrefix = aliasPrefix @'AddressKindImplicit
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
@@ -133,7 +133,6 @@
import Data.ByteString.Lazy qualified as LBS
import Data.Some (Some(..), mapSome)
import Data.Text qualified as T
-import Data.Text.Internal.Builder (Builder)
import Fmt (Buildable, build, hexF, pretty)
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift)
@@ -621,7 +620,7 @@
parseKeyHashHelper
:: Int
- -> Builder
+ -> LText
-> ExceptT CryptoParseError Get.Get a
-> ByteString
-> Either CryptoParseError a
diff --git a/src/Morley/Tezos/Crypto/BLS.hs b/src/Morley/Tezos/Crypto/BLS.hs
--- a/src/Morley/Tezos/Crypto/BLS.hs
+++ b/src/Morley/Tezos/Crypto/BLS.hs
@@ -39,7 +39,7 @@
import Crypto.Random (MonadRandom(getRandomBytes))
import Data.ByteArray (ByteArray, ByteArrayAccess, Bytes, convert)
import Data.ByteArray.Sized (SizedByteArray(..), sizedByteArray)
-import Fmt (Buildable, Builder, build)
+import Fmt (Buildable, build)
import Morley.Michelson.Text
import Morley.Tezos.Crypto.Util
@@ -105,7 +105,7 @@
toSized
:: forall n a. (KnownNat n, ByteArrayAccess a)
- => Builder -> a -> Either CryptoParseError (SizedByteArray n a)
+ => LText -> a -> Either CryptoParseError (SizedByteArray n a)
toSized what =
maybeToRight (CryptoParseUnexpectedLength what $ fromIntegralOverflowing $ natVal @n Proxy)
. sizedByteArray
diff --git a/src/Morley/Tezos/Crypto/BLS12381.hs b/src/Morley/Tezos/Crypto/BLS12381.hs
--- a/src/Morley/Tezos/Crypto/BLS12381.hs
+++ b/src/Morley/Tezos/Crypto/BLS12381.hs
@@ -37,13 +37,11 @@
import Data.Curve.Weierstrass.BLS12381 qualified as CW.BLS
import Data.Field.Galois qualified as GF
import Data.Pairing.BLS12381 qualified as BLS
-import Fmt (Buildable(..))
+import Fmt (Buildable(..), hexF, (<+>))
import Morley.Util.Instances ()
import Morley.Util.Named
-import Text.Hex (decodeHex, encodeHex)
-import Text.PrettyPrint.Leijen.Text (int, integer, (<+>))
+import Text.Hex (decodeHex)
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)
-- | Methods common for all BLS12-381 primitives.
class CurveObject a where
@@ -184,22 +182,19 @@
deriving anyclass (NFData)
instance Buildable DeserializationError where
- build = buildRenderDoc
-
-instance RenderDoc DeserializationError where
- renderDoc _ = \case
+ build = \case
CompressedFormIsNotSupported ->
"Compressed form of BLS12-381 point is not supported by Tezos"
UnexpectedLength (arg #expected -> expected) (arg #given -> given) ->
"Unexpected length of BLS12-381 primitive: \
- \expected" <+> (int expected) <> ", but given" <+> (int given)
+ \expected" <+> build expected <> ", but given" <+> build given
TooLargeLength (arg #limit -> limit) (arg #given -> given) ->
"Too large length of BLS12-381 primitive: \
- \limit is" <+> (int limit) <+> ", but given" <+> (int given)
+ \limit is" <+> build limit <+> ", but given" <+> build given
ValueOutsideOfField v ->
- "Value is too large for the given field of values:" <+> (integer v)
+ "Value is too large for the given field of values:" <+> build v
PointNotOnCurve bs ->
- "Point is not on curve: 0x" <> (renderAnyBuildable $ encodeHex bs)
+ "Point is not on curve: 0x" <> hexF bs
{- Note on serialization:
diff --git a/src/Morley/Tezos/Crypto/Util.hs b/src/Morley/Tezos/Crypto/Util.hs
--- a/src/Morley/Tezos/Crypto/Util.hs
+++ b/src/Morley/Tezos/Crypto/Util.hs
@@ -42,10 +42,8 @@
import Data.ByteString qualified as BS
import Data.ByteString.Base58 qualified as Base58
import Data.ByteString.Lazy qualified as LBS
-import Fmt (Buildable, Builder, build, hexF)
-import Text.PrettyPrint.Leijen.Text (int, textStrict, (<+>))
+import Fmt (Buildable, build, hexF, (<+>))
-import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended, renderAnyBuildable)
import Morley.Tezos.Crypto.Hash
import Morley.Util.Binary (getRemainingByteStringCopy)
@@ -54,10 +52,10 @@
data CryptoParseError
= CryptoParseWrongBase58Check
| CryptoParseWrongTag ByteString
- | CryptoParseUnsupportedTag Builder ByteString
+ | CryptoParseUnsupportedTag LText ByteString
| CryptoParseCryptoError CryptoError
| CryptoParseBLSTError BlstError
- | CryptoParseUnexpectedLength Builder Int
+ | CryptoParseUnexpectedLength LText Int
| CryptoParseBinaryError Text
deriving stock (Show, Eq)
@@ -65,21 +63,18 @@
rnf = rnf @String . Debug.show
instance Buildable CryptoParseError where
- build = buildRenderDocExtended
-
-instance RenderDoc CryptoParseError where
- renderDoc _ = \case
+ build = \case
CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"
- CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> renderAnyBuildable (hexF tag)
+ CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> hexF tag
CryptoParseUnsupportedTag name tag ->
- "Unsupported hash" <+> renderAnyBuildable name <> ":" <+> renderAnyBuildable (hexF tag)
+ "Unsupported hash" <+> build name <> ":" <+> hexF tag
CryptoParseCryptoError err ->
- "Cryptographic library reported an error:" <+> renderAnyBuildable (displayException err)
+ "Cryptographic library reported an error:" <+> build (displayException err)
CryptoParseBLSTError err ->
- "Cryptographic library reported an error:" <+> renderAnyBuildable (displayException err)
+ "Cryptographic library reported an error:" <+> build (displayException err)
CryptoParseUnexpectedLength what l ->
- "Unexpected length of" <+> renderAnyBuildable what <> ":" <+> int l
- CryptoParseBinaryError err -> textStrict err
+ "Unexpected length of" <+> build what <> ":" <+> build l
+ CryptoParseBinaryError err -> build err
-- | Encode a bytestring in Base58Check format.
encodeBase58Check :: ByteString -> Text
diff --git a/src/Morley/Util/Instances.hs b/src/Morley/Util/Instances.hs
--- a/src/Morley/Util/Instances.hs
+++ b/src/Morley/Util/Instances.hs
@@ -7,13 +7,6 @@
module Morley.Util.Instances () where
import Data.Default (Default(..))
-import Fmt (Buildable(..))
instance Default Natural where
def = 0
-
-instance Buildable Natural where
- build = build @Integer . fromIntegral
-
-instance Buildable a => (Buildable (Identity a)) where
- build (Identity x) = build x
diff --git a/src/Morley/Util/Interpolate.hs b/src/Morley/Util/Interpolate.hs
--- a/src/Morley/Util/Interpolate.hs
+++ b/src/Morley/Util/Interpolate.hs
@@ -3,11 +3,11 @@
{- |
String interpolation quasi-quoters. The most basic version is 'i', it returns anything that
-has a 'Fmt.FromBuilder' instance: 'Text', 'ByteString', 'String', @Builder@.
+has a 'Fmt.FromDoc' instance: 'Text', 'ByteString', 'String', etc.
-In some cases, it is more convenient to return a lazy @Text@ @Builder@, in that case 'ib', which
-returns a non-polymorphic result, can be helpful, for instance, if you want to use one interpolated
-string inside another one. Using @Builder@ is also more efficient in this case.
+In some cases, it is more convenient to return a @Doc@, in that case 'ib', which returns a
+non-polymorphic result, can be helpful, for instance, if you want to use one interpolated string
+inside another one. Using @Doc@ is also more efficient in this case.
>>> let splice = [i|some text|]
>>> [i|larger text with #{splice}|] :: Text
@@ -25,7 +25,7 @@
those that remove whitespace-only lines from beginning and end of the quote.
The mnemonic is @i@nterpolate @t@rimming @u@nindenting returning @b@uilder, i.e. 'itub' is
-the trimming, unindenting version returning @Builder@.
+the trimming, unindenting version returning @Doc@.
Versions not interpreting Haskell escape sequences additionally start with @l@, e.g. 'litu' is
@l@iteral @i@nterpolation @t@trimming @u@nindenting.
@@ -57,8 +57,7 @@
line trailing text
If you wish to avoid that, either include the final newline in the splice explicitly (but be aware
-that indentation of the trailing text won't be auto-adjusted, not even the leading spaces are
-removed!), or include it in the quote:
+that leading spaces of the trailing text are not removed!), or include it in the quote:
>>> let splice = "multi\nline" :: Text
>>> :{
@@ -81,7 +80,7 @@
Some text
Some indented text multi
line
- trailing text
+ trailing text
Empty lines are never indented:
diff --git a/src/Morley/Util/Interpolate/Internal.hs b/src/Morley/Util/Interpolate/Internal.hs
--- a/src/Morley/Util/Interpolate/Internal.hs
+++ b/src/Morley/Util/Interpolate/Internal.hs
@@ -13,11 +13,11 @@
import Data.Char (isSpace)
import Data.List qualified as List
import Data.Set qualified as S
-import Data.Text.Internal.Builder (Builder, fromLazyText, toLazyText)
import Data.Text.Lazy qualified as TL
import Fmt (build, fmt)
import Language.Haskell.TH (Exp, Name, Q, lookupValueName, mkName, reportWarning, varE)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Prettyprinter (align)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read.Lex (lexChar)
@@ -77,24 +77,12 @@
| (expr, '}':ys) <- List.span (/='}') xs
= lookupValueName expr >>= \case
Just valueName ->
- let txt = fmt tacc
- ls = splitTextLazy (=='\n') txt
- indent = length . last $ ls
- in [| build txt <> indentF'' indent (build $(varE valueName)) <> $(go mempty ys) |]
+ let txt = fmt tacc :: Text
+ in [| build txt <> align (build $(varE valueName)) <> $(go mempty ys) |]
Nothing -> fail $ "Variable '" ++ expr ++ "' is not in scope"
go tacc (c:cs) = case List.span (`notElem` ['\\', '#']) cs of
(str, rest) -> go (tacc <> build (c:str)) rest
go tacc [] = let txt = fmt @Text tacc in [| build txt |]
-
--- | A version of @Fmt.indentF'@ that doesn't indent the first line, and keeps the final line break
--- intact.
-indentF'' :: Int -> Builder -> Builder
-indentF'' indent bld = case splitTextLazy (=='\n') $ toLazyText bld of
- (x :| xs) -> fromLazyText . TL.intercalate "\n" $ x : map addIndent xs
- where
- addIndent str | null str = str
- | otherwise = spaces <> str
- spaces = TL.replicate (fromIntegral indent) " "
splitTextLazy :: (Char -> Bool) -> TL.Text -> NonEmpty TL.Text
splitTextLazy p t = case nonEmpty $ TL.split p t of
diff --git a/src/Morley/Util/Markdown.hs b/src/Morley/Util/Markdown.hs
--- a/src/Morley/Util/Markdown.hs
+++ b/src/Morley/Util/Markdown.hs
@@ -28,7 +28,7 @@
import Prelude hiding (try)
import Data.Char (isAscii)
-import Fmt (Builder, build, (+|), (|+))
+import Fmt (Doc, build, (+|), (|+))
import Language.Haskell.TH.Quote (QuasiQuoter)
import Morley.Util.Interpolate (iub)
@@ -37,7 +37,7 @@
--
-- This is opposed to 'Text' type, which in turn is not supposed to contain
-- markup elements.
-type Markdown = Builder
+type Markdown = Doc
-- | Level of header, starting from 1.
newtype HeaderLevel = HeaderLevel Int
@@ -141,7 +141,7 @@
-- Markdown's bold does not always work within spoiler header
htmlBold txt = "" <> txt <> ""
-mdComment :: Builder -> Builder
+mdComment :: Doc -> Doc
mdComment commentText =
""
diff --git a/src/Morley/Util/MismatchError.hs b/src/Morley/Util/MismatchError.hs
--- a/src/Morley/Util/MismatchError.hs
+++ b/src/Morley/Util/MismatchError.hs
@@ -33,16 +33,16 @@
-}
module Morley.Util.MismatchError
( MismatchError(..)
- , renderDocDiff
- , renderDocDiffList
+ , buildDocDiff
+ , buildDocDiffList
) where
import Prelude hiding (First, (<$>))
import Data.Algorithm.Diff (PolyDiff(..), getDiffBy)
import Data.Text.Lazy as LT (lines, strip)
-import Fmt (Buildable(..), nameF)
-import Text.PrettyPrint.Leijen.Text (Doc, align, fill, indent, text, vcat, (<$>), (<+>))
+import Fmt (Buildable(..), Doc, unlessF, (<+>))
+import Prettyprinter (align, fill, hardline, indent, line, vcat)
import Morley.Michelson.Printer.Util
@@ -56,66 +56,61 @@
deriving anyclass (NFData, Container)
instance {-# OVERLAPPABLE #-} Buildable a => Buildable (MismatchError a) where
- build MkMismatchError{..} =
- nameF "Expected" (build meExpected) <> nameF "Actual" (build meActual)
+ build = buildStandard
-instance {-# OVERLAPPABLE #-} RenderDoc a => RenderDoc (MismatchError a) where
- renderDoc = renderDocStandard
+buildStandard :: Buildable a => MismatchError a -> Doc
+buildStandard = buildDoc . fmap build
-renderDocStandard :: RenderDoc a => RenderContext -> MismatchError a -> Doc
-renderDocStandard _ (fmap (align . renderDoc doesntNeedParens) -> MkMismatchError{..})
- = fill 9 "Expected:" <+> meExpected
- <$> fill 9 "Actual:" <+> meActual
+buildStandardList :: Buildable a => MismatchError [a] -> Doc
+buildStandardList = buildDoc . fmap buildList
-renderDocStandardList :: RenderDoc a => RenderContext -> MismatchError [a] -> Doc
-renderDocStandardList _ (fmap (align . renderDocList doesntNeedParens) -> MkMismatchError{..})
- = fill 9 "Expected:" <+> meExpected
- <$> fill 9 "Actual:" <+> meActual
+buildDoc :: MismatchError Doc -> Doc
+buildDoc MkMismatchError{..}
+ = fill 9 "Expected:" <+> align meExpected <> hardline
+ <> fill 9 "Actual:" <+> align meActual
+renderMismatch :: MismatchError Doc -> Doc
+renderMismatch errText
+ = hardline <> "Mismatch:" <> hardline
+ <> indent 2 "--- expected +++ actual" <> hardline
+ <> align (diff errText)
+
-- | Render a mismatch error with a diff.
--
-- This is intended to be used with types for which 'RenderDoc' outputs
--- multiline 'Doc'. Generally those are types wrapped in 'Prettier'.
-renderDocDiff :: RenderDoc a => RenderContext -> MismatchError a -> Doc
-renderDocDiff ctx err = renderDocStandard ctx err
- <$> if expectedAndActualBothSingleLine
- then mempty
- else "Mismatch:"
- <$> indent 2 "--- expected +++ actual"
- <$> align (diff errText)
+-- multiline 'Doc'.
+buildDocDiff :: Buildable a => MismatchError a -> Doc
+buildDocDiff err = buildStandard err
+ <> unlessF expectedAndActualBothSingleLine (renderMismatch errText)
where
- errText = fmap (renderDoc doesntNeedParens) err
- expectedAndActualBothSingleLine = all (null . drop 1 . LT.lines . printDoc False) errText
+ errText = fmap build err
+ expectedAndActualBothSingleLine = all (null . drop 1 . LT.lines . printRenderDoc False) errText
-- | Render a mismatch error of lists with a diff.
--
-- This is intended to be used with types for which 'RenderDoc' outputs
--- multiline 'Doc'. Generally those are types wrapped in 'Prettier'.
-renderDocDiffList :: RenderDoc a => RenderContext -> MismatchError [a] -> Doc
-renderDocDiffList ctx err = renderDocStandardList ctx err
- <$> if simple
- then mempty
- else "Mismatch:"
- <$> indent 2 "--- expected +++ actual"
- <$> align (diff errText)
+-- multiline 'Doc'.
+buildDocDiffList :: Buildable a => MismatchError [a] -> Doc
+buildDocDiffList err = buildStandardList err
+ <> unlessF simple (renderMismatch errText)
where
- errText = fmap (renderList' . map (align . renderDoc doesntNeedParens)) err
+ errText = fmap (renderList' . map (align . build)) err
-- "simple" here means that at least one is true:
--
-- * one of the lists is empty
-- * rendered representation for both expected and actual types are single-line
- simple = any null err || all (null . drop 1 . LT.lines . printDoc False) errText
+ simple = any null err || all (null . drop 1 . LT.lines . printRenderDoc False) errText
renderList' ds
= case ds of
[] -> "[]"
[d] -> align $ "[ " <> d <> " ]"
- _ -> align $ vcat (zipWith (<>) ("[ " : repeat ", ") ds) <$> "]"
+ _ -> align $ vcat (zipWith (<>) ("[ " : repeat ", ") ds) <> line <> "]"
diff :: MismatchError Doc -> Doc
-diff (fmap $ LT.lines . printDoc False -> MkMismatchError{..}) = vcat $
+diff (fmap $ LT.lines . printRenderDoc False -> MkMismatchError{..}) = vcat $
showLine `fmap` getDiffBy ((==) `on` LT.strip) meExpected meActual
where
showLine = \case
- (Both _ b) -> indent 2 $ text b
- (First x) -> "-" <+> text x
- (Second x) -> "+" <+> text x
+ (Both _ b) -> indent 2 $ build b
+ (First x) -> "-" <+> build x
+ (Second x) -> "+" <+> build x
diff --git a/src/Morley/Util/Peano.hs b/src/Morley/Util/Peano.hs
--- a/src/Morley/Util/Peano.hs
+++ b/src/Morley/Util/Peano.hs
@@ -79,7 +79,6 @@
, minIdempotency
, commutativity
, transitivity
- , (|-)
-- * Helpers
, toNatural
@@ -89,7 +88,7 @@
import Data.Constraint (Dict(..), (\\))
import Data.Data (Data(..))
import Data.Singletons (Sing, SingI(..), SomeSing(..))
-import Data.Type.Equality (gcastWith, type (:~:)(..))
+import Data.Type.Equality (type (:~:)(..))
import Data.Vinyl (Rec(..))
import Data.Vinyl.Core (Head, Tail)
import Data.Vinyl.TypeLevel (Nat(..), RLength)
@@ -101,7 +100,7 @@
import Morley.Util.Sing (genSingletonsType)
import Morley.Util.StubbedProof
-import Morley.Util.Type (FailUnless, MockableConstraint(..))
+import Morley.Util.Type (FailUnless)
-- This is very obviously a false positive.
{-# ANN module ("HLint: ignore Use 'natVal' from Universum" :: Text) #-}
@@ -411,12 +410,6 @@
instance (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>
RequireLongerOrSameLength l a
-instance MockableConstraint (RequireLongerOrSameLength l a) where
- unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerOrSameLength '[] 'Z)
-
-instance MockableConstraint (RequireLongerThan l a) where
- unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerThan '[()] 'Z)
-
----------------------------------------------------------------------------
-- Length constraints 'Dict'ionaries
----------------------------------------------------------------------------
@@ -462,12 +455,6 @@
----------------------------------------------------------------------------
-- Inductive proofs
----------------------------------------------------------------------------
-
--- | Convenience synonym for 'gcastWith'
-(|-) :: forall k (a :: k) (b :: k) r. (a :~: b) -> ((a ~ b) => r) -> r
-(|-) = gcastWith
-infixr 1 |-
-{-# DEPRECATED (|-) "Just use (\\\\) from Data.Constraint." #-}
-- | Proof that for naturals, @k + (m + 1) = n@ entails @n > k@
additivity :: forall k m n. AddPeano k ('S m) ~ n
diff --git a/src/Morley/Util/PeanoNatural.hs b/src/Morley/Util/PeanoNatural.hs
--- a/src/Morley/Util/PeanoNatural.hs
+++ b/src/Morley/Util/PeanoNatural.hs
@@ -21,11 +21,11 @@
import Data.Singletons (SingI(..))
import Data.Type.Equality (TestEquality(..), (:~:))
+import Fmt (build)
import GHC.TypeNats (Nat)
-import Morley.Util.Peano
-import Text.PrettyPrint.Leijen.Text (integer)
import Morley.Michelson.Printer.Util
+import Morley.Util.Peano
-- | PeanoNatural data type
--
@@ -40,7 +40,7 @@
deriving stock instance Eq (PeanoNatural n)
instance RenderDoc (PeanoNatural n) where
- renderDoc _ = integer . toInteger . fromPeanoNatural
+ renderDoc _ = build . fromPeanoNatural
instance NFData (PeanoNatural n) where
rnf (PN s _) = rnf s
diff --git a/src/Morley/Util/StubbedProof.hs b/src/Morley/Util/StubbedProof.hs
--- a/src/Morley/Util/StubbedProof.hs
+++ b/src/Morley/Util/StubbedProof.hs
@@ -33,3 +33,4 @@
-- assumed that the first argument constitutes a semi-proper proof.
stubProof :: forall a b. (Stubbed => a :~: b) -> a :~: b
stubProof _ = unsafeCoerce Refl
+{-# INLINE stubProof #-}
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
@@ -18,8 +18,6 @@
, FailUnless
, FailUnlessElse
, FailUnlessElsePoly
- , failUnlessEvi
- , failWhenEvi
, AllUnique
, RequireAllUnique
, ReifyList (..)
@@ -32,16 +30,11 @@
, Some1 (..)
, recordToSomeList
- , ConcatListOfTypesAssociativity
- , listOfTypesConcatAssociativityAxiom
-
- , MockableConstraint (..)
-
, onFirst
, knownListFromSingI
) where
-import Data.Constraint (Dict(..), (:-)(..), (\\))
+import Data.Constraint (Dict(..), (\\))
import Data.Eq.Singletons (DefaultEq)
import Data.Singletons (SingI(sing))
import Data.Type.Bool (If, Not, type (&&))
@@ -52,7 +45,6 @@
import Data.Vinyl.TypeLevel qualified as Vinyl
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
import Prelude.Singletons (SList(..))
-import Unsafe.Coerce (unsafeCoerce)
-- $setup
-- >>> import GHC.TypeLits (TypeError, ErrorMessage (..))
@@ -242,15 +234,6 @@
type FailWhen :: Bool -> ErrorMessage -> Constraint
type FailWhen cond msg = FailWhenElse cond msg ()
--- | A natural conclusion from the fact that an error has not occurred.
-failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True)
-failUnlessEvi = Sub unsafeProvideConstraint
-{-# DEPRECATED failUnlessEvi "FailUnless should carry the corresponding type equality already" #-}
-
-failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False)
-failWhenEvi = Sub unsafeProvideConstraint
-{-# DEPRECATED failWhenEvi "FailWhen should carry the corresponding type equality already" #-}
-
type family AllUnique (l :: [k]) :: Bool where
AllUnique '[] = 'True
AllUnique (x : xs) = Not (IsElem x xs) && AllUnique xs
@@ -336,82 +319,6 @@
recordToSomeList :: Rec f l -> [Some1 f]
recordToSomeList = recordToList . rmap (Vinyl.Const . Some1)
-
-type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))
-{-# DEPRECATED ConcatListOfTypesAssociativity "Unused; use the definition instead" #-}
-
--- | GHC can't deduce this itself because
--- in general a type family might be not associative,
--- what brings extra difficulties and redundant constraints,
--- especially if you have complex types.
--- But (++) type family is associative, so let's define this small hack.
-listOfTypesConcatAssociativityAxiom :: forall a b c . Dict (ConcatListOfTypesAssociativity a b c)
-listOfTypesConcatAssociativityAxiom = unsafeProvideConstraint
-{-# DEPRECATED listOfTypesConcatAssociativityAxiom
- "Unused; a less ad-hoc version is available from \
- \Morley.Michelson.Typed.Instr.Internal.Proofs.assocThm" #-}
-
--- | Constaints that can be provided on demand.
---
--- Needless to say, this is a pretty unsafe operation. This typeclass makes
--- using it safer in a sense that getting a segfault becomes harder, but still
--- it deceives the type system and should be used only if providing a proper
--- proof would be too difficult.
-class MockableConstraint (c :: Constraint) where
- -- | Produce a constraint out of thin air.
- unsafeProvideConstraint :: Dict c
-{-# DEPRECATED unsafeProvideConstraint
- "Apparently unused, and turns out to be very unsafe in practice." #-}
-
-instance MockableConstraint (a ~ b) where
- unsafeProvideConstraint = unsafeCoerce $ Dict @(Int ~ Int)
-
--- | In majority of the cases we don't want to mock typeclass constraints
--- since coercing instances of typeclasses with methods is utterly unsafe.
-instance {-# OVERLAPPABLE #-} c a => MockableConstraint (c a) where
- unsafeProvideConstraint = Dict
-
-instance ( MockableConstraint c1
- , MockableConstraint c2
- ) => MockableConstraint (c1, c2) where
- unsafeProvideConstraint = runIdentity $ do
- Dict <- pure $ unsafeProvideConstraint @c1
- Dict <- pure $ unsafeProvideConstraint @c2
- return Dict
- {-# INLINE unsafeProvideConstraint #-}
-
-instance ( MockableConstraint c1
- , MockableConstraint c2
- , MockableConstraint c3
- ) => MockableConstraint (c1, c2, c3) where
- unsafeProvideConstraint = runIdentity $ do
- Dict <- pure $ unsafeProvideConstraint @(c1, c2)
- Dict <- pure $ unsafeProvideConstraint @c3
- return Dict
- {-# INLINE unsafeProvideConstraint #-}
-
-instance ( MockableConstraint c1
- , MockableConstraint c2
- , MockableConstraint c3
- , MockableConstraint c4
- ) => MockableConstraint (c1, c2, c3, c4) where
- unsafeProvideConstraint = runIdentity $ do
- Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3)
- Dict <- pure $ unsafeProvideConstraint @c4
- return Dict
- {-# INLINE unsafeProvideConstraint #-}
-
-instance ( MockableConstraint c1
- , MockableConstraint c2
- , MockableConstraint c3
- , MockableConstraint c4
- , MockableConstraint c5
- ) => MockableConstraint (c1, c2, c3, c4, c5) where
- unsafeProvideConstraint = runIdentity $ do
- Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3, c4)
- Dict <- pure $ unsafeProvideConstraint @c5
- return Dict
- {-# INLINE unsafeProvideConstraint #-}
-- | Utility function to help transform the first argument of a binfunctor.
onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c