packages feed

morley 0.2.0.1 → 0.3.0

raw patch · 162 files changed

+16202/−6947 lines, 162 filesdep +binarydep +constraintsdep +generic-arbitrarydep −bifunctorsdep −hspec-golden-aesondep −universumdep ~megaparsecdep ~transformers-compatnew-component:exe:contract-discover

Dependencies added: binary, constraints, generic-arbitrary, ghc-prim, hspec-expectations, qm-interpolated-string, syb, tasty, tasty-ant-xml, tasty-hspec, tasty-quickcheck, template-haskell, vector

Dependencies removed: bifunctors, hspec-golden-aeson, universum

Dependency ranges changed: megaparsec, transformers-compat

Files

CHANGES.md view
@@ -1,5 +1,16 @@+0.3.0+=====++* [TM-68](https://issues.serokell.io/issue/TM-68) Lorentz DSL which allows one to write contracts directly in Haskell.+May be moved to a separate package later.+* [TM-132](https://issues.serokell.io/issue/TM-132) Names for contracts in integrational tests.+* [TM-35](https://issues.serokell.io/issue/TM-35) `PACK` and `UNPACK` instructions.+* [TM-27](https://issues.serokell.io/issue/TM-27) Proper handling of `FAILWITH`.+* [TM-44](https://issues.serokell.io/issue/TM-44) [TM-124](https://issues.serokell.io/issue/TM-124) Reorganization of modules.+* Bug fixes.+ 0.2.0.1-======+=======  * Update documentation and metadata.
CONTRIBUTING.md view
@@ -24,9 +24,51 @@ [Universum](https://hackage.haskell.org/package/universum) as a replacement for the default prelude. +### Tests++We use [`tasty`](https://hackage.haskell.org/package/tasty) as our primary top-level testing framework.+Some old code may use `hspec` instead, but all new code must use `tasty`.+We use [`tasty-discover`](https://hackage.haskell.org/package/tasty-discover) to automatically find all tests.+We still require explicit exports to ensure that we don't accidentally miss some test.+If we accidentally name some test in a way which will be ignored by `tasty-discover`, `weeder` will detect a useless export.++Some hints regarding `tasty` and our test-suite:+1. You can use `--hide-successes` to see only failing tests.+It's useful because otherwise if test suite fails you need to find the cause of failure manually.+2. However, beware of [this issue](https://github.com/feuerbach/tasty/issues/152) with `--hide-successes`.+In short, this option is somewhat broken when `tasty` thinks that it outputs to console.+A workaround is to set `TERM=dumb`.+3. You can run tests using our `Makefile`, see below.+ ## Makefile  We have a [Makefile](/Makefile) which provides shortcuts for the most common developers' activities, like building with flags suitable for development, testing, applying `stylish-haskell` and `hlint`, building-Haddock documentation.+Haddock documentation. Mentioned `Makefile` builds morley itself,+each extra package, like [`lorentz-contracts`](/lorentz-contracts/Makefile),+has its own `Makefile`.++If you want to run test suite with additional options, set `TEST_ARGUMENTS` variable.+Example: `TEST_ARGUMENTS="--pattern Parser" make test`.+If you want to enable `--hide-successes` option, you can use `make test-hide-successes`.+It will automatically set `TERM=dumb` which is a workaround for the issue mentioned earlier.++## Branching policy++Our branching policy is described [here](/docs/branching.md).++## Build recomendations++### Emacs intero++As soon as this repository uses different default extensions in different packages,+Intero may report non-existing errors.+This issue [is known](https://github.com/chrisdone/intero/issues/554) and probably+won't be resolved soon.++However, with proper care, this problem can be avoided. Just follow the rules:+* When working with `morley` package, select only `morley:*` packages in `intero-targets`.+* When developing on Lorentz within `lorentz-contracts` package, make sure that+you first built morley core with `make morley`, only after that open the Lorentz modules.+Then set `lorentz-contracts:*` packages as intero targets.
README.md view
@@ -7,13 +7,13 @@  It consists of the following parts: -- `Tezos.*` hierarchy is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts but is used not only by Michelson.-- `Michelson.Untyped` and `Michelson.Typed` hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](/docs/michelsonTypes.md).-- `Michelson.TypeCheck`: A typechecker that validates Michelson contracts according to the Michelson's typing rules. Essentially, it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](/docs/morleyTypechecker.md).-- `Michelson.Interpret`: An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](/docs/morleyInterpreter.md).-- `Morley.Types`: Types for macros, syntactic sugar, and other extensions that are described in the next chapter.-- `Morley.Parser` A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT.-- `Morley.Runtime`: A high-level interface to Morley functionality, see [morleyRuntime.md](/docs/morleyRuntime.md).+- [`Tezos.*`](/src/Tezos/) hierarchy is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts but is used not only by Michelson.+- [`Michelson.Untyped`](/src/Michelson/Untyped.hs) and [`Michelson.Typed`](src/Michelson/Typed.hs) hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](/docs/michelsonTypes.md).+- [`Michelson.TypeCheck`](/src/Michelson/TypeCheck.hs): A typechecker that validates Michelson contracts according to the Michelson's typing rules. Essentially, it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](/docs/morleyTypechecker.md).+- [`Michelson.Interpret`](/src/Michelson/Interpret.hs): An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](/docs/morleyInterpreter.md).+- [`Michelson.Macro`](/src/Michelson/Macro.hs) Types for macros, syntactic sugar, and other extensions that are described in the next chapter.+- [`Michelson.Parser`](/src/Michelson/Parser.hs) A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT.+- [`Michelson.Runtime`](/src/Michelson/Runtime.hs): A high-level interface to Morley functionality, see [morleyRuntime.md](/docs/morleyRuntime.md).  ## II: Morley extensions @@ -30,11 +30,24 @@ You should use it if you want to develop contracts in Morley and submit them to the Tezos network. Workflow is the following: -1. If your contract is called `foo.mtz`, use `morley print --contract foo.mtz > foo.tz`. Note that normally you should not use `morley` directly, you should use `morley.sh` or `stack exec -- morley`. See usage instructions below.-2. After that, you can use existing Tezos tools to deploy your contract. You can also typecheck or interpret it using a reference implementation. If you are not familiar with the Tezos tooling, please read [Tezos documentation](http://tezos.gitlab.io/zeronet/index.html) or [Michelson tutorial](https://gitlab.com/tezos-standards/michelson-tutorial).+1. If your contract is called `foo.mtz`, use `morley print --contract foo.mtz --output foo.tz`. Note that normally you should not use `morley` directly, you should use `morley.sh` or `stack exec -- morley`. See usage instructions below.+2. After that, you can use existing Tezos tools to deploy your contract. You can also typecheck or interpret it using a reference implementation. If you are not familiar with the Tezos tooling, please read [Tezos documentation](http://tezos.gitlab.io/zeronet/index.html) or [Michelson tutorial](https://gitlab.com/morley-framework/michelson-tutorial). -## IV: Testing EDSL+## IV: Lorentz EDSL +<!-- This section is to be proof-read -->++Lorentz is a powerful meta-programming tool which allows one to write contracts directly in Haskell.++Haskell's type checker and automatic type inference facilitate contracts implementation and reduce boilerplate related to types. Adoption of Algebraic Data Types makes work with complex objects safe and convenient.+Later Lorentz contract can be dumped as a plain textual Michelson contract using functions from [`Michelson.Printer`](/src/Michelson/Printer.hs).++You can find Lorentz instructions in [`Lorentz`](/src/Lorentz.hs) modules.+Examples reside in [`Lorentz.Contracts.*`](/lorentz-contracts/src/Lorentz/Contracts/) modules.+For more information, refer this package [README](/lorentz-contracts/README.md).++## V: Testing EDSL+ Another way to test Michelson contracts is to write tests in Haskell using the testing EDSL provided by Morley. It supports both integrational and unit tests. Tests of both types can use static data or arbitrary data.@@ -55,7 +68,7 @@ There are two ways to get Morley executable: - [Docker](https://docs.docker.com/) based (preferable).   * Get [script](/scripts/morley.sh)- (e. g. using `curl https://gitlab.com/tezos-standards/morley/raw/master/scripts/morley.sh > morley.sh`)+ (e. g. using `curl https://gitlab.com/morley-framework/morley/raw/master/scripts/morley.sh > morley.sh`)   and run it `./morley.sh <args>`. This script will pull a docker image that contains the latest version of Morley executable from the master branch and run it with the given arguments.   * Usage example:     + `./morley.sh` to see help message
app/Main.hs view
@@ -2,10 +2,10 @@   ( main   ) where -+import qualified Control.Exception as E import Data.Version (showVersion) import Fmt (pretty)-import Named ((!))+import Named ((:?), argF, (!)) import Options.Applicative   (auto, command, eitherReader, execParser, footerDoc, fullDesc, header, help, helper, info,   infoOption, long, maybeReader, metavar, option, progDesc, readerError, short, showDefault,@@ -13,34 +13,49 @@ import qualified Options.Applicative as Opt import Options.Applicative.Help.Pretty (Doc, linebreak) import Paths_morley (version)+import System.Exit (ExitCode)+import System.IO (utf8) import Text.Pretty.Simple (pPrint)+import qualified Text.Show +import Michelson.Macro (expandContract, expandValue)+import qualified Michelson.Parser as P import Michelson.Printer (printUntypedContract)+import Michelson.Runtime+  (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer,+  typeCheckWithDb)+import Michelson.Runtime.GState (genesisAddress, genesisKeyHash) import Michelson.Untyped hiding (OriginationOperation(..))-import qualified Michelson.Untyped as Un-import Morley.Ext (typeCheckMorleyContract)-import Morley.Macro (expandContract, expandValue)-import qualified Morley.Parser as P-import Morley.Runtime-  (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer)-import Morley.Runtime.GState (genesisAddress, genesisKeyHash)+import qualified Michelson.Untyped as U import Tezos.Address (Address, parseAddress) import Tezos.Core   (Mutez, Timestamp(..), mkMutez, parseTimestamp, timestampFromSeconds, unMutez, unsafeMkMutez) import Tezos.Crypto+import Util.IO (hSetTranslit, withEncoding, writeFileUtf8)+import Util.Named +----------------------------------------------------------------------------+-- Command line options+----------------------------------------------------------------------------+ data CmdLnArgs   = Parse (Maybe FilePath) Bool-  | Print (Maybe FilePath)-  | TypeCheck (Maybe FilePath) Bool+  | Print ("input" :? FilePath) ("output" :? FilePath)+  | TypeCheck !TypeCheckOptions   | Run !RunOptions   | Originate !OriginateOptions   | Transfer !TransferOptions +data TypeCheckOptions = TypeCheckOptions+  { tcoContractFile :: !(Maybe FilePath)+  , tcoDBPath       :: !FilePath+  , tcoVerbose      :: !Bool+  }+ data RunOptions = RunOptions   { roContractFile :: !(Maybe FilePath)   , roDBPath :: !FilePath-  , roStorageValue :: !Un.UntypedValue+  , roStorageValue :: !U.Value   , roTxData :: !TxData   , roVerbose :: !Bool   , roNow :: !(Maybe Timestamp)@@ -56,7 +71,7 @@   , ooDelegate :: !(Maybe KeyHash)   , ooSpendable :: !Bool   , ooDelegatable :: !Bool-  , ooStorageValue :: !Un.UntypedValue+  , ooStorageValue :: !U.Value   , ooBalance :: !Mutez   , ooVerbose :: !Bool   }@@ -92,14 +107,14 @@      typecheckSubCmd =       mkCommandParser "typecheck"-      (uncurry TypeCheck <$> typecheckOptions)-      "Typecheck passed contract"+        (TypeCheck <$> typeCheckOptions) $+        ("Typecheck passed contract")      printSubCmd =       mkCommandParser "print"-      (Print <$> printOptions)+      (Print <$> (#input <.?> contractFileOption) <*> (#output <.?> outputOption))       ("Parse a Morley contract and print corresponding Michelson " <>-       "contract that can be parsed the OCaml reference client")+       "contract that can be parsed by the OCaml reference client")      runSubCmd =       mkCommandParser "run"@@ -133,9 +148,10 @@       long "dry-run" <>       help "Do not write updated DB to DB file" -    typecheckOptions :: Opt.Parser (Maybe FilePath, Bool)-    typecheckOptions = (,)+    typeCheckOptions :: Opt.Parser TypeCheckOptions+    typeCheckOptions = TypeCheckOptions       <$> contractFileOption+      <*> dbPathOption       <*> verboseFlag      parseOptions :: Opt.Parser (Maybe FilePath, Bool)@@ -148,9 +164,6 @@     defaultBalance :: Mutez     defaultBalance = unsafeMkMutez 4000000 -    printOptions :: Opt.Parser (Maybe FilePath)-    printOptions = contractFileOption-     runOptions :: Opt.Parser RunOptions     runOptions =       RunOptions@@ -232,12 +245,12 @@   maybeAddDefault pretty defaultValue <>   help hInfo -valueOption :: String -> String -> Opt.Parser Un.UntypedValue+valueOption :: String -> String -> Opt.Parser U.Value valueOption name hInfo = option (eitherReader parseValue) $   long name <>   help hInfo   where-    parseValue :: String -> Either String Un.UntypedValue+    parseValue :: String -> Either String U.Value     parseValue s =       either (Left . mappend "Failed to parse value: " . show)              (Right . expandValue)@@ -264,6 +277,13 @@       either (Left . mappend "Failed to parse address: " . pretty) Right $       parseAddress $ toText addr +outputOption :: Opt.Parser (Maybe FilePath)+outputOption = optional . strOption $+  short 'o' <>+  long "output" <>+  metavar "FILEPATH" <>+  help "Write output to the given file. If not specified, stdout is used."+ txData :: Opt.Parser TxData txData =   mkTxData@@ -271,7 +291,7 @@     <*> valueOption "parameter" "Parameter of passed contract"     <*> mutezOption (Just minBound) "amount" "Amout sent by a transaction"   where-    mkTxData :: Address -> UntypedValue -> Mutez -> TxData+    mkTxData :: Address -> Value -> Mutez -> TxData     mkTxData addr param amount =       TxData         { tdSenderAddress = addr@@ -285,10 +305,54 @@   where     addDefault v = value v <> showDefaultWith printer +----------------------------------------------------------------------------+-- Better printing of exceptions+----------------------------------------------------------------------------++newtype DisplayExceptionInShow = DisplayExceptionInShow SomeException++instance Show DisplayExceptionInShow where+  show (DisplayExceptionInShow se) = displayException se++instance Exception DisplayExceptionInShow++-- | Customise default uncaught exception handling. The problem with+-- the default handler is that it uses `show` to display uncaught+-- exceptions, but `displayException` may provide more reasonable+-- output. We do not modify uncaught exception handler, but simply+-- wrap uncaught exceptions (only synchronous ones) into+-- 'DisplayExceptionInShow'.+--+-- Some exceptions (currently we are aware only of 'ExitCode') are+-- handled specially by default exception handler, so we don't wrap+-- them.+displayUncaughtException :: IO () -> IO ()+displayUncaughtException = mapIOExceptions wrapUnlessExitCode+  where+    -- We can't use `mapException` here, because it only works with+    -- exceptions inside pure values, not with `IO` exceptions.+    -- Note: it doesn't catch async exceptions.+    mapIOExceptions :: (SomeException -> SomeException) -> IO a -> IO a+    mapIOExceptions f action = action `catchAny` (E.throwIO . f)++    -- We don't wrap `ExitCode` because it seems to be handled specially.+    -- Application exit code depends on the value stored in `ExitCode`.+    wrapUnlessExitCode :: SomeException -> SomeException+    wrapUnlessExitCode e =+      case fromException @ExitCode e of+        Just _ -> e+        Nothing -> toException $ DisplayExceptionInShow e++----------------------------------------------------------------------------+-- Actual main+----------------------------------------------------------------------------+ main :: IO ()-main = do+main = displayUncaughtException $ withEncoding stdin utf8 $ do+  hSetTranslit stdout+  hSetTranslit stderr   cmdLnArgs <- execParser programInfo-  run cmdLnArgs `catchAny` (die . displayException)+  run cmdLnArgs   where     programInfo = info (helper <*> versionOption <*> argParser) $       mconcat@@ -308,13 +372,13 @@         if hasExpandMacros           then pPrint $ expandContract contract           else pPrint contract-      Print mFilename -> do-        contract <- prepareContract mFilename-        putStrLn $ printUntypedContract contract-      TypeCheck mFilename _hasVerboseFlag -> do-        michelsonContract <- prepareContract mFilename-        void $ either throwM pure $-          typeCheckMorleyContract michelsonContract+      Print (argF #input -> mInputFile) (argF #output -> mOutputFile) -> do+        contract <- prepareContract mInputFile+        let write = maybe putStrLn writeFileUtf8 mOutputFile+        write $ printUntypedContract contract+      TypeCheck TypeCheckOptions{..} -> do+        morleyContract <- prepareContract tcoContractFile+        either throwM (const pass) =<< typeCheckWithDb tcoDBPath morleyContract         putTextLn "Contract is well-typed"       Run RunOptions {..} -> do         michelsonContract <- prepareContract roContractFile@@ -323,14 +387,14 @@           ! #dryRun (not roWrite)       Originate OriginateOptions {..} -> do         michelsonContract <- prepareContract ooContractFile-        let origination = Un.OriginationOperation-              { Un.ooManager = ooManager-              , Un.ooDelegate = ooDelegate-              , Un.ooSpendable = ooSpendable-              , Un.ooDelegatable = ooDelegatable-              , Un.ooStorage = ooStorageValue-              , Un.ooBalance = ooBalance-              , Un.ooContract = michelsonContract+        let origination = U.OriginationOperation+              { U.ooManager = ooManager+              , U.ooDelegate = ooDelegate+              , U.ooSpendable = ooSpendable+              , U.ooDelegatable = ooDelegatable+              , U.ooStorage = ooStorageValue+              , U.ooBalance = ooBalance+              , U.ooContract = michelsonContract               }         addr <- originateContract ooDBPath origination ! #verbose ooVerbose         putTextLn $ "Originated contract " <> pretty addr@@ -346,11 +410,11 @@    , "  morley run --help", linebreak    , linebreak    , "Documentation for morley tools can be found at the following links:", linebreak-   , "  https://gitlab.com/tezos-standards/morley/blob/master/README.md", linebreak-   , "  https://gitlab.com/tezos-standards/morley/tree/master/docs", linebreak+   , "  https://gitlab.com/morley-framework/morley/blob/master/README.md", linebreak+   , "  https://gitlab.com/morley-framework/morley/tree/master/docs", linebreak    , linebreak    , "Sample contracts for running can be found at the following link:", linebreak-   , "  https://gitlab.com/tezos-standards/morley/tree/master/contracts", linebreak+   , "  https://gitlab.com/morley-framework/morley/tree/master/contracts", linebreak    , linebreak    , "USAGE EXAMPLE:", linebreak    , "  morley parse --contract add1.tz", linebreak
+ contract-discover/Main.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveAnyClass #-}++-- | An executable for haskell preprocessor which finds+-- all contract declarations in Haskell modules within the directory where+-- preprocessor is called and exports found contracts in a map.+module Main+  ( main+  ) where++import qualified Unsafe++import Data.Default (Default(..))+import Fmt (Builder, build, fmt, indentF, listF', unlinesF, (+|), (+||), (|+), (||+))+import qualified System.Directory as Dir+import System.Environment (getArgs)+import System.FilePath.Posix (isAbsolute, takeDirectory, (</>))+import Text.Megaparsec (errorBundlePretty, runParser)++import Lorentz.Discover+import Util.IO (hSetTranslit, readFileUtf8, writeFileUtf8)++main :: IO ()+main = do+  hSetTranslit stderr+  args <- getArgs+  case args of+    src : _ : dst : opts -> do+      Config{..} <- parseOpts def (map toText opts)++      let scanRoot+            | isAbsolute cScanRoot = cScanRoot+            | otherwise = takeDirectory src </> cScanRoot+      validRoot <- Dir.doesDirectoryExist scanRoot+      unless validRoot $+        die $ "Specified scan root is not an existing directory: " <> scanRoot+      contracts <- findContracts cDebug scanRoot++      verifyContractDecls contracts+      let output = fmt @Text $ unlinesF+            [ pragmasSection+            , "module " +| cModuleName |+ " (contracts) where"+            , ""+            , importsSection contracts+            , ""+            , contractsMapSection contracts+            ]+      printDebug cDebug . fmt $+        "Generated module:\n" +| indentF 2 (build output) |+ ""++      writeFileUtf8 dst output+    _ -> do+      die "Usage: lorentz-discover src _ dst moduleName"++newtype IsDebug = IsDebug Bool++data Config = Config+  { cModuleName :: Text+  , cDebug :: IsDebug+  , cScanRoot :: FilePath+  }++instance Default Config where+  def = Config+    { cModuleName = "Main"+    , cDebug = IsDebug False+    , cScanRoot = "."+    }++parseOpts :: Config -> [Text] -> IO Config+parseOpts cfg = \case+  [] -> pure cfg+  "--debug" : opts ->+    parseOpts cfg{ cDebug = IsDebug True } opts+  "--generated-module" : opts ->+    case opts of+      [] -> die "Usage: `--generated-module <module name>`"+      modName : os -> parseOpts cfg{ cModuleName = modName } os+  "--root" : opts ->+    case opts of+      [] -> die "Usage: `--root <directory>`"+      root : os -> parseOpts cfg{ cScanRoot = toString root } os+  opt : _ ->+    die $ "Unknown option: " <> show opt++printDebug :: IsDebug -> Text -> IO ()+printDebug (IsDebug isDebug)+  | isDebug = hPutStrLn stderr . ("contract-discover: " <>)+  | otherwise = \_ -> pass++findContracts :: IsDebug -> FilePath -> IO [ExportedContractInfo]+findContracts isDebug path = do+  isDir <- Dir.doesDirectoryExist path+  if isDir+    then do+      dirs <- Dir.listDirectory path+      concatMapM (findContracts isDebug) (map (path </>) dirs)+    else do+      if isHaskellModule path+        then parseHaskellModule isDebug path+        else pure []++parseHaskellModule :: IsDebug -> FilePath -> IO [ExportedContractInfo]+parseHaskellModule isDebug path = do+  file <- readFileUtf8 path+  case runParser haskellExportsParser path file of+    -- Some autogenerated modules may have no export list, we ignore them+    Left err -> do+      printDebug isDebug . toText $ errorBundlePretty err+      return []+    Right res -> do+      printDebug isDebug $ "In module " +|| path ||+ " found contracts "+                         +| listF' (build . ecdName . eciContractDecl) res |+ ""+      return res++-- | Ensures that:+--+-- 1. No two contracts have the same name.+verifyContractDecls :: [ExportedContractInfo] -> IO ()+verifyContractDecls contracts = do+  let vars = map (ecdVar . eciContractDecl) contracts+  let dups = map head . mapMaybe (nonEmpty . Unsafe.init) . group $ sort vars+  case dups of+    [] -> pass+    dup : _ -> die $ "Found multiple contracts with the same name: " <> show dup++pragmasSection :: Builder+pragmasSection =+  mconcat . map (<> "\n") $+  [ "{-# LANGUAGE ImplicitPrelude #-}"+  ]++importsSection :: [ExportedContractInfo] -> Builder+importsSection =+  mconcat . map (<> "\n") .+  (extraImports ++) . map mkImport . ordNub . map eciModuleName+  where+  mkImport m = "import qualified " +| m |+ ""+  extraImports =+    [ "import Data.Text (Text)"+    , "import qualified Data.Map as Map"++    , "import qualified Michelson.Untyped as U"+    , "import Lorentz.Discover"+    ]++contractsMapSection :: [ExportedContractInfo] -> Builder+contractsMapSection contracts =+  "contracts :: Map.Map Text U.Contract\n\+  \contracts = Map.fromList\n  " <> listF' contractPairF contracts+  where+    -- Forms @(contract name, contract variable)@ pair.+    contractPairF ExportedContractInfo{..} =+      let ExportedContractDecl{..} = eciContractDecl+          var = "toUntypedContract " +| eciModuleName |+ "." +| ecdVar |+ ""+      in "\n  (\"" +| ecdName |+ "\", " +| var +| ")"
morley.cabal view
@@ -1,312 +1,297 @@-cabal-version:       2.4-name:                morley-version:             0.2.0.1-synopsis:            Developer tools for the Michelson Language-description:-  A library to make writing smart contracts in Michelson — the smart contract-  language of the Tezos blockchain — pleasant and effective.-homepage:            https://gitlab.com/tezos-standards/morley-license:             AGPL-3.0-or-later-license-file:        LICENSE-author:              camlCase, Serokell, Tocqueville Group-maintainer:          john.c.burnham@gmail.com-copyright:           2018 camlCase, 2019 Tocqueville Group-category:            Language-build-type:          Simple-bug-reports:         https://issues.serokell.io/issues/TM-extra-doc-files:     CHANGES.md-                   , CONTRIBUTING.md-                   , README.md+cabal-version: 2.2 +-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 0607101018e9f75ece0835983f196e390581fc8a40fd97654d7f8e0c13d46371++name:           morley+version:        0.3.0+synopsis:       Developer tools for the Michelson Language+description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective.+category:       Language+homepage:       https://gitlab.com/morley-framework/morley+bug-reports:    https://issues.serokell.io/issues/TM+author:         camlCase, Serokell, Tocqueville Group+maintainer:     john.c.burnham@gmail.com+copyright:      2018 camlCase, 2019 Tocqueville Group+license:        AGPL-3.0-or-later+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGES.md+    CONTRIBUTING.md+    README.md+ source-repository head-  type:     git-  location: git@gitlab.com:tezos-standards/morley.git+  type: git+  location: git@gitlab.com:morley-framework/morley.git  library-  hs-source-dirs:      src-  default-language:    Haskell2010-  exposed-modules:     Michelson.Interpret-                     , Michelson.Printer-                     , Michelson.Printer.Util-                     , Michelson.TypeCheck-                     , Michelson.Typed-                     , Michelson.Typed.Value-                     , Michelson.Untyped-                     , Morley.Default-                     , Morley.Lexer-                     , Morley.Macro-                     , Morley.Ext-                     , Morley.Parser-                     , Morley.Parser.Annotations-                     , Morley.Parser.Helpers-                     , Morley.Runtime-                     , Morley.Runtime.GState-                     , Morley.Runtime.TxData-                     , Morley.Test-                     , Morley.Test.Dummy-                     , Morley.Test.Gen-                     , Morley.Test.Import-                     , Morley.Test.Integrational-                     , Morley.Test.Unit-                     , Morley.Test.Util-                     , Morley.Types-                     , Tezos.Address-                     , Tezos.Core-                     , Tezos.Crypto+  exposed-modules:+      Lorentz+      Lorentz.ADT+      Lorentz.Arith+      Lorentz.Base+      Lorentz.Coercions+      Lorentz.Constraints+      Lorentz.Discover+      Lorentz.Errors+      Lorentz.Ext+      Lorentz.Instr+      Lorentz.Macro+      Lorentz.Polymorphic+      Lorentz.Prelude+      Lorentz.Rebinded+      Lorentz.Referenced+      Lorentz.Store+      Lorentz.Test+      Lorentz.Test.Integrational+      Lorentz.Value+      Michelson.EqParam+      Michelson.ErrorPos+      Michelson.Interpret+      Michelson.Interpret.Pack+      Michelson.Interpret.Unpack+      Michelson.Let+      Michelson.Macro+      Michelson.Parser+      Michelson.Parser.Annotations+      Michelson.Parser.Error+      Michelson.Parser.Ext+      Michelson.Parser.Helpers+      Michelson.Parser.Instr+      Michelson.Parser.Let+      Michelson.Parser.Lexer+      Michelson.Parser.Macro+      Michelson.Parser.Type+      Michelson.Parser.Types+      Michelson.Parser.Value+      Michelson.Printer+      Michelson.Printer.Util+      Michelson.Runtime+      Michelson.Runtime.GState+      Michelson.Runtime.TxData+      Michelson.Test+      Michelson.Test.Dummy+      Michelson.Test.Gen+      Michelson.Test.Import+      Michelson.Test.Integrational+      Michelson.Test.Unit+      Michelson.Test.Util+      Michelson.Text+      Michelson.TypeCheck+      Michelson.TypeCheck.Error+      Michelson.TypeCheck.Ext+      Michelson.TypeCheck.Helpers+      Michelson.TypeCheck.Instr+      Michelson.TypeCheck.TypeCheck+      Michelson.TypeCheck.Types+      Michelson.TypeCheck.Value+      Michelson.Typed+      Michelson.Typed.Aliases+      Michelson.Typed.Annotation+      Michelson.Typed.Arith+      Michelson.Typed.Convert+      Michelson.Typed.CValue+      Michelson.Typed.Extract+      Michelson.Typed.Haskell+      Michelson.Typed.Haskell.Instr+      Michelson.Typed.Haskell.Instr.Helpers+      Michelson.Typed.Haskell.Instr.Product+      Michelson.Typed.Haskell.Instr.Sum+      Michelson.Typed.Haskell.Value+      Michelson.Typed.Instr+      Michelson.Typed.Polymorphic+      Michelson.Typed.Print+      Michelson.Typed.Scope+      Michelson.Typed.Sing+      Michelson.Typed.T+      Michelson.Typed.Value+      Michelson.Untyped+      Michelson.Untyped.Aliases+      Michelson.Untyped.Annotation+      Michelson.Untyped.Contract+      Michelson.Untyped.Ext+      Michelson.Untyped.Instr+      Michelson.Untyped.Type+      Michelson.Untyped.Value+      Tezos.Address+      Tezos.Core+      Tezos.Crypto+      Util.Alternative+      Util.Default+      Util.Generic+      Util.Instances+      Util.IO+      Util.Lens+      Util.Named+      Util.Peano+      Util.Test.Arbitrary+      Util.Test.Ingredients+      Util.Type+      Util.TypeTuple+      Util.TypeTuple.Class+      Util.TypeTuple.Instances+      Util.TypeTuple.TH   other-modules:-                       Michelson.EqParam-                     , Michelson.TypeCheck.Helpers-                     , Michelson.TypeCheck.Instr-                     , Michelson.TypeCheck.Types-                     , Michelson.TypeCheck.Value-                     , Michelson.Typed.Annotation-                     , Michelson.Typed.Arith-                     , Michelson.Typed.Convert-                     , Michelson.Typed.CValue-                     , Michelson.Typed.Extract-                     , Michelson.Typed.Instr-                     , Michelson.Typed.Polymorphic-                     , Michelson.Typed.Sing-                     , Michelson.Typed.T-                     , Michelson.Untyped.Aliases-                     , Michelson.Untyped.Annotation-                     , Michelson.Untyped.Contract-                     , Michelson.Untyped.Instr-                     , Michelson.Untyped.Type-                     , Michelson.Untyped.Value+      Paths_morley+  hs-source-dirs:+      src+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude+  build-depends:+      QuickCheck+    , aeson+    , aeson-options+    , aeson-pretty+    , base-noprelude >=4.7 && <5+    , base16-bytestring+    , base58-bytestring+    , binary+    , bytestring+    , constraints+    , containers+    , cryptonite+    , data-default+    , filepath+    , fmt+    , formatting+    , ghc-prim+    , hex-text+    , hspec+    , lens+    , megaparsec >=7.0.0+    , memory+    , morley-prelude+    , mtl+    , named+    , parser-combinators >=1.0.0+    , quickcheck-arbitrary-adt+    , quickcheck-instances+    , singletons+    , syb+    , tasty+    , tasty-ant-xml+    , template-haskell+    , text+    , time+    , timerep+    , transformers-compat ==0.6.5+    , vector+    , vinyl+    , wl-pprint-text+  default-language: Haskell2010 -  build-depends:       aeson-                     , aeson-options-                     , aeson-pretty-                     , base-noprelude >= 4.7 && < 5-                     , base16-bytestring-                     , base58-bytestring-                     , bifunctors-                     , bytestring-                     , containers-                     , cryptonite-                     , data-default-                     , fmt-                     , formatting-                     , hex-text-                     , hspec-                     , lens-                     , megaparsec >= 7.0.0-                     , memory-                     , morley-prelude-                     , named-                     , QuickCheck-                     , text-                     , time-                     , timerep-                     -- Otherwise Hackage fails-                     , transformers-compat == 0.6.2-                     , parser-combinators >= 1.0.0-                     , directory-                     , singletons-                     , mtl-                     , vinyl-                     , wl-pprint-text-  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-  default-extensions:-                       ApplicativeDo-                       AllowAmbiguousTypes-                       BangPatterns-                       ConstraintKinds-                       DataKinds-                       DeriveFoldable-                       DeriveFunctor-                       DeriveGeneric-                       DeriveTraversable-                       EmptyCase-                       FlexibleContexts-                       FlexibleInstances-                       GADTs-                       GeneralizedNewtypeDeriving-                       LambdaCase-                       MonadFailDesugaring-                       MultiParamTypeClasses-                       MultiWayIf-                       NegativeLiterals-                       OverloadedLabels-                       OverloadedStrings-                       PatternSynonyms-                       PolyKinds-                       RankNTypes-                       RecordWildCards-                       RecursiveDo-                       ScopedTypeVariables-                       StandaloneDeriving-                       TemplateHaskell-                       TupleSections-                       TypeApplications-                       TypeFamilies-                       TypeOperators-                       UndecidableInstances-                       ViewPatterns+executable contract-discover+  main-is: Main.hs+  other-modules:+      Paths_morley+  hs-source-dirs:+      contract-discover+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude+  build-depends:+      base-noprelude >=4.7 && <5+    , data-default+    , directory+    , filepath+    , fmt+    , megaparsec+    , morley+    , morley-prelude+    , text+  default-language: Haskell2010  executable morley-  hs-source-dirs:      app-  main-is:             Main.hs-  autogen-modules:     Paths_morley-  other-modules:       Paths_morley-  default-language:    Haskell2010-  build-depends:       base-noprelude >= 4.7 && < 5-                     , fmt-                     , megaparsec >= 7.0.0-                     , morley-                     , morley-prelude-                     , named-                     , optparse-applicative-                     , pretty-simple-                     , text-  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-  default-extensions:-                       ApplicativeDo-                       AllowAmbiguousTypes-                       BangPatterns-                       ConstraintKinds-                       DataKinds-                       DeriveFoldable-                       DeriveFunctor-                       DeriveGeneric-                       DeriveTraversable-                       EmptyCase-                       FlexibleContexts-                       FlexibleInstances-                       GADTs-                       GeneralizedNewtypeDeriving-                       LambdaCase-                       MonadFailDesugaring-                       MultiParamTypeClasses-                       MultiWayIf-                       NegativeLiterals-                       OverloadedLabels-                       OverloadedStrings-                       PatternSynonyms-                       PolyKinds-                       RankNTypes-                       RecordWildCards-                       RecursiveDo-                       ScopedTypeVariables-                       StandaloneDeriving-                       TemplateHaskell-                       TupleSections-                       TypeApplications-                       TypeFamilies-                       TypeOperators-                       UndecidableInstances-                       ViewPatterns+  main-is: Main.hs+  other-modules:+      Paths_morley+  autogen-modules:+      Paths_morley+  hs-source-dirs:+      app+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude+  build-depends:+      base-noprelude >=4.7 && <5+    , fmt+    , morley+    , morley-prelude+    , named+    , optparse-applicative+    , pretty-simple+  default-language: Haskell2010  test-suite morley-test-  hs-source-dirs:      test-  main-is:             Spec.hs-  default-language:    Haskell2010-  type:                exitcode-stdio-1.0-  other-modules:       Test.Arbitrary-                     , Test.CValConversion-                     , Test.Interpreter-                     , Test.Interpreter.Auction-                     , Test.Interpreter.CallSelf-                     , Test.Interpreter.Compare-                     , Test.Interpreter.Conditionals-                     , Test.Interpreter.EnvironmentSpec-                     , Test.Interpreter.StringCaller-                     , Test.Macro-                     , Test.Ext-                     , Test.Morley.Runtime-                     , Test.Parser-                     , Test.Printer.Michelson-                     , Test.Serialization.Aeson-                     , Test.Tezos.Address-                     , Test.Tezos.Crypto-                     , Test.Typecheck-                     , Test.Util.Contracts-                     , Test.Util.QuickCheck-                     , Test.ValConversion+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Test.CValConversion+      Test.Ext+      Test.Interpreter+      Test.Interpreter.A1.Feather+      Test.Interpreter.CallSelf+      Test.Interpreter.Compare+      Test.Interpreter.Conditionals+      Test.Interpreter.ContractOp+      Test.Interpreter.EnvironmentSpec+      Test.Interpreter.StringCaller+      Test.Lorentz.Discovery+      Test.Lorentz.Macro+      Test.Macro+      Test.Michelson.Runtime+      Test.Michelson.Text+      Test.Parser+      Test.Printer.Michelson+      Test.Serialization.Aeson+      Test.Serialization.Michelson+      Test.Tasty.HUnit+      Test.Tezos.Address+      Test.Tezos.Crypto+      Test.Typecheck+      Test.Untyped.Instr+      Test.Util.Contracts+      Test.Util.Parser+      Test.Util.QuickCheck+      Test.ValConversion+      Tree+      Paths_morley+  hs-source-dirs:+      test+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns DerivingStrategies+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -with-rtsopts=-N+  build-tool-depends:+      tasty-discover:tasty-discover   build-depends:-                       aeson-                     , base-noprelude >= 4.7 && < 5-                     , containers-                     , directory-                     , filepath-                     , fmt-                     , formatting-                     , hspec-                     , hspec-golden-aeson-                     , HUnit-                     , lens-                     , megaparsec >= 7.0.0-                     , morley-                     , morley-prelude-                     , QuickCheck-                     , quickcheck-arbitrary-adt-                     , quickcheck-instances-                     , text-                     , time-                     , universum-                     , vinyl-  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-  default-extensions:-                       ApplicativeDo-                       AllowAmbiguousTypes-                       BangPatterns-                       ConstraintKinds-                       DataKinds-                       DeriveFoldable-                       DeriveFunctor-                       DeriveGeneric-                       DeriveTraversable-                       EmptyCase-                       FlexibleContexts-                       FlexibleInstances-                       GADTs-                       GeneralizedNewtypeDeriving-                       LambdaCase-                       MonadFailDesugaring-                       MultiParamTypeClasses-                       MultiWayIf-                       NegativeLiterals-                       OverloadedLabels-                       OverloadedStrings-                       PatternSynonyms-                       PolyKinds-                       RankNTypes-                       RecordWildCards-                       RecursiveDo-                       ScopedTypeVariables-                       StandaloneDeriving-                       TemplateHaskell-                       TupleSections-                       TypeApplications-                       TypeFamilies-                       TypeOperators-                       UndecidableInstances-                       ViewPatterns+      HUnit+    , QuickCheck+    , aeson+    , base-noprelude >=4.7 && <5+    , bytestring+    , containers+    , data-default+    , directory+    , filepath+    , fmt+    , formatting+    , generic-arbitrary+    , hex-text+    , hspec+    , hspec-expectations+    , lens+    , megaparsec >=7.0.0+    , morley+    , morley-prelude+    , mtl+    , qm-interpolated-string+    , quickcheck-arbitrary-adt+    , quickcheck-instances+    , singletons+    , syb+    , tasty+    , tasty-hspec+    , tasty-quickcheck+    , text+  default-language: Haskell2010
+ src/Lorentz.hs view
@@ -0,0 +1,19 @@+module Lorentz+  ( module Exports+  ) where++import Lorentz.ADT as Exports+import Lorentz.Arith as Exports+import Lorentz.Base as Exports+import Lorentz.Coercions as Exports+import Lorentz.Constraints as Exports+import Lorentz.Errors as Exports+import Lorentz.Ext as Exports+import Lorentz.Instr as Exports+import Lorentz.Macro as Exports+import Lorentz.Polymorphic as Exports+import Lorentz.Prelude as Exports+import Lorentz.Rebinded as Exports+import Lorentz.Referenced as Exports+import Lorentz.Store as Exports+import Lorentz.Value as Exports
+ src/Lorentz/ADT.hs view
@@ -0,0 +1,207 @@+module Lorentz.ADT+  ( HasField+  , HasFieldOfType+  , HasFieldsOfType+  , NamedField (..)+  , (:=)+  , toField+  , toFieldNamed+  , getField+  , getFieldNamed+  , setField+  , modifyField+  , construct+  , constructT+  , fieldCtor+  , wrap_+  , case_+  , caseT+  , (/->)++    -- * Useful re-exports+  , Rec (..)+  , (:!)+  , (:?)+  , arg+  ) where++import Data.Constraint (Dict(..))+import qualified Data.Kind as Kind+import Data.Vinyl.Core (RMap(..), Rec(..))+import Data.Vinyl.Derived (Label)+import GHC.TypeLits (AppendSymbol, Symbol)+import Named ((:!), (:?), arg)++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr+import Michelson.Typed.Haskell.Instr+import Michelson.Typed.Haskell.Value+import Util.TypeTuple++-- | Allows field access and modification.+type HasField dt fname =+  ( InstrGetFieldC dt fname+  , InstrSetFieldC dt fname+  )++-- | Like 'HasField', but allows constrainting field type.+type HasFieldOfType dt fname fieldTy =+  ( HasField dt fname+  , GetFieldType dt fname ~ fieldTy+  )++-- | A pair of field name and type.+data NamedField = NamedField Symbol Kind.Type+type n := ty = 'NamedField n ty++-- | Shortcut for multiple 'HasFieldOfType' constraints.+type family HasFieldsOfType (dt :: Kind.Type) (fs :: [NamedField])+             :: Constraint where+  HasFieldsOfType _ '[] = ()+  HasFieldsOfType dt ((n := ty) ': fs) =+    (HasFieldOfType dt n ty, HasFieldsOfType dt fs)++-- | Extract a field of a datatype replacing the value of this+-- datatype with the extracted field.+--+-- For this and the following functions you have to specify field name+-- which is either record name or name attached with @(:!)@ operator.+toField+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> GetFieldType dt name & st+toField = I . instrGetField @dt++-- | Like 'toField', but leaves field named.+toFieldNamed+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> (name :! GetFieldType dt name) & st+toFieldNamed l = toField l # coerce_++-- | Extract a field of a datatype, leaving the original datatype on stack.+getField+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> GetFieldType dt name & dt ': st+getField l = dup # toField @dt l++-- | Like 'getField', but leaves field named.+getFieldNamed+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> (name :! GetFieldType dt name) & dt ': st+getFieldNamed l = getField l # coerce_++-- | Set a field of a datatype.+setField+  :: forall dt name st.+     InstrSetFieldC dt name+  => Label name -> (GetFieldType dt name ': dt ': st) :-> (dt ': st)+setField = I . instrSetField @dt++-- | Apply given modifier to a datatype field.+modifyField+  :: forall dt name st.+     ( InstrGetFieldC dt name+     , InstrSetFieldC dt name+     )+  => Label name+  -> (forall st0. (GetFieldType dt name ': st0) :-> (GetFieldType dt name ': st0))+  -> dt & st :-> dt & st+modifyField l i = getField @dt l # i # setField @dt l++-- | Make up a datatype. You provide a pack of individual fields constructors.+--+-- Each element of the accepted record should be an instruction wrapped with+-- 'fieldCtor' function. This instruction will have access to the stack at+-- the moment of calling @construct@.+-- Instructions have to output fields of the built datatype, one per instruction;+-- instructions order is expected to correspond to the order of fields in the+-- datatype.+construct+  :: forall dt st.+     ( InstrConstructC dt+     , RMap (ConstructorFieldTypes dt)+     )+  => Rec (FieldConstructor st) (ConstructorFieldTypes dt)+  -> st :-> dt & st+construct fctors =+  I $ instrConstruct @dt $+  rmap (\(FieldConstructor i) -> FieldConstructor i) fctors++-- | Version of 'construct' which accepts tuple of field constructors.+constructT+  :: forall dt fctors st.+     ( InstrConstructC dt+     , RMap (ConstructorFieldTypes dt)+     , fctors ~ Rec (FieldConstructor st) (ConstructorFieldTypes dt)+     , RecFromTuple fctors+     )+  => IsoRecTuple fctors+  -> st :-> dt & st+constructT = construct . recFromTuple++-- | Lift an instruction to field constructor.+fieldCtor :: (st :-> f & st) -> FieldConstructor st f+fieldCtor (I i) = FieldConstructor i++-- | Wrap entry in constructor. Useful for sum types.+wrap_+  :: forall dt name st.+     InstrWrapC dt name+  => Label name -> (AppendCtorField (GetCtorField dt name) st) :-> dt & st+wrap_ =+  case appendCtorFieldAxiom @(GetCtorField dt name) @st of+    Dict -> I . instrWrap @dt++-- | Lorentz analogy of 'CaseClause', it works on plain 'Kind.Type' types.+data CaseClauseL (inp :: [Kind.Type]) (out :: [Kind.Type]) (param :: CaseClauseParam) where+  CaseClauseL :: AppendCtorField x inp :-> out -> CaseClauseL inp out ('CaseClauseParam ctor x)++-- | Lift an instruction to case clause.+--+-- You should write out constructor name corresponding to the clause+-- explicitly. Prefix constructor name with "c" letter, otherwise+-- your label will not be recognized by Haskell parser.+-- Passing constructor name can be circumvented but doing so is not recomended+-- as mentioning contructor name improves readability and allows avoiding+-- some mistakes.+(/->)+  :: Label ("c" `AppendSymbol` ctor)+  -> AppendCtorField x inp :-> out+  -> CaseClauseL inp out ('CaseClauseParam ctor x)+(/->) _ = CaseClauseL+infixr 0 /->++-- | Pattern match on the given sum type.+--+-- You have to provide a 'Rec' containing case branches.+-- To construct a case branch use '/->' operator.+case_+  :: forall dt out inp.+     ( InstrCaseC dt inp out+     , RMap (CaseClauses dt)+     )+  => Rec (CaseClauseL inp out) (CaseClauses dt) -> dt & inp :-> out+case_ = I . instrCase @dt . rmap coerceCaseClause+  where+    coerceCaseClause+      :: forall clauses.+         CaseClauseL inp out clauses -> CaseClause (ToTs inp) (ToTs out) clauses+    coerceCaseClause (CaseClauseL (I cc)) =+      CaseClause $ case Proxy @clauses of+        (_ :: Proxy ('CaseClauseParam ctor cc)) ->+          case appendCtorFieldAxiom @cc @inp of Dict -> cc++-- | Like 'case_', accepts a tuple of clauses, which may be more convenient.+caseT+  :: forall dt out inp clauses.+     ( InstrCaseC dt inp out+     , RMap (CaseClauses dt)+     , RecFromTuple clauses+     , clauses ~ Rec (CaseClauseL inp out) (CaseClauses dt)+     )+  => IsoRecTuple clauses -> dt & inp :-> out+caseT = case_ @dt . recFromTuple
+ src/Lorentz/Arith.hs view
@@ -0,0 +1,146 @@+-- | Type families from 'Michelson.Typed.Arith' lifted to Haskell types.+module Lorentz.Arith+  ( ArithOpHs (..)+  , UnaryArithOpHs (..)+  ) where++import qualified Data.Kind as Kind++import Lorentz.Value+import Michelson.Typed.Arith+import Michelson.Typed.Haskell.Value+import Michelson.Typed.T++-- | Lifted 'AithOp'.+class ( ArithOp aop (ToCT n) (ToCT m)+      , IsComparable n, IsComparable m+      , Typeable (ToCT n), Typeable (ToCT m)+      , ToT (ArithResHs aop n m) ~ 'Tc (ArithRes aop (ToCT n) (ToCT m))+      ) => ArithOpHs (aop :: Kind.Type) (n :: Kind.Type) (m :: Kind.Type) where+  type ArithResHs aop n m :: Kind.Type++-- | Lifted 'UnaryAithOp'.+class ( UnaryArithOp aop (ToCT n)+      , IsComparable n+      , Typeable (ToCT n)+      , ToT (UnaryArithResHs aop n) ~ 'Tc (UnaryArithRes aop (ToCT n))+      ) => UnaryArithOpHs (aop :: Kind.Type) (n :: Kind.Type) where+  type UnaryArithResHs aop n :: Kind.Type++instance ArithOpHs Add Natural Integer where+  type ArithResHs Add Natural Integer = Integer+instance ArithOpHs Add Integer Natural where+  type ArithResHs Add Integer Natural = Integer+instance ArithOpHs Add Natural Natural where+  type ArithResHs Add Natural Natural = Natural+instance ArithOpHs Add Integer Integer where+  type ArithResHs Add Integer Integer = Integer+instance ArithOpHs Add Timestamp Integer where+  type ArithResHs Add Timestamp Integer = Timestamp+instance ArithOpHs Add Integer Timestamp where+  type ArithResHs Add Integer Timestamp = Timestamp+instance ArithOpHs Add Mutez Mutez where+  type ArithResHs Add Mutez Mutez = Mutez++instance ArithOpHs Sub Natural Integer where+  type ArithResHs Sub Natural Integer = Integer+instance ArithOpHs Sub Integer Natural where+  type ArithResHs Sub Integer Natural = Integer+instance ArithOpHs Sub Natural Natural where+  type ArithResHs Sub Natural Natural = Integer+instance ArithOpHs Sub Integer Integer where+  type ArithResHs Sub Integer Integer = Integer+instance ArithOpHs Sub Timestamp Integer where+  type ArithResHs Sub Timestamp Integer = Timestamp+instance ArithOpHs Sub Timestamp Timestamp where+  type ArithResHs Sub Timestamp Timestamp = Integer+instance ArithOpHs Sub Mutez Mutez where+  type ArithResHs Sub Mutez Mutez = Mutez++instance ArithOpHs Mul Natural Integer where+  type ArithResHs Mul Natural Integer = Integer+instance ArithOpHs Mul Integer Natural where+  type ArithResHs Mul Integer Natural = Integer+instance ArithOpHs Mul Natural Natural where+  type ArithResHs Mul Natural Natural = Natural+instance ArithOpHs Mul Integer Integer where+  type ArithResHs Mul Integer Integer = Integer+instance ArithOpHs Mul Natural Mutez where+  type ArithResHs Mul Natural Mutez = Mutez+instance ArithOpHs Mul Mutez Natural where+  type ArithResHs Mul Mutez Natural = Mutez++instance UnaryArithOpHs Abs Integer where+  type UnaryArithResHs Abs Integer = Natural++instance UnaryArithOpHs Neg Integer where+  type UnaryArithResHs Neg Integer = Integer+instance UnaryArithOpHs Neg Natural where+  type UnaryArithResHs Neg Natural = Integer++instance ArithOpHs Or Natural Natural where+  type ArithResHs Or Natural Natural = Natural+instance ArithOpHs Or Bool Bool where+  type ArithResHs Or Bool Bool = Bool++instance ArithOpHs And Integer Natural where+  type ArithResHs And Integer Natural = Integer+instance ArithOpHs And Natural Natural where+  type ArithResHs And Natural Natural = Natural+instance ArithOpHs And Bool Bool where+  type ArithResHs And Bool Bool = Bool++instance ArithOpHs Xor Natural Natural where+  type ArithResHs Xor Natural Natural = Natural+instance ArithOpHs Xor Bool Bool where+  type ArithResHs Xor Bool Bool = Bool++instance ArithOpHs Lsl Natural Natural where+  type ArithResHs Lsl Natural Natural = Natural++instance ArithOpHs Lsr Natural Natural where+  type ArithResHs Lsr Natural Natural = Natural++instance UnaryArithOpHs Not Integer where+  type UnaryArithResHs Not Integer = Integer+instance UnaryArithOpHs Not Natural where+  type UnaryArithResHs Not Natural = Integer+instance UnaryArithOpHs Not Bool where+  type UnaryArithResHs Not Bool = Bool++instance ArithOpHs Compare Bool Bool where+  type ArithResHs Compare Bool Bool = Integer+instance ArithOpHs Compare Address Address where+  type ArithResHs Compare Address Address = Integer+instance ArithOpHs Compare Natural Natural where+  type ArithResHs Compare Natural Natural = Integer+instance ArithOpHs Compare Integer Integer where+  type ArithResHs Compare Integer Integer = Integer+instance ArithOpHs Compare MText MText where+  type ArithResHs Compare MText MText = Integer+instance ArithOpHs Compare ByteString ByteString where+  type ArithResHs Compare ByteString ByteString = Integer+instance ArithOpHs Compare Timestamp Timestamp where+  type ArithResHs Compare Timestamp Timestamp = Integer+instance ArithOpHs Compare Mutez Mutez where+  type ArithResHs Compare Mutez Mutez = Integer+instance ArithOpHs Compare KeyHash KeyHash where+  type ArithResHs Compare KeyHash KeyHash = Integer++instance UnaryArithOpHs Eq' Integer where+  type UnaryArithResHs Eq' Integer = Bool++instance UnaryArithOpHs Neq Integer where+  type UnaryArithResHs Neq Integer = Bool++instance UnaryArithOpHs Lt Integer where+  type UnaryArithResHs Lt Integer = Bool++instance UnaryArithOpHs Gt Integer where+  type UnaryArithResHs Gt Integer = Bool++instance UnaryArithOpHs Le Integer where+  type UnaryArithResHs Le Integer = Bool++instance UnaryArithOpHs Ge Integer where+  type UnaryArithResHs Ge Integer = Bool
+ src/Lorentz/Base.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Foundation of Lorentz development.+module Lorentz.Base+  ( (:->) (..)+  , type (%>)+  , type (&)+  , (#)++  , compileLorentz+  , compileLorentzContract+  , printLorentzContract++  , ContractOut+  , Contract+  , Lambda++  ) where++import qualified Data.Kind as Kind+import Data.Singletons (SingI)++import Lorentz.Constraints+import Lorentz.Value+import Michelson.Printer (printTypedContract)+import Michelson.Typed (Instr(..), T(..), ToT, ToTs, Value'(..))++-- | Alias for instruction which hides inner types representation via 'T'.+newtype (inp :: [Kind.Type]) :-> (out :: [Kind.Type]) =+  I { unI :: Instr (ToTs inp) (ToTs out) }+  deriving (Show, Eq)+infixr 1 :->++-- | Alias for ':->', seems to make signatures more readable sometimes.+--+-- Let's someday decide which one of these two should remain.+type (%>) = (:->)+infixr 1 %>++-- | For use outside of Lorentz.+compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out)+compileLorentz = unI++type ContractOut st = '[([Operation], st)]+type Contract cp st = '[(cp, st)] :-> ContractOut st++-- | Version of 'compileLorentz' specialized to instruction corresponding to+-- contract code.+compileLorentzContract+  :: forall cp st.+     (NoOperation cp, NoOperation st, NoBigMap cp, CanHaveBigMap st)+  => Contract cp st -> Instr '[ToT (cp, st)] '[ToT ([Operation], st)]+compileLorentzContract = compileLorentz++printLorentzContract+  :: forall cp st.+      ( SingI (ToT cp), SingI (ToT st)+      , NoOperation cp, NoOperation st, NoBigMap cp, CanHaveBigMap st+      )+  => Contract cp st -> LText+printLorentzContract = printTypedContract . compileLorentzContract++type (&) (a :: Kind.Type) (b :: [Kind.Type]) = a ': b+infixr 2 &++(#) :: (a :-> b) -> (b :-> c) -> a :-> c+I l # I r = I (l `Seq` r)++type Lambda i o = '[i] :-> '[o]++instance IsoValue (Lambda inp out) where+  type ToT (Lambda inp out) = 'TLambda (ToT inp) (ToT out)+  toVal = VLam . unI+  fromVal (VLam l) = I l
+ src/Lorentz/Coercions.hs view
@@ -0,0 +1,47 @@+-- | Identity transformations between different Haskell types.+module Lorentz.Coercions+  ( Coercible_+  , coerce_++  , coerceUnwrap+  , coerceWrap+  , toNamed+  , fromNamed++    -- * Re-exports+  , Wrapped (..)+  ) where++import Control.Lens (Wrapped(..))+import Data.Vinyl.Derived (Label)+import Named (NamedF)++import Lorentz.Base+import Michelson.Typed++-- | Whether two types have the same Michelson representation.+type Coercible_ a b = ToT a ~ ToT b++-- | Convert between values of types that have the same representation.+coerce_ :: Coercible_ a b => a & s :-> b & s+coerce_ = I Nop++-- | Specialized version of 'coerce_' to wrap into a haskell newtype.+coerceWrap+  :: Coercible_ newtyp (Unwrapped newtyp)+  => Unwrapped newtyp : s :-> newtyp : s+coerceWrap = coerce_++-- | Specialized version of 'coerce_' to unwrap a haskell newtype.+coerceUnwrap+  :: Coercible_ newtyp (Unwrapped newtyp)+  => newtyp : s :-> Unwrapped newtyp : s+coerceUnwrap = coerce_++-- | Lift given value to a named value.+toNamed :: Label name -> a : s :-> NamedF Identity a name : s+toNamed _ = coerceWrap++-- | Unpack named value.+fromNamed :: Label name -> NamedF Identity a name : s :-> a : s+fromNamed _ = coerceUnwrap
+ src/Lorentz/Constraints.hs view
@@ -0,0 +1,23 @@+module Lorentz.Constraints+  ( CanHaveBigMap+  , KnownValue+  , KnownCValue+  , NoOperation+  , NoBigMap+  ) where++import Data.Singletons (SingI)++import Michelson.Typed++-- | Gathers constraints, commonly required for values.+type KnownValue a = (Typeable (ToT a), SingI (ToT a))++type KnownCValue a = (IsoValue a, Typeable (ToCT a), SingI (ToCT a))++-- | Ensure given type does not contain "operation".+type NoOperation a = ForbidOp (ToT a)++type NoBigMap a = ForbidBigMap (ToT a)++type CanHaveBigMap a = AllowBigMap (ToT a)
+ src/Lorentz/Discover.hs view
@@ -0,0 +1,118 @@+-- | Utilities used for contracts discovery.+--+-- All the discovery logic resides in 'lorentz-discover' executable.+module Lorentz.Discover+  ( IsContract (..)++  , ExportedContractInfo (..)+  , ExportedContractDecl (..)++  , isHaskellModule+  , haskellExportsParser+  ) where++import Data.Char (isAlphaNum)+import Data.Singletons (SingI)+import qualified Data.Text as T+import System.FilePath.Posix (takeExtension, takeFileName)+import Text.Megaparsec (Parsec)+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as PL++import qualified Lorentz.Base as L+import Lorentz.Constraints+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U++-- | Defined for values representing a contract.+class IsContract c where+  toUntypedContract :: c -> U.Contract++instance IsContract U.Contract where+  toUntypedContract = id++instance (SingI cp, SingI st) => IsContract (T.Contract cp st) where+  toUntypedContract = T.convertContract++instance ( SingI (T.ToT cp), SingI (T.ToT st)+         , NoOperation cp, NoOperation st, NoBigMap cp, CanHaveBigMap st+         ) =>+         IsContract (L.Contract cp st) where+  toUntypedContract = toUntypedContract . L.compileLorentzContract++-- | Information about a contract required for contracts registry.+data ExportedContractInfo = ExportedContractInfo+  { eciModuleName :: Text+  , eciContractDecl :: ExportedContractDecl+  } deriving (Show, Eq)++-- | Contract names, for Haskell and for humans.+data ExportedContractDecl = ExportedContractDecl+  { ecdName :: Text+    -- ^ Identifier of a contract, e.g. "auction".+  , ecdVar :: Text+    -- ^ Name of a contract as is appears in Haskell code.+  } deriving (Show, Eq)++isHaskellModule :: FilePath -> Bool+isHaskellModule path =+  let file = takeFileName path+  in and+     [ takeExtension file == ".hs"+     , all (\c -> isAlphaNum c || c == '_' || c == '.') file+     ]++haskellExportsParser :: Parsec Void Text [ExportedContractInfo]+haskellExportsParser = do+  space+  symbol "module"+  moduleName <-+    lexeme $ P.takeWhile1P (Just "module name")+                           (\c -> isAlphaNum c || c `elem` ['.', '_'])+  symbol "("+  exports <- exportItems+  symbol ")"+  symbol "where"+  return+    [ ExportedContractInfo+      { eciModuleName = moduleName+      , eciContractDecl = decl+      }+    | exportRaw <- exports+    , let export = T.strip exportRaw+    , Just decl <- pure $ toContractDecl export+    ]+  where+    exportItems :: Parsec Void Text [Text]+    exportItems = P.sepBy exportItem (symbol ",")++    -- We do not follow the syntax precisely, just trying to parse+    -- all valid Haskell programs+    exportItem = fmap mconcat . many . lexeme $+      P.choice+        [ P.takeWhile1P Nothing isExportEntryChar+        , do symbol "("+             _ <- exportItems+             symbol ")"+             return "(..)"  -- we are not interested in content+        , symbol ".." $> ".."+        ]++    space = PL.space P.space1 (PL.skipLineComment "--")+                              (PL.skipBlockComment "{-" "-}")+    lexeme = PL.lexeme space+    symbol = void . PL.symbol space++isExportEntryChar :: Char -> Bool+isExportEntryChar c = isAlphaNum c || c == '_'++toContractDecl :: Text -> Maybe ExportedContractDecl+toContractDecl varName = do+  rawName <- T.stripPrefix "contract_" varName+  guard $ all isExportEntryChar $ toString rawName+  let name = T.replace "_" " " rawName+  return ExportedContractDecl+    { ecdName = name+    , ecdVar = varName+    }
+ src/Lorentz/Errors.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DerivingStrategies #-}++-- | Advanced errors.+module Lorentz.Errors+  ( IsError+  , LorentzUserError+  , unLorentzUserError+  , UserFailInstr+  , userFailWith+  ) where++import Data.Singletons (SingI)+import Data.Vinyl.Derived (Label)+import GHC.TypeLits (KnownSymbol, symbolVal)++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Instr+import Lorentz.Value+import Michelson.Text+import Michelson.Typed.Haskell++-- | Constraints on an object you can fail with.+type IsError err =+  ( IsoValue err+  , KnownValue err+  , NoOperation err+  , NoBigMap err+  )++-- | A unique error identifier.+newtype ErrorTag = ErrorTag MText+  deriving newtype (Show, Eq, Ord, IsString, IsoValue)++-- | An error indicating a normal failure caused by such user input.+type LorentzUserError e = (ErrorTag, e)++-- | Pseudo-getter for error within 'LorentzUserError'.+unLorentzUserError :: LorentzUserError e -> e+unLorentzUserError = snd++-- | Signature of 'userFailWith'.+type UserFailInstr e name s s'+  = (InstrWrapC e name, KnownSymbol name)+  => Label name -> AppendCtorField (GetCtorField e name) s :-> s'++-- | Fail with given error, picking argument for error from the top+-- of the stack if any required. Error will be wrapped into 'LorentzUserError'+-- (i.e. an error tag will be attached to the error data).+--+-- Consider the following practice: once error datatype for your contract+-- is defined, create a specialization of this function to the error type.+userFailWith+  :: forall err name s s'.+      (Typeable (ToT err), SingI (ToT err))+  => UserFailInstr err name s s'+userFailWith label =+  wrap_ @err @_ @s label # push (mkMTextUnsafe . toText $ symbolVal (Proxy @name)) # pair #+  coerce_ @_ @(LorentzUserError err) #+  failWith
+ src/Lorentz/Ext.hs view
@@ -0,0 +1,37 @@+module Lorentz.Ext+  ( stackRef+  , printComment+  , testAssert+  , stackType+  ) where++import Data.Singletons (SingI)++import Lorentz.Base+import Michelson.Typed.Haskell+import Michelson.Typed.Instr+import Util.Peano++stackRef+  :: forall (gn :: Nat) st n.+      (n ~ ToPeano gn, SingI n, KnownPeano n, RequireLongerThan st n)+  => PrintComment st+stackRef = PrintComment . one . Right $ mkStackRef @gn++printComment :: PrintComment (ToTs s) -> s :-> s+printComment = I . Ext . PRINT++testAssert+  :: Typeable (ToTs out)+  => Text -> PrintComment (ToTs inp) -> inp :-> Bool & out -> inp :-> inp+testAssert msg comment (I instr) =+  I . (Ext . TEST_ASSERT) $ TestAssert msg comment instr++stackType :: forall s. s :-> s+stackType = I Nop++_sample1 :: s ~ (a & s') => s :-> s+_sample1 = printComment $ "Head is " <> stackRef @0++_sample2 :: Integer & Natural & s :-> Integer & Natural & s+_sample2 = stackType @(Integer & _)
+ src/Lorentz/Instr.hs view
@@ -0,0 +1,448 @@+module Lorentz.Instr+  ( nop+  , drop+  , dup+  , swap+  , push+  , some+  , none+  , unit+  , ifNone+  , pair+  , car+  , cdr+  , left+  , right+  , ifLeft+  , nil+  , cons+  , size+  , emptySet+  , emptyMap+  , map+  , iter+  , mem+  , get+  , update+  , failingWhenPresent+  , updateNew+  , if_+  , ifCons+  , loop+  , loopLeft+  , lambda+  , exec+  , dip+  , failWith+  , failText+  , failTagged+  , failUsing+  , failUnexpected+  , cast+  , pack+  , unpack+  , concat+  , concat'+  , slice, isNat, add, sub, rsub, mul, ediv, abs+  , neg+  , lsl+  , lsr+  , or+  , and+  , xor+  , not+  , compare+  , eq0+  , neq0+  , lt0+  , gt0+  , le0+  , ge0+  , int+  , self+  , contract+  , transferTokens+  , setDelegate+  , createAccount+  , createContract+  , implicitAccount+  , now+  , amount+  , balance+  , checkSignature+  , sha256+  , sha512+  , blake2B+  , hashKey+  , stepsToQuota+  , source+  , sender+  , address+  , LorentzFunctor (..)+  ) where++import Prelude hiding+  (EQ, GT, LT, abs, and, compare, concat, drop, get, map, not, or, some, swap, xor)++import qualified Data.Kind as Kind++import Lorentz.Arith+import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Polymorphic+import Lorentz.Value+import Michelson.Typed+  (Instr(..), Notes(NStar), ToT, Value'(..), checkBigMapConstraint, forbiddenBigMap,+  forbiddenOp)+import Michelson.Text+import Michelson.Typed.Arith++nop :: s :-> s+nop = I Nop++drop :: a & s :-> s+drop = I DROP++dup  :: a & s :-> a & a & s+dup = I DUP++swap :: a & b & s :-> b & a & s+swap = I SWAP++push :: forall t s .(KnownValue t, NoOperation t, NoBigMap t, IsoValue t) => t -> (s :-> t & s)+push a = I $ forbiddenOp @(ToT t) $ forbiddenBigMap @(ToT t) $ PUSH (toVal a)++some :: a & s :-> Maybe a & s+some = I SOME++none :: forall a s . KnownValue a => s :-> (Maybe a & s)+none = I NONE++unit :: s :-> () & s+unit = I UNIT++ifNone+  :: (s :-> s') -> (a & s :-> s') -> (Maybe a & s :-> s')+ifNone (I l) (I r) = I (IF_NONE l r)++pair :: a & b & s :-> (a, b) & s+pair = I PAIR++car :: (a, b) & s :-> a & s+car = I CAR++cdr :: (a, b) & s :-> b & s+cdr = I CDR++left :: forall a b s. KnownValue b => a & s :-> Either a b & s+left = I LEFT++right :: forall a b s. KnownValue a => b & s :-> Either a b & s+right = I RIGHT++ifLeft+  :: (a & s :-> s') -> (b & s :-> s') -> (Either a b & s :-> s')+ifLeft (I l) (I r) = I (IF_LEFT l r)++nil :: KnownValue p => s :-> List p & s+nil = I NIL++cons :: a & List a & s :-> List a & s+cons = I CONS++ifCons+  :: (a & List a & s :-> s') -> (s :-> s') -> (List a & s :-> s')+ifCons (I l) (I r) = I (IF_CONS l r)++size :: SizeOpHs c => c & s :-> Natural & s+size = I SIZE++emptySet :: (KnownCValue e) => s :-> Set e & s+emptySet = I EMPTY_SET++emptyMap :: (KnownCValue k, KnownValue v)+         => s :-> Map k v & s+emptyMap = I EMPTY_MAP++map+  :: (MapOpHs c, IsoMapOpRes c b)+  => (MapOpInpHs c & s :-> b & s) -> (c & s :-> MapOpResHs c b & s)+map (I action) = I (MAP action)++iter+  :: (IterOpHs c)+  => (IterOpElHs c & s :-> s) -> (c & s :-> s)+iter (I action) = I (ITER action)++mem :: MemOpHs c => MemOpKeyHs c & c & s :-> Bool & s+mem = I MEM++get :: GetOpHs c => GetOpKeyHs c & c & s :-> Maybe (GetOpValHs c) & s+get = I GET++update :: UpdOpHs c => UpdOpKeyHs c & UpdOpParamsHs c & c & s :-> c & s+update = I UPDATE++if_ :: (s :-> s') -> (s :-> s') -> (Bool & s :-> s')+if_ (I l) (I r) = I (IF l r)++loop :: (s :-> Bool & s) -> (Bool & s :-> s)+loop (I b) = I (LOOP b)++loopLeft+  :: (a & s :-> Either a b & s) -> (Either a b & s :-> b & s)+loopLeft (I b) = I (LOOP_LEFT b)++lambda+  :: (KnownValue i, KnownValue o)+  => Lambda i o -> (s :-> Lambda i o & s)+lambda (I l) = I (LAMBDA $ VLam l)++exec :: a & Lambda a b & s :-> b & s+exec = I EXEC++dip :: forall a s s'. (s :-> s') -> (a & s :-> a & s')+dip (I a) = I (DIP a)++failWith :: (KnownValue a) => a & s :-> t+failWith = I FAILWITH++cast :: KnownValue a => (a & s :-> a & s)+cast = I CAST++pack+  :: forall a s. (KnownValue a, NoOperation a, NoBigMap a)+  => a & s :-> ByteString & s+pack = I $ forbiddenOp @(ToT a) $ forbiddenBigMap @(ToT a) PACK++unpack+  :: forall a s. (KnownValue a, NoOperation a, NoBigMap a)+  => ByteString & s :-> Maybe a & s+unpack = I $ forbiddenOp @(ToT a) $ forbiddenBigMap @(ToT a) UNPACK++concat :: ConcatOpHs c => c & c & s :-> c & s+concat = I CONCAT++concat' :: ConcatOpHs c => List c & s :-> c & s+concat' = I CONCAT'++slice :: SliceOpHs c => Natural & Natural & c & s :-> Maybe c & s+slice = I SLICE++isNat :: Integer & s :-> Maybe Natural & s+isNat = I ISNAT++add+  :: ArithOpHs Add n m+  => n & m & s :-> ArithResHs Add n m & s+add = I ADD++sub+  :: ArithOpHs Sub n m+  => n & m & s :-> ArithResHs Sub n m & s+sub = I SUB++rsub+  :: ArithOpHs Sub n m+  => m & n & s :-> ArithResHs Sub n m & s+rsub = swap # sub++mul+  :: ArithOpHs Mul n m+  => n & m & s :-> ArithResHs Mul n m & s+mul = I MUL++ediv :: EDivOpHs n m+     => n & m & s+     :-> Maybe ((EDivOpResHs n m, EModOpResHs n m)) & s+ediv = I EDIV++abs :: UnaryArithOpHs Abs n => n & s :-> UnaryArithResHs Abs n & s+abs = I ABS++neg :: UnaryArithOpHs Neg n => n & s :-> UnaryArithResHs Neg n & s+neg = I NEG+++lsl+  :: ArithOpHs Lsl n m+  => n & m & s :-> ArithResHs Lsl n m & s+lsl = I LSL++lsr+  :: ArithOpHs Lsr n m+  => n & m & s :-> ArithResHs Lsr n m & s+lsr = I LSR++or+  :: ArithOpHs Or n m+  => n & m & s :-> ArithResHs Or n m & s+or = I OR++and+  :: ArithOpHs And n m+  => n & m & s :-> ArithResHs And n m & s+and = I AND++xor+  :: (ArithOpHs Xor n m)+  => n & m & s :-> ArithResHs Xor n m & s+xor = I XOR++not :: UnaryArithOpHs Not n => n & s :-> UnaryArithResHs Not n & s+not = I NOT++compare :: ArithOpHs Compare n m+        => n & m & s :-> ArithResHs Compare n m & s+compare = I COMPARE++eq0 :: UnaryArithOpHs Eq' n => n & s :-> UnaryArithResHs Eq' n & s+eq0 = I EQ++neq0 :: UnaryArithOpHs Neq n => n & s :-> UnaryArithResHs Neq n & s+neq0 = I NEQ++lt0 :: UnaryArithOpHs Lt n => n & s :-> UnaryArithResHs Lt n & s+lt0 = I LT++gt0 :: UnaryArithOpHs Gt n => n & s :-> UnaryArithResHs Gt n & s+gt0 = I GT++le0 :: UnaryArithOpHs Le n => n & s :-> UnaryArithResHs Le n & s+le0 = I LE++ge0 :: UnaryArithOpHs Ge n => n & s :-> UnaryArithResHs Ge n & s+ge0 = I GE++int :: Natural & s :-> Integer & s+int = I INT++self :: forall cp s . s :-> ContractAddr cp & s+self = I SELF++contract :: (KnownValue p) => Address & s :-> Maybe (ContractAddr p) & s+contract = I (CONTRACT NStar)++transferTokens+  :: forall p s. (KnownValue p, NoOperation p, NoBigMap p)+  => p & Mutez & ContractAddr p & s :-> Operation & s+transferTokens = I $ forbiddenOp @(ToT p) $ forbiddenBigMap @(ToT p) TRANSFER_TOKENS++setDelegate :: Maybe KeyHash & s :-> Operation & s+setDelegate = I SET_DELEGATE++createAccount :: KeyHash & Maybe KeyHash & Bool & Mutez & s+              :-> Operation & Address & s+createAccount = I CREATE_ACCOUNT+++createContract+  :: forall p g s. (KnownValue p, NoOperation p, KnownValue g, NoOperation g+                   , NoBigMap p, CanHaveBigMap g)+  => '[(p, g)] :-> '[(List Operation, g)]+  -> KeyHash & Maybe KeyHash & Bool & Bool & Mutez & g & s+  :-> Operation & Address & s+createContract (I c) =+  I $ forbiddenOp @(ToT p) $ forbiddenOp @(ToT g) $+  forbiddenBigMap @(ToT p) $ checkBigMapConstraint @(ToT g) $ CREATE_CONTRACT c++implicitAccount :: KeyHash & s :-> ContractAddr () & s+implicitAccount = I IMPLICIT_ACCOUNT++now :: s :-> Timestamp & s+now = I NOW++amount :: s :-> Mutez & s+amount = I AMOUNT++balance :: s :-> Mutez & s+balance = I BALANCE++checkSignature :: PublicKey & Signature & ByteString & s :-> Bool & s+checkSignature = I CHECK_SIGNATURE++sha256 :: ByteString & s :-> ByteString & s+sha256 = I SHA256++sha512 :: ByteString & s :-> ByteString & s+sha512 = I SHA512++blake2B :: ByteString & s :-> ByteString & s+blake2B = I BLAKE2B++hashKey :: PublicKey & s :-> KeyHash & s+hashKey = I HASH_KEY++stepsToQuota :: s :-> Natural & s+stepsToQuota = I STEPS_TO_QUOTA++{-# WARNING source+    "Using `source` is considered a bad practice.\n\+\    Consider using `sender` instead until further investigation" #-}+source :: s :-> Address & s+source = I SOURCE++sender :: s :-> Address & s+sender = I SENDER++address :: ContractAddr a & s :-> Address & s+address = I ADDRESS++----------------------------------------------------------------------------+-- Non-canonical instructions+----------------------------------------------------------------------------++-- | Helper instruction.+--+-- Checks whether given key present in the storage and fails if it is.+-- This instruction leaves stack intact.+failingWhenPresent+  :: forall c k s v st e.+     ( MemOpHs c, k ~ MemOpKeyHs c+     , KnownValue e+     , st ~ (k & v & c & s)+     )+  => (forall s0. k : s0 :-> e : s0)+  -> st :-> st+failingWhenPresent mkErr =+  dip (dip dup # swap) # swap # dip dup # swap # mem #+  if_ (mkErr # failWith) nop++-- | Like 'update', but throw an error on attempt to overwrite existing entry.+updateNew+  :: forall c k s e.+     ( UpdOpHs c, MemOpHs c, k ~ UpdOpKeyHs c, k ~ MemOpKeyHs c+     , KnownValue e+     )+  => (forall s0. k : s0 :-> e : s0)+  -> k & UpdOpParamsHs c & c & s :-> c & s+updateNew mkErr = failingWhenPresent mkErr # update++-- | Fail with a given message.+failText :: MText -> s :-> t+failText msg = push msg # failWith++-- | Fail with a given message and the top of the current stack.+failTagged :: (KnownValue a) => MText -> a & s :-> t+failTagged tag = push tag # pair # failWith++-- | Fail with the given Haskell value.+failUsing+  :: (IsoValue a, KnownValue a, NoOperation a, NoBigMap a)+  => a -> s :-> t+failUsing err = push err # failWith++-- | Fail, providing a reference to the place in the code where+-- this function is called.+--+-- Like 'error' in Haskell code, this instruction is for internal errors only.+failUnexpected :: HasCallStack => MText -> s :-> t+failUnexpected msg =+  failText $ [mt|Unexpected failure: |] <> msg <> [mt|\n|]+          <> mkMTextCut (toText $ prettyCallStack callStack)++class LorentzFunctor (c :: Kind.Type -> Kind.Type) where+  lmap :: KnownValue b => (a : s :-> b : s) -> (c a : s :-> c b : s)++instance LorentzFunctor Maybe where+  lmap f = ifNone none (f # some)
+ src/Lorentz/Macro.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}++-- | Common Michelson macros defined using Lorentz syntax.+module Lorentz.Macro+  ( -- * Compare+    IfCmpXConstraints+  , eq+  , neq+  , lt+  , gt+  , le+  , ge+  , ifEq0+  , ifGe0+  , ifGt0+  , ifLe0+  , ifLt0+  , ifNeq0+  , ifEq+  , ifGe+  , ifGt+  , ifLe+  , ifLt+  , ifNeq++  -- * Fail+  , fail_++  -- * Assertion macros+  -- |+  -- They differ from the same macros in Michelson, because those+  -- macros use FAIL macro which is not informative (fails with unit).+  -- If you __really__ want Michelson versions (maybe to produce exact+  -- copy of an existing contract), you can pass empty string, then+  -- FAILWITH will be called with unit, not empty string.+  , assert+  , assertEq0+  , assertNeq0+  , assertLt0+  , assertGt0+  , assertLe0+  , assertGe0+  , assertEq+  , assertNeq+  , assertLt+  , assertGt+  , assertLe+  , assertGe+  , assertNone+  , assertSome+  , assertLeft+  , assertRight+  , assertUsing++  -- * Syntactic Conveniences+  , dipX+  , dropX+  , cloneX+  , duupX+  , elevateX+  , caar+  , cadr+  , cdar+  , cddr+  , ifRight+  , ifSome+  , mapCar+  , mapCdr+  , papair+  , ppaiir+  , unpair+  , setCar+  , setCdr+  , setInsert+  , mapInsert+  , setInsertNew+  , mapInsertNew+  , deleteMap+  , setDelete++  -- * Additional Morley macros+  , View (..)+  , Void_ (..)+  , VoidResult(..)+  , view_+  , void_+  , mkVoid+  ) where++import Prelude hiding (compare, drop, some, swap)++import qualified Data.Kind as Kind+import Data.Vinyl.TypeLevel (Nat(..))+import GHC.TypeNats (type (+), type (-))+import qualified GHC.TypeNats as GHC (Nat)++import Lorentz.Arith+import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Coercions+import Lorentz.Instr+import Lorentz.Value+import Michelson.Typed.Arith+import Michelson.Typed.Haskell.Value+import Util.Peano++----------------------------------------------------------------------------+-- Compare+----------------------------------------------------------------------------++eq :: (ArithOpHs Compare n m, UnaryArithOpHs Eq' (ArithResHs Compare n m))+   => n & m & s :-> (UnaryArithResHs Eq' (ArithResHs Compare n m)) & s+eq = compare # eq0++neq :: (ArithOpHs Compare n m, UnaryArithOpHs Neq (ArithResHs Compare n m))+   => n & m & s :-> (UnaryArithResHs Neq (ArithResHs Compare n m)) & s+neq = compare # neq0++gt :: (ArithOpHs Compare n m, UnaryArithOpHs Gt (ArithResHs Compare n m))+   => n & m & s :-> (UnaryArithResHs Gt (ArithResHs Compare n m)) & s+gt = compare # gt0++le :: (ArithOpHs Compare n m, UnaryArithOpHs Le (ArithResHs Compare n m))+   => n & m & s :-> (UnaryArithResHs Le (ArithResHs Compare n m)) & s+le = compare # le0++ge :: (ArithOpHs Compare n m, UnaryArithOpHs Ge (ArithResHs Compare n m))+   => n & m & s :-> (UnaryArithResHs Ge (ArithResHs Compare n m)) & s+ge = compare # ge0++lt :: (ArithOpHs Compare n m, UnaryArithOpHs Lt (ArithResHs Compare n m))+   => n & m & s :-> (UnaryArithResHs Lt (ArithResHs Compare n m)) & s+lt = compare # lt0++type IfCmp0Constraints a op =+  (UnaryArithOpHs op a, (UnaryArithResHs op a ~ Bool))++ifEq0+  :: (IfCmp0Constraints a Eq')+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifEq0 l r = eq0 # if_ l r++ifNeq0+  :: (IfCmp0Constraints a Neq)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifNeq0 l r = neq0 # if_ l r++ifLt0+  :: (IfCmp0Constraints a Lt)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifLt0 l r = lt0 # if_ l r++ifGt0+  :: (IfCmp0Constraints a Gt)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifGt0 l r = gt0 # if_ l r++ifLe0+  :: (IfCmp0Constraints a Le)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifLe0 l r = le0 # if_ l r++ifGe0+  :: (IfCmp0Constraints a Ge)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifGe0 l r = ge0 # if_ l r++type IfCmpXConstraints a b op =+  (Typeable a, Typeable b, ArithOpHs Compare a b+  , UnaryArithOpHs op (ArithResHs Compare a b)+  , UnaryArithResHs op (ArithResHs Compare a b) ~ Bool)++ifEq+  :: (IfCmpXConstraints a b Eq')+  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+ifEq l r = eq # if_ l r++ifNeq+  :: (IfCmpXConstraints a b Neq)+  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+ifNeq l r = neq # if_ l r++ifLt+  :: (IfCmpXConstraints a b Lt)+  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+ifLt l r = lt # if_ l r++ifGt+  :: (IfCmpXConstraints a b Gt)+  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+ifGt l r = gt # if_ l r++ifLe+  :: (IfCmpXConstraints a b Le)+  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+ifLe l r = le # if_ l r++ifGe+  :: (IfCmpXConstraints a b Ge)+  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+ifGe l r = ge # if_ l r++----------------------------------------------------------------------------+-- Fail+----------------------------------------------------------------------------++-- | Analog of the FAIL macro in Michelson. Its usage is discouraged+-- because it doesn't carry any information about failure.+{-# WARNING fail_ "'fail_' remains in code" #-}+fail_ :: a :-> c+fail_ = unit # failWith++----------------------------------------------------------------------------+-- Assertions+----------------------------------------------------------------------------++-- Helper function, see Haddock comment in the export list.+assertionFailed :: MText -> whatever :-> anything+assertionFailed reason+  | null reason = fail_+  | otherwise = failText reason++assert :: MText -> Bool & s :-> s+assert reason = if_ nop (assertionFailed reason)++assertEq0 :: IfCmp0Constraints a Eq' => MText -> a & s :-> s+assertEq0 reason = ifEq0 nop (assertionFailed reason)++assertNeq0 :: IfCmp0Constraints a Neq => MText -> a & s :-> s+assertNeq0 reason = ifNeq0 nop (assertionFailed reason)++assertLt0 :: IfCmp0Constraints a Lt => MText -> a & s :-> s+assertLt0 reason = ifLt0 nop (assertionFailed reason)++assertGt0 :: IfCmp0Constraints a Gt => MText -> a & s :-> s+assertGt0 reason = ifGt0 nop (assertionFailed reason)++assertLe0 :: IfCmp0Constraints a Le => MText -> a & s :-> s+assertLe0 reason = ifLe0 nop (assertionFailed reason)++assertGe0 :: IfCmp0Constraints a Ge => MText -> a & s :-> s+assertGe0 reason = ifGe0 nop (assertionFailed reason)++assertEq :: IfCmpXConstraints a b Eq' => MText -> a & b & s :-> s+assertEq reason = ifEq nop (assertionFailed reason)++assertNeq :: IfCmpXConstraints a b Neq => MText -> a & b & s :-> s+assertNeq reason = ifNeq nop (assertionFailed reason)++assertLt :: IfCmpXConstraints a b Lt => MText -> a & b & s :-> s+assertLt reason = ifLt nop (assertionFailed reason)++assertGt :: IfCmpXConstraints a b Gt => MText -> a & b & s :-> s+assertGt reason = ifGt nop (assertionFailed reason)++assertLe :: IfCmpXConstraints a b Le => MText -> a & b & s :-> s+assertLe reason = ifLe nop (assertionFailed reason)++assertGe :: IfCmpXConstraints a b Ge => MText -> a & b & s :-> s+assertGe reason = ifGe nop (assertionFailed reason)++assertNone :: MText -> Maybe a & s :-> s+assertNone reason = ifNone nop (assertionFailed reason)++assertSome :: MText -> Maybe a & s :-> a & s+assertSome reason = ifNone (assertionFailed reason) nop++assertLeft :: MText -> Either a b & s :-> a & s+assertLeft reason = ifLeft nop (assertionFailed reason)++assertRight :: MText -> Either a b & s :-> b & s+assertRight reason = ifLeft (assertionFailed reason) nop++assertUsing+  :: (IsoValue a, KnownValue a, NoOperation a, NoBigMap a)+  => a -> Bool & s :-> s+assertUsing err = if_ nop $ failUsing err++----------------------------------------------------------------------------+-- Syntactic Conveniences+----------------------------------------------------------------------------++type family Above (n :: Peano) s where+  Above  'Z _s = '[]+  Above ('S n) (a ': s) = (a ': Above n s)++class DipX (n :: Peano) (head :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]) where+  dipXImpl :: s :-> s' -> head ++ s :-> head ++ s'+instance DipX 'Z '[] s s' where+  dipXImpl op = op+instance DipX n h s s' => DipX ('S n) (a ': h) s s' where+  dipXImpl = dip . dipXImpl @n @h++-- Type family, that is necessary for DipX+type family (++) (l :: [a]) (r :: [a]) where+  '[] ++ r = r+  (l ': ls) ++ r = l ': (ls ++ r)++-- | @DII+P@ macro. For example, `dipX @3` is `DIIIP`.+dipX+  :: forall (n :: GHC.Nat) inp out s s'.+  (DipX (ToPeano n) (Above (ToPeano n) inp) s s'+  , ((Above (ToPeano n) inp) ++ s) ~ inp+  , ((Above (ToPeano n) inp) ++ s') ~ out)+  => (s :-> s') -> inp :-> out+dipX = dipXImpl @(ToPeano n) @(Above (ToPeano n) inp)++-- | Custom Lorentz macro that drops element with given index+-- (starting from 0) from the stack.+dropX+  :: forall (n :: GHC.Nat) a inp out s s'.+  ( DipX (ToPeano n) (Above (ToPeano n) inp) s s'+  , ((Above (ToPeano n) inp) ++ s) ~ inp+  , ((Above (ToPeano n) inp) ++ s') ~ out+  , s ~ (a ': s')+  )+  => inp :-> out+dropX = dipX @n @inp @out @s @s' drop++class CloneX (n :: Peano) a s where+  type CloneXT n a s :: [Kind.Type]+  cloneXImpl :: a & s :-> CloneXT n a s+instance CloneX 'Z a s where+  type CloneXT 'Z a s = a & s+  cloneXImpl = nop+instance (CloneX n a s) => CloneX ('S n) a s where+  type CloneXT ('S n) a s = a ': CloneXT n a s+  cloneXImpl = dup # dip (cloneXImpl @n)++-- | Duplicate the top of the stack @n@ times.+--+-- For example, `cloneX @3` has type `a & s :-> a & a & a & a & s`.+cloneX+  :: forall (n :: GHC.Nat) a s. CloneX (ToPeano n) a s+  => a & s :-> CloneXT (ToPeano n) a s+cloneX = cloneXImpl @(ToPeano n)++class DuupX (n :: Peano) (s :: [Kind.Type]) (a :: Kind.Type) where+  duupXImpl :: s :-> a & s++instance DuupX ('S 'Z) (a & xs) a where+  duupXImpl = dup++instance DuupX ('S n) xs a => DuupX ('S ('S n)) (x & xs) a where+  duupXImpl = dip (duupXImpl @('S n) @xs @a) # swap++-- | @DUU+P@ macro. For example, `duupX @3` is `DUUUP`, it puts+-- the 3-rd (starting from 1) element to the top of the stack.+duupX+  :: forall (n :: GHC.Nat) inp .+  ( DuupX (ToPeano n) inp (At (ToPeano (n - 1)) inp)+  )+  => inp :-> (At (ToPeano (n - 1)) inp) & inp+duupX = duupXImpl @(ToPeano n) @inp @(At (ToPeano (n - 1)) inp)++-- | Move item with given index (starting from 0) to the top of the stack.+--+-- TODO: probably it can be implemented more efficiently, so if we+-- ever want to optimize gas consumption we can rewrite it.+-- It only makes sense if it's applied to a relatively large index.+elevateX+  :: forall (n :: GHC.Nat) inp out s a.+  ( DuupX (ToPeano (1 + n)) inp a+  , DipX (ToPeano (n + 1)) (Above (ToPeano (n + 1)) (a : inp)) (a : s) s+  , (a ': (Above (ToPeano n) inp) ++ s) ~ out+  , a ~ At (ToPeano n) inp++  -- These 3 constraints must hold if the above holds, but GHC can't deduce it.+  -- Btw, last constraint must always hold.+  , (Above (ToPeano (n + 1)) (a ': inp) ++ (a ': s)) ~ (a ': inp)+  , (Above (ToPeano (n + 1)) (a : inp) ++ s) ~ (a : (Above (ToPeano n) inp ++ s))+  , ((1 + n) - 1) ~ n+  ) => inp :-> out+elevateX = duupX @(1 + n) @inp # dropX @(n + 1) @a @(a ': inp) @out @(a ': s) @s++papair :: a & b & c & s :-> ((a, b), c) & s+papair = pair # pair++ppaiir :: a & b & c & s :-> (a, (b, c)) & s+ppaiir = dip pair # pair++unpair :: (a, b) & s :-> a & b & s+unpair = dup # car # dip cdr++cdar :: (a1, (a2, b)) & s :-> a2 & s+cdar = cdr # car++cddr :: (a1, (a2, b)) & s :-> b & s+cddr = cdr # cdr++caar :: ((a, b1), b2) & s :-> a & s+caar = car # car++cadr :: ((a, b1), b2) & s :-> b1 & s+cadr = car # cdr++setCar :: (a, b1) & (b2 & s) :-> (b2, b1) & s+setCar = cdr # swap # pair++setCdr :: (a, b1) & (b2 & s) :-> (a, b2) & s+setCdr = car # pair++mapCar+  :: a & s :-> a1 & s+  -> (a, b) & s :-> (a1, b) & s+mapCar op = dup # cdr # dip (car # op) # swap # pair++mapCdr+  :: b & (a, b) & s :-> b1 & (a, b) & s+  -> (a, b) & s :-> (a, b1) & s+mapCdr op = dup # cdr # op # swap # car # pair++ifRight :: (b & s :-> s') -> (a & s :-> s') -> (Either a b & s :-> s')+ifRight l r = ifLeft r l++ifSome+  :: (a & s :-> s') -> (s :-> s') -> (Maybe a & s :-> s')+ifSome s n = ifNone n s++-- | Various convenient instructions on maps.+class MapInstrs map where+  -- | Specialized version of 'update'.+  mapUpdate :: IsComparable k => k : Maybe v : map k v : s :-> map k v : s++  -- | Insert given element into map.+  mapInsert :: IsComparable k => k : v : map k v : s :-> map k v : s+  mapInsert = dip some # mapUpdate++  -- | Insert given element into map, ensuring that it does not overwrite+  -- any existing entry.+  --+  -- As first argument accepts container name (for error message).+  mapInsertNew+    :: (IsComparable k, KnownValue e)+    => (forall s0. k : s0 :-> e : s0)+    -> k : v : map k v : s :-> map k v : s++  -- | Delete element from the map.+  deleteMap+    :: forall k v s. (IsComparable k, KnownValue k, KnownValue v)+    => k : map k v : s :-> map k v : s+  deleteMap = dip (none @v) # mapUpdate++instance MapInstrs Map where+  mapUpdate = update+  mapInsertNew mkErr = failingWhenPresent mkErr # mapInsert+instance MapInstrs BigMap where+  mapUpdate = update+  mapInsertNew mkErr = failingWhenPresent mkErr # mapInsert++-- | Insert given element into set.+--+-- This is a separate function from 'updateMap' because stacks they operate with+-- differ in length.+setInsert :: IsComparable e => e & Set e & s :-> Set e & s+setInsert = dip (push True) # update++-- | Insert given element into set, ensuring that it does not overwrite+-- any existing entry.+--+-- As first argument accepts container name.+setInsertNew+  :: (IsComparable e, KnownValue err)+  => (forall s0. e : s0 :-> err : s0)+  -> e & Set e & s :-> Set e & s+setInsertNew desc = dip (push True) # failingWhenPresent desc # update++-- | Delete given element from the set.+setDelete :: IsComparable e => e & Set e & s :-> Set e & s+setDelete = dip (push False) # update++----------------------------------------------------------------------------+-- Additional Morley macros+----------------------------------------------------------------------------++-- | @view@ type synonym as described in A1.+data View (a :: Kind.Type) (r :: Kind.Type) = View+  { viewParam :: a+  , viewCallbackTo :: ContractAddr (a, Maybe r)+  } deriving stock Generic+    deriving anyclass IsoValue++view_ ::+     (KnownValue a, KnownValue r, NoOperation (a, r), NoBigMap (a, r))+  => (forall s0. (a, storage) & s0 :-> r : s0)+  -> View a r & storage & s :-> (List Operation, storage) & s+view_ code =+  coerce_ #+  unpair # dip (duupX @2) # dup # dip (pair # code # some) # pair # dip amount #+  transferTokens # nil # swap # cons # pair++-- | @void@ type synonym as described in A1.+data Void_ (a :: Kind.Type) (b :: Kind.Type) = Void_+  { voidParam :: a+    -- ^ Entry point argument.+  , voidResProxy :: Lambda b b+    -- ^ Type of result reported via 'failWith'.+  } deriving stock Generic+    deriving anyclass IsoValue++-- | Newtype over void result type used in tests to+-- distinguish successful void result from other errors.+--+-- Usage example:+-- lExpectFailWith (== VoidResult roleMaster)`+newtype VoidResult r = VoidResult { unVoidResult :: r }+  deriving newtype (Eq, IsoValue)++mkVoid :: forall b a. a -> Void_ a b+mkVoid a = Void_ a nop++void_+  :: forall a b s s' anything.+      (KnownValue b)+  => a & s :-> b & s' -> Void_ a b & s :-> anything+void_ code =+  coerce_ @_ @(_, Lambda b b) #+  unpair # swap # dip code # swap # exec # coerce_ @b @(VoidResult b) # failWith
+ src/Lorentz/Polymorphic.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE QuantifiedConstraints #-}++-- | Type families from 'Michelson.Typed.Polymorphic' lifted to Haskell types.+module Lorentz.Polymorphic+  ( MemOpHs (..)+  , MapOpHs (..)+  , IterOpHs (..)+  , SizeOpHs+  , UpdOpHs (..)+  , GetOpHs (..)+  , ConcatOpHs+  , SliceOpHs+  , EDivOpHs (..)++  , IsoMapOpRes+  ) where++import qualified Data.Kind as Kind++import Michelson.Text+import Michelson.Typed+import Tezos.Core (Mutez)++----------------------------------------------------------------------------+-- Mirrored from Michelson+----------------------------------------------------------------------------++-- | Lifted 'MemOpKey'.+class ( MemOp (ToT c)+      , ToT (MemOpKeyHs c) ~ 'Tc (MemOpKey (ToT c))+      ) => MemOpHs c where+  type MemOpKeyHs c :: Kind.Type++instance IsComparable e => MemOpHs (Set e) where+  type MemOpKeyHs (Set e) = e++instance IsComparable k => MemOpHs (Map k v) where+  type MemOpKeyHs (Map k v) = k++instance IsComparable k => MemOpHs (BigMap k v) where+  type MemOpKeyHs (BigMap k v) = k++-- | A useful property which holds for reasonable 'MapOp' instances.+--+-- It's a separate thing from 'MapOpHs' because it mentions @b@ type parameter.+type family IsoMapOpRes c b where+  IsoMapOpRes c b = ToT (MapOpResHs c b) ~ MapOpRes (ToT c) (ToT b)++-- | Lifted 'MapOp'.+class ( MapOp (ToT c)+      , ToT (MapOpInpHs c) ~ MapOpInp (ToT c)+      , ToT (MapOpResHs c ()) ~ MapOpRes (ToT c) (ToT ())+      ) => MapOpHs c where+  type MapOpInpHs c :: Kind.Type+  type MapOpResHs c :: Kind.Type -> Kind.Type++instance IsComparable k => MapOpHs (Map k v) where+  type MapOpInpHs (Map k v) = (k, v)+  type MapOpResHs (Map k v) = Map k++instance MapOpHs [e] where+  type MapOpInpHs [e] = e+  type MapOpResHs [e] = []++-- | Lifted 'IterOp'.+class ( IterOp (ToT c)+      , ToT (IterOpElHs c) ~ IterOpEl (ToT c)+      ) => IterOpHs c where+  type IterOpElHs c :: Kind.Type++instance IsComparable k => IterOpHs (Map k v) where+  type IterOpElHs (Map k v) = (k, v)++instance IterOpHs [e] where+  type IterOpElHs [e] = e++instance IsComparable e => IterOpHs (Set e) where+  type IterOpElHs (Set e) = e++-- | Lifted 'SizeOp'.+--+-- This could be just a constraint alias, but to avoid 'T' types appearance in+-- error messages we make a full type class with concrete instances.+class SizeOp (ToT c) => SizeOpHs c++instance SizeOpHs MText+instance SizeOpHs ByteString+instance SizeOpHs (Set a)+instance SizeOpHs [a]+instance SizeOpHs (Map k v)++-- | Lifted 'UpdOp'.+class ( UpdOp (ToT c)+      , ToT (UpdOpKeyHs c) ~ 'Tc (UpdOpKey (ToT c))+      , ToT (UpdOpParamsHs c) ~ UpdOpParams (ToT c)+      ) => UpdOpHs c where+  type UpdOpKeyHs c :: Kind.Type+  type UpdOpParamsHs c :: Kind.Type++instance IsComparable k => UpdOpHs (Map k v) where+  type UpdOpKeyHs (Map k v) = k+  type UpdOpParamsHs (Map k v) = Maybe v++instance IsComparable k => UpdOpHs (BigMap k v) where+  type UpdOpKeyHs (BigMap k v) = k+  type UpdOpParamsHs (BigMap k v) = Maybe v++instance IsComparable a => UpdOpHs (Set a) where+  type UpdOpKeyHs (Set a) = a+  type UpdOpParamsHs (Set a) = Bool++-- | Lifted 'GetOp'.+class ( GetOp (ToT c)+      , ToT (GetOpKeyHs c) ~ 'Tc (GetOpKey (ToT c))+      , ToT (GetOpValHs c) ~ GetOpVal (ToT c)+      ) => GetOpHs c where+  type GetOpKeyHs c :: Kind.Type+  type GetOpValHs c :: Kind.Type++instance IsComparable k => GetOpHs (Map k v) where+  type GetOpKeyHs (Map k v) = k+  type GetOpValHs (Map k v) = v++instance IsComparable k => GetOpHs (BigMap k v) where+  type GetOpKeyHs (BigMap k v) = k+  type GetOpValHs (BigMap k v) = v++-- | Lifted 'ConcatOp'.+class ConcatOp (ToT c) => ConcatOpHs c++instance ConcatOpHs MText+instance ConcatOpHs ByteString++-- | Lifted 'SliceOp'.+class SliceOp (ToT c) => SliceOpHs c++instance SliceOpHs MText+instance SliceOpHs ByteString++-- | Lifted 'EDivOp'.+class ( EDivOp (ToCT n) (ToCT m)+      , IsComparable n, IsComparable m+      , ToT (EDivOpResHs n m) ~ 'Tc (EDivOpRes (ToCT n) (ToCT m))+      , ToT (EModOpResHs n m) ~ 'Tc (EModOpRes (ToCT n) (ToCT m))+      ) => EDivOpHs n m where+  type EDivOpResHs n m :: Kind.Type+  type EModOpResHs n m :: Kind.Type++instance EDivOpHs Integer Integer where+  type EDivOpResHs Integer Integer = Integer+  type EModOpResHs Integer Integer = Natural++instance EDivOpHs Integer Natural where+  type EDivOpResHs Integer Natural = Integer+  type EModOpResHs Integer Natural = Natural++instance EDivOpHs Natural Integer where+  type EDivOpResHs Natural Integer = Integer+  type EModOpResHs Natural Integer = Natural++instance EDivOpHs Natural Natural where+  type EDivOpResHs Natural Natural = Natural+  type EModOpResHs Natural Natural = Natural++instance EDivOpHs Mutez Mutez where+  type EDivOpResHs Mutez Mutez = Natural+  type EModOpResHs Mutez Mutez = Mutez++instance EDivOpHs Mutez Natural where+  type EDivOpResHs Mutez Natural = Mutez+  type EModOpResHs Mutez Natural = Mutez
+ src/Lorentz/Prelude.hs view
@@ -0,0 +1,14 @@+-- | Commonly used parts of regular Prelude.+module Lorentz.Prelude+  ( ($)+  , type ($)+  , Eq+  , Ord+  , Bounded (..)+  , Semigroup (..)+  , Monoid (..)+  , Generic+  , Text+  , fromString+  , undefined+  ) where
+ src/Lorentz/Rebinded.hs view
@@ -0,0 +1,79 @@+{- | Reimplementation of some syntax sugar.++You need the following module pragmas to make it work smoothly:++{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++-}+module Lorentz.Rebinded+  ( (>>)+  , pure+  , return+  , ifThenElse+  , Condition (..)++    -- * Re-exports required for RebindableSyntax+  , fromInteger+  , fromString+  , fromLabel+  ) where+++import Prelude hiding ((>>), (>>=))++import Lorentz.Arith+import Lorentz.Base+import Lorentz.Instr+import Lorentz.Macro+import Michelson.Typed.Arith++-- | Aliases for '(#)' used by do-blocks.+(>>) :: (a :-> b) -> (b :-> c) -> (a :-> c)+(>>) = (#)++-- | Predicate for @if ... then .. else ...@ construction,+-- defines a kind of operation applied to the top elements of the current stack.+data Condition st arg argl argr where+  Holds :: Condition s (Bool ': s) s s+  IsSome :: Condition s (Maybe a ': s) (a ': s) s+  IsNone :: Condition s (Maybe a ': s) s (a ': s)+  IsLeft :: Condition s (Either l r ': s) (l ': s) (r ': s)+  IsRight :: Condition s (Either l r ': s) (r ': s) (l ': s)+  IsCons :: Condition s ([a] ': s) (a ': [a] ': s) s+  IsNil :: Condition s ([a] ': s) s (a ': [a] ': s)++  IsZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool)+         => Condition s (a ': s) s s+  IsNotZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool)+         => Condition s (a ': s) s s++  IsEq :: IfCmpXConstraints a b Eq' => Condition s (a ': b ': s) s s+  IsNeq :: IfCmpXConstraints a b Neq => Condition s (a ': b ': s) s s+  IsLt :: IfCmpXConstraints a b Lt => Condition s (a ': b ': s) s s+  IsGt :: IfCmpXConstraints a b Gt => Condition s (a ': b ': s) s s+  IsLe :: IfCmpXConstraints a b Le => Condition s (a ': b ': s) s s+  IsGe :: IfCmpXConstraints a b Ge => Condition s (a ': b ': s) s s++-- | Defines semantics of @if ... then ... else ...@ construction.+ifThenElse+  :: Condition st arg argl argr+  -> (argl :-> o) -> (argr :-> o) -> (arg :-> o)+ifThenElse = \case+  Holds -> if_+  IsSome -> flip ifNone+  IsNone -> ifNone+  IsLeft -> ifLeft+  IsRight -> flip ifLeft+  IsCons -> ifCons+  IsNil -> flip ifCons++  IsZero -> \l r -> eq0 # if_ l r+  IsNotZero -> \l r -> eq0 # if_ r l++  IsEq -> ifEq+  IsNeq -> ifNeq+  IsLt -> ifLt+  IsGt -> ifGt+  IsLe -> ifLe+  IsGe -> ifGe
+ src/Lorentz/Referenced.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DerivingStrategies, FunctionalDependencies #-}++-- | Referenced-by-type versions of some instructions.+--+-- They allow to "dip" into stack or copy elements of stack referring them+-- by type. Their use is justified, because in most cases there is only+-- one element of each type of stack, and in cases when this does not hold+-- (e.g. entry point with multiple parameters of the same type), it might be+-- a good idea to wrap those types into a newtype or to use primitives from+-- 'named' package.+--+-- This module is experimental, i.e. everything here should work but may be+-- removed in favor of better development practices.+--+-- Each instruction is followed with usage example.+module Lorentz.Referenced+  ( dupT+  , dipT+  , dropT+  ) where++import Prelude hiding (drop, swap)++import qualified Data.Kind as Kind+import Data.Type.Bool (If)+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Lorentz.Base+import Lorentz.Instr+import Util.Type++-- Errors+----------------------------------------------------------------------------++type family StackElemNotFound st a :: ErrorMessage where+  StackElemNotFound st a =+    'Text "Element of type `" ':<>: 'ShowType a ':<>:+    'Text "` is not present on stack" ':$$: 'ShowType st++type family StackElemAmbiguous st a :: ErrorMessage where+  StackElemAmbiguous st a =+    'Text "Ambigous reference to element of type `" ':<>: 'ShowType a ':<>:+    'Text "` for stack" ':$$: 'ShowType st++-- Dup+----------------------------------------------------------------------------++-- | Allows duplicating stack elements referring them by type.+class DupT (origSt :: [Kind.Type]) (a :: Kind.Type) (st :: [Kind.Type]) where+  dupTImpl :: st :-> a : st++instance TypeError (StackElemNotFound origSt a) =>+         DupT origSt a '[] where+  dupTImpl = error "impossible"++instance {-# OVERLAPPING #-}+         If (a `IsElem` st)+            (TypeError (StackElemAmbiguous origSt a))+            (() :: Constraint) =>+         DupT origSt a (a : st) where+  dupTImpl = dup++instance {-# OVERLAPPABLE #-}+         DupT origSt a st =>+         DupT origSt a (b : st) where+  dupTImpl = dip (dupTImpl @origSt) # swap++-- | Duplicate an element of stack referring it by type.+--+-- If stack contains multiple entries of this type, compile error is raised.+dupT :: forall a st. DupT st a st => st :-> a : st+dupT = dupTImpl @st @a @st++_dupSample1 :: [Integer, Text, ()] :-> [Text, Integer, Text, ()]+_dupSample1 = dupT @Text++-- Dip+----------------------------------------------------------------------------++-- | Allows diving into stack referring expected new tip by type.+--+-- Implemented with fun deps for conciseness; we can replace them+-- with a type family anytime, but that would probably require more declarations.+class DipT (origInp :: [Kind.Type]) (a :: Kind.Type)+           (inp :: [Kind.Type]) (dipInp :: [Kind.Type])+           (dipOut :: [Kind.Type]) (out :: [Kind.Type])+           | inp a -> dipInp, dipOut inp a -> out where+  dipTImpl :: (dipInp :-> dipOut) -> (inp :-> out)++instance ( TypeError (StackElemNotFound origSt a)+         , dipInp ~ TypeError ('Text "Undefined type (see next error)")+         , out ~ TypeError ('Text "Undefined type (see next error)")+         ) =>+         DipT origSt a '[] dipInp dipOut out where+  dipTImpl = error "impossible"++instance {-# OVERLAPPING #-}+         ( If (a `IsElem` st)+            (TypeError (StackElemAmbiguous origSt a))+            (() :: Constraint)+         , dipInp ~ (a : st)+         , dipOut ~ out+         ) =>+         DipT origSt a (a : st) dipInp dipOut out where+  dipTImpl = id++instance {-# OVERLAPPABLE #-}+         ( DipT origSt a st dipInp dipOut out+         , out1 ~ (b : out)+         ) =>+         DipT origSt a (b : st) dipInp dipOut out1 where+  dipTImpl = dip . dipTImpl @origSt @a @st++-- | Dip repeatedly until element of the given type is on top of the stack.+--+-- If stack contains multiple entries of this type, compile error is raised.+dipT+  :: forall a inp dinp dout out.+     DipT inp a inp dinp dout out+  => (dinp :-> dout) -> (inp :-> out)+dipT = dipTImpl @inp @a @inp @dinp++_dipSample1+  :: [Natural, ()]+      :-> '[ByteString]+  -> [Integer, Text, Natural, ()]+      :-> [Integer, Text, ByteString]+_dipSample1 = dipT @Natural++-- Drop+----------------------------------------------------------------------------++-- | Remove element with the given type from the stack.+dropT+  :: forall a inp dinp dout out.+     ( DipT inp a inp dinp dout out+     , dinp ~ (a ': dout)+     )+  => inp :-> out+dropT = dipT @a drop++_dropSample1 :: [Integer, (), Natural] :-> [Integer, Natural]+_dropSample1 = dropT @()++-- Framing+----------------------------------------------------------------------------++{- Note that there instructions are only usable for concrete stacks.++When you know your stack only partially, and you try to refer to element of+type "X", then with the current approach compiler will require the unknown+part of stack to contain no elements of type "X", and this is annoying+at least because it ruins modularity.++For now I suggest to use these instructions only in contract code directly, and+if you need to extract a set of instructions to a reusable function polymorphic+over stack tail then it will probably be small enough to use just plain+instructions.++If this module is in demand, I hope we will find a way to resolve this issue.++-}
+ src/Lorentz/Store.hs view
@@ -0,0 +1,628 @@+{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Impementation of @Store@ - object incapsulating multiple 'BigMap's.+--+-- This module also provides template for the contract storage -+-- 'StorageSkeleton'.+--+-- We represent 'Store' as @big_map bytes (a | b | ...)@.+--+-- Key of this map is formed as @(index, orig_key)@, where @index@ is+-- zero-based index of emulated map, @orig_key@ is key of this emulated map.+--+-- Value of this map is just a union of emulated map's values.++{- Note on store inner representation (@martoon)++I see an alternative approach - representing store as+@big_map bytes (option a, option b, ...)@.++This would allow for saner implementation and more convenient interface.+An obvious shortcoming here is gas consumption. But this overhead seems+insignificant against the background of some other instructions.++-}+module Lorentz.Store+  ( -- * Store and related type definitions+    Store (..)+  , type (|->)++    -- ** Type-lookup-by-name+  , GetStoreKey+  , GetStoreValue++    -- ** Instructions+  , storeMem+  , storeGet+  , storeInsert+  , storeInsertNew+  , storeDelete++    -- ** Instruction constraints+  , StoreMemC+  , StoreGetC+  , StoreInsertC+  , StoreDeleteC+  , HasStore+  , HasStoreForAllIn++    -- * Storage skeleton+  , StorageSkeleton (..)+  , storageUnpack+  , storagePack+  , storageMem+  , storageGet+  , storageInsert+  , storageInsertNew+  , storageDelete++    -- * Store management from Haskell+  , storePiece+  , storeLookup++    -- ** Function constraints+  , StorePieceC+  ) where++import Data.Constraint (Dict(..))+import Data.Default (Default)+import qualified Data.Kind as Kind+import qualified Data.Map as Map+import Data.Singletons (SingI)+import Data.Type.Bool (If, type (||))+import Data.Type.Equality (type (==))+import Data.Vinyl.Derived (Label)+import GHC.Generics ((:+:))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, ErrorMessage(..), KnownSymbol, Symbol, TypeError)+import GHC.TypeNats (type (+))+import Type.Reflection ((:~:)(Refl))++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Instr+import Lorentz.Macro+import Michelson.Interpret.Pack+import Michelson.Typed.Haskell.Instr.Sum+import Michelson.Typed.Haskell.Value+import Michelson.Typed.Instr+import Michelson.Typed.Scope++{-# ANN module ("HLint: ignore Use 'natVal' from Universum" :: Text) #-}++----------------------------------------------------------------------------+-- Store+----------------------------------------------------------------------------++-- | Gathers multple 'BigMap's under one object.+--+-- Type argument of this datatype stands for a "map template" -+-- a datatype with multiple constructors, each containing an object of+-- type '|->' and corresponding to single virtual 'BigMap'.+-- It's also possible to parameterize it with a larger type which is+-- a sum of types satisfying the above property.+--+-- Inside it keeps only one 'BigMap' thus not violating Michelson limitations.+--+-- See examples below.+newtype Store a = Store { unStore :: BigMap ByteString a }+  deriving stock (Eq, Show)+  deriving newtype (Default, Semigroup, Monoid, IsoValue)++-- | Describes one virtual big map.+data k |-> v = BigMapImage v+  deriving stock Generic+  deriving anyclass IsoValue++{- Again we use generic magic to implement methods for 'Store'+(and thus 'Store' type constructor accepts a datatype, not a type-level list).++There are two reasons for this:++1. This gives us expected balanced tree of 'Or's for free.++2. This allows us selecting a map by constructor name, not by+e.g. type of map value. This is subjective, but looks like a good thing+for me (@martoon). On the other hand, it prevents us from sharing the+same interface between maps and 'Store'.++-}++-- | Position of a constructor in the corresponding datatype declaration.+type CtorIdx = Nat++-- | Number of datatype constructors.+type CtorsNum = Nat++-- | Type arguments of '|->'.+data MapSignature = MapSignature Kind.Type Kind.Type CtorIdx++-- Again, we will use these getters instead of binding types within+-- 'MapSignature' using type equality because getters does not produce extra+-- compile errors on "field not found" cases.+type family MSKey ms where+  MSKey ('MapSignature k _ _) = k+type family MSValue ms where+  MSValue ('MapSignature _ v _) = v+type family MSCtorIdx ms where+  MSCtorIdx ('MapSignature _ _ ci) = ci++-- | Get map signature from the constructor with a given name.+type GetStore name a = MSRequireFound name a (GLookupStore name (G.Rep a))++data MapLookupRes+  = MapFound MapSignature+  | MapAbsent CtorsNum++type family MSRequireFound+  (name :: Symbol)+  (a :: Kind.Type)+  (mlr :: MapLookupRes)+    :: MapSignature where+  MSRequireFound _ _ ('MapFound ms) = ms+  MSRequireFound name a ('MapAbsent _) = TypeError+    ('Text "Failed to find store template: datatype " ':<>: 'ShowType a ':<>:+     'Text " has no constructor " ':<>: 'ShowType name)++-- | Prepend a constructor name with a lower-case character so that you+-- could make a label with @OverloadedLabels@ extension matching+-- resulting thing.+type CtorNameToLabel name = "c" `AppendSymbol` name++type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)+              :: MapLookupRes where+  GLookupStore name (G.D1 _ x) = GLookupStore name x+  GLookupStore name (x :+: y) = LSMergeFound name (GLookupStore name x)+                                                  (GLookupStore name y)+  -- When we encounter a constructor there are two cases we are interested in:+  -- 1. This constructor has one field with type `|->`. Then we check its name+  -- and return 'MapFound' if it matches and 'MapAbsent' otherwise (storing+  -- information that we've found one constructor).+  -- 2. This constructor has one field with a different type. Then we expect+  -- this field to store '|->' somewhere deeper and try to find it there.+  GLookupStore name (G.C1 ('G.MetaCons ctorName _ _) x) =+    If (IsLeafCtor x)+      (If (name == ctorName || name == CtorNameToLabel ctorName)+         ('MapFound $ GExtractMapSignature ctorName x)+         ('MapAbsent 1)+      )+      (GLookupStoreDeeper name x)+  GLookupStore _ G.V1 = 'MapAbsent 0++-- Helper type family to check whether ADT constructor has one field+-- with type `|->`.+type family IsLeafCtor (x :: Kind.Type -> Kind.Type) :: Bool where+  IsLeafCtor (G.S1 _ (G.Rec0 (_ |-> _))) = 'True+  IsLeafCtor _ = 'False++-- Helper type family to go deeper during type-level store lookup.+type family GLookupStoreDeeper (name :: Symbol) (x :: Kind.Type -> Kind.Type)+              :: MapLookupRes where+  GLookupStoreDeeper name (G.S1 _ (G.Rec0 y))  = GLookupStore name (G.Rep y)+  GLookupStoreDeeper name _ = TypeError+    ('Text "Attempt to go deeper failed while looking for" ':<>: 'ShowType name+    ':$$:+    'Text "Make sure that all constructors have exactly one field inside.")++type family LSMergeFound (name :: Symbol)+  (f1 :: MapLookupRes) (f2 :: MapLookupRes)+  :: MapLookupRes where+  LSMergeFound _ ('MapAbsent n1) ('MapAbsent n2) = 'MapAbsent (n1 + n2)+  LSMergeFound _ ('MapFound ms) ('MapAbsent _) = 'MapFound ms+  LSMergeFound _ ('MapAbsent n) ('MapFound ('MapSignature k v i)) =+    'MapFound ('MapSignature k v (n + i))+  -- It's possible that there are two constructors with the same name,+  -- because main template pattern may be a sum of smaller template+  -- patterns with same constructor names.+  LSMergeFound ctor ('MapFound _) ('MapFound _) = TypeError+    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)++type family GExtractMapSignature (ctor :: Symbol) (x :: Kind.Type -> Kind.Type)+             :: MapSignature where+  GExtractMapSignature _ (G.S1 _ (G.Rec0 (k |-> v))) = 'MapSignature k v 0+  GExtractMapSignature ctor _ = TypeError+    ('Text "Expected exactly one field of type `k |-> v`" ':$$:+     'Text "In constructor " ':<>: 'ShowType ctor)++type GetStoreKey store name = MSKey (GetStore name store)+type GetStoreValue store name = MSValue (GetStore name store)++packKey+  :: forall (idx :: CtorIdx) t s.+     (KnownNat idx, Typeable t, SingI t, HasNoOp t, HasNoBigMap t)+  => Instr (t : s) (ToT ByteString : s)+packKey =+  PUSH (toVal . natVal $ Proxy @idx) `Seq`+  PAIR @(ToT Natural) @t `Seq`+  PACK++type StoreOpC store name =+  ( Each [Typeable, SingI, HasNoOp, HasNoBigMap] '[ToT (MSKey (GetStore name store))]+  , KnownNat (MSCtorIdx (GetStore name store))+  )++{- Note on store initialization:++It's not possible to create an empty store, because Michelson provides no way+to create a new empty @big_map@.+-}++storeMem+  :: forall store name s.+     (StoreMemC store name)+  => Label name+  -> GetStoreKey store name : Store store : s :-> Bool : s+storeMem _ = I $+  packKey @(MSCtorIdx (GetStore name store)) `Seq`+  MEM++type StoreMemC store name = StoreOpC store name++storeGet+  :: forall store name s.+     StoreGetC store name+  => Label name+  -> GetStoreKey store name : Store store : s+       :-> Maybe (GetStoreValue store name) : s+storeGet label = I $+  packKey @(MSCtorIdx (GetStore name store)) `Seq`+  GET `Seq`+  IF_NONE (NONE) (instrUnwrapUnsafe @store label `Seq` SOME)++type StoreGetC store name =+  ( StoreOpC store name+  , InstrUnwrapC store name+  , SingI (ToT (GetStoreValue store name))+  , CtorHasOnlyField name store+      (GetStoreKey store name |-> GetStoreValue store name)+  )++storeInsert+  :: forall store name s.+     StoreInsertC store name+  => Label name+  -> GetStoreKey store name+      : GetStoreValue store name+      : Store store+      : s+  :-> Store store : s+storeInsert label = I $+  packKey @(MSCtorIdx (GetStore name store)) `Seq`+  DIP (instrWrap @store label `Seq` SOME) `Seq`+  UPDATE++type StoreInsertC store name =+  ( StoreOpC store name+  , InstrWrapC store name+  , CtorHasOnlyField name store+      (GetStoreKey store name |-> GetStoreValue store name)+  )++-- | Insert a key-value pair, but fail if it will overwrite some existing entry.+storeInsertNew+  :: forall store name err s.+     (StoreInsertC store name, KnownSymbol name, KnownValue err)+  => Label name+  -> (forall s0. GetStoreKey store name : s0 :-> err : s0)+  -> GetStoreKey store name+      : GetStoreValue store name+      : Store store+      : s+  :-> Store store : s+storeInsertNew label mkErr =+  duupX @3 # duupX @2 # storeMem label #+  if_ (mkErr # failWith)+      (storeInsert label)++storeDelete+  :: forall store name s.+     ( StoreDeleteC store name+     )+  => Label name+  -> GetStoreKey store name : Store store : s+     :-> Store store : s+storeDelete _ = I $+  packKey @(MSCtorIdx (GetStore name store)) `Seq`+  DIP (NONE @(ToT store)) `Seq`+  UPDATE++type StoreDeleteC store name =+  ( StoreOpC store name+  , SingI (ToT store)+  )++-- | This constraint can be used if a function needs to work with+-- /big/ store, but needs to know only about some part(s) of it.+--+-- It can use all Store operations for a particular name, key and+-- value without knowing whole template.+type HasStore name key value store =+   ( StoreGetC store name+   , StoreInsertC store name+   , StoreDeleteC store name+   , GetStoreKey store name ~ key+   , GetStoreValue store name ~ value+   , StorePieceC store name key value+   )++-- | Write down all sensisble constraints which given @store@ satisfies+-- and apply them to @constrained@.+--+-- This store should have '|->' datatype in its immediate fields,+-- no deep inspection is performed.+type HasStoreForAllIn store constrained =+  GForAllHasStore constrained (G.Rep store)++type family GForAllHasStore (store :: Kind.Type) (x :: Kind.Type -> Kind.Type)+            :: Constraint where+  GForAllHasStore store (G.D1 _ x) = GForAllHasStore store x+  GForAllHasStore store (x :+: y) = ( GForAllHasStore store x+                                    , GForAllHasStore store y )+  GForAllHasStore store (G.C1 ('G.MetaCons ctorName _ _)+                          (G.S1 _ (G.Rec0 (key |-> value)))) =+    HasStore (CtorNameToLabel ctorName) key value store+  GForAllHasStore _ (G.C1 _ _) = ()+  GForAllHasStore _ G.V1 = ()++-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate+  = IntsStore (Integer |-> ())+  | BytesStore (ByteString |-> ByteString)+  deriving stock Generic+  deriving anyclass IsoValue++type MyStore = Store MyStoreTemplate++_sample1 :: Integer : MyStore : s :-> MyStore : s+_sample1 = storeDelete @MyStoreTemplate #cIntsStore++_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s+_sample2 = storeInsert @MyStoreTemplate #cBytesStore++data MyStoreTemplate2+  = BoolsStore (Bool |-> Bool)+  | IntsStore2 (Integer |-> Integer)+  | IntsStore3 (Integer |-> Bool)+  deriving stock Generic+  deriving anyclass IsoValue++-- You must derive 'Generic' instance for all custom types, even+-- newtypes.+newtype MyNatural = MyNatural Natural+  deriving stock Generic+  deriving newtype (IsoCValue, IsoValue)++data MyStoreTemplate3 = MyStoreTemplate3 (Natural |-> MyNatural)+  deriving stock Generic+  deriving anyclass IsoValue++data MyStoreTemplateBig+  = BigTemplatePart1 MyStoreTemplate+  | BigTemplatePart2 MyStoreTemplate2+  | BigTemplatePart3 MyStoreTemplate3+  deriving stock Generic+  deriving anyclass IsoValue++_MyStoreTemplateBigTextsStore ::+  GetStore "cBytesStore" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString 1+_MyStoreTemplateBigTextsStore = Refl++_MyStoreTemplateBigBoolsStore ::+  GetStore "cBoolsStore" MyStoreTemplateBig :~: 'MapSignature Bool Bool 2+_MyStoreTemplateBigBoolsStore = Refl++_MyStoreTemplateBigMyStoreTemplate3 ::+  GetStore "cMyStoreTemplate3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural 5+_MyStoreTemplateBigMyStoreTemplate3 = Refl++_MyStoreBigHasAllStores+  :: HasStoreForAllIn MyStoreTemplate store+  => Dict ( HasStore "cIntsStore" Integer () store+          , HasStore "cBytesStore" ByteString ByteString store+          )+_MyStoreBigHasAllStores = Dict++type MyStoreBig = Store MyStoreTemplateBig++_sample3 :: Integer : MyStoreBig : s :-> MyStoreBig : s+_sample3 = storeDelete @MyStoreTemplateBig #cIntsStore2++_sample4 :: ByteString : MyStoreBig : s :-> Bool : s+_sample4 = storeMem @MyStoreTemplateBig #cBytesStore++_sample5 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s+_sample5 = storeInsert @MyStoreTemplateBig #cMyStoreTemplate3++-- Example of 'HasStoreForAllIn' use.+-- This function will work with any @store@ which has 'MyStoreTemplate3' inside.+_sample6+  :: forall store s.+      HasStoreForAllIn MyStoreTemplate3 store+  => Natural : MyNatural : Store store : s :-> Store store : s+_sample6 = storeInsert @store #cMyStoreTemplate3++-- For instance, 'sample6' works for 'MyStoreBig'.+_sample6' :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s+_sample6' = _sample6++----------------------------------------------------------------------------+-- Storage skeleton+----------------------------------------------------------------------------++-- | Contract storage with @big_map@.+--+-- Due to Michelson constraints it is the only possible layout containing+-- @big_map@.+data StorageSkeleton storeTemplate other = StorageSkeleton+  { sMap :: Store storeTemplate+  , sFields :: other+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (Default, IsoValue)++-- | Unpack 'StorageSkeleton' into a pair.+storageUnpack :: StorageSkeleton store fields : s :-> (Store store, fields) : s+storageUnpack = coerce_++-- | Pack a pair into 'StorageSkeleton'.+storagePack :: (Store store, fields) : s :-> StorageSkeleton store fields : s+storagePack = coerce_++storageMem+  :: forall store name fields s.+     (StoreMemC store name)+  => Label name+  -> GetStoreKey store name : StorageSkeleton store fields : s :-> Bool : s+storageMem label = dip (storageUnpack # car) # storeMem label++storageGet+  :: forall store name fields s.+     StoreGetC store name+  => Label name+  -> GetStoreKey store name : StorageSkeleton store fields : s+       :-> Maybe (GetStoreValue store name) : s+storageGet label = dip (storageUnpack # car) # storeGet label++storageInsert+  :: forall store name fields s.+     StoreInsertC store name+  => Label name+  -> GetStoreKey store name+      : GetStoreValue store name+      : StorageSkeleton store fields+      : s+  :-> StorageSkeleton store fields : s+storageInsert label =+  dip (dip (storageUnpack # dup # car # dip cdr)) #+  storeInsert label #+  pair # storagePack++-- | Insert a key-value pair, but fail if it will overwrite some existing entry.+storageInsertNew+  :: forall store name fields err s.+     (StoreInsertC store name, KnownSymbol name, KnownValue err)+  => Label name+  -> (forall s0. GetStoreKey store name : s0 :-> err : s0)+  -> GetStoreKey store name+      : GetStoreValue store name+      : StorageSkeleton store fields+      : s+  :-> StorageSkeleton store fields : s+storageInsertNew label mkErr =+  dip (dip (storageUnpack # dup # car # dip cdr)) #+  storeInsertNew label mkErr #+  pair # storagePack++storageDelete+  :: forall store name fields s.+     ( StoreDeleteC store name+     )+  => Label name+  -> GetStoreKey store name : StorageSkeleton store fields : s+     :-> StorageSkeleton store fields : s+storageDelete label =+  dip (storageUnpack # dup # car # dip cdr) #+  storeDelete label #+  pair # storagePack++-- Examples+----------------------------------------------------------------------------++type MyStorage = StorageSkeleton MyStoreTemplate (Integer, ByteString)++-- You can access both Store...+_storageSample1 :: Integer : MyStorage : s :-> MyStorage : s+_storageSample1 = storageDelete @MyStoreTemplate #cIntsStore++-- and other fields of the storage created with 'StorageSkeleton'.+_storageSample2 :: MyStorage : s :-> Integer : s+_storageSample2 = toField #sFields # car++----------------------------------------------------------------------------+-- Store construction from Haskell+----------------------------------------------------------------------------++packHsKey+  :: forall ctorIdx key.+     ( IsoValue key, KnownValue key, HasNoOp (ToT key), HasNoBigMap (ToT key)+     , KnownNat ctorIdx+     )+  => key -> ByteString+packHsKey key =+  packValue' $ toVal (natVal (Proxy @ctorIdx), key)++-- | Lift a key-value pair to 'Store'.+--+-- Further you can use 'Monoid' instance of @Store@ to make up large stores.+storePiece+  :: forall name store key value.+     StorePieceC store name key value+  => Label name+  -> key+  -> value+  -> Store store+storePiece label key val =+  Store . BigMap $ one+    ( packHsKey @(MSCtorIdx (GetStore name store)) key+    , hsWrap @store label (BigMapImage val)+    )++type StorePieceC store name key value =+  ( key ~ GetStoreKey store name+  , value ~ GetStoreValue store name+  , IsoValue key, KnownValue key, HasNoOp (ToT key), HasNoBigMap (ToT key)+  , KnownNat (MSCtorIdx (GetStore name store))+  , InstrWrapC store name, Generic store+  , ExtractCtorField (GetCtorField store name) ~ (key |-> value)+  )++-- | Get a value from store by key.+--+-- It expects map to be consistent, otherwise call to this function fails+-- with error.+storeLookup+  :: forall name store key value ctorIdx.+     ( key ~ GetStoreKey store name+     , value ~ GetStoreValue store name+     , ctorIdx ~ MSCtorIdx (GetStore name store)+     , IsoValue key, KnownValue key, HasNoOp (ToT key), HasNoBigMap (ToT key)+     , KnownNat ctorIdx+     , InstrUnwrapC store name, Generic store+     , CtorOnlyField name store ~ (key |-> value)+     )+  => Label name+  -> key+  -> Store store+  -> Maybe value+storeLookup label key (Store (BigMap m)) =+  Map.lookup (packHsKey @ctorIdx key) m <&> \val ->+    case hsUnwrap label val of+      Nothing -> error "Invalid store, keys and values types \+                       \correspondence is violated"+      Just (BigMapImage x) -> x++-- Examples+----------------------------------------------------------------------------++_storeSample :: Store MyStoreTemplate+_storeSample = mconcat+  [ storePiece #cIntsStore 1 ()+  , storePiece #cBytesStore "a" "b"+  ]++_lookupSample :: Maybe ByteString+_lookupSample = storeLookup #cBytesStore "a" _storeSample++_storeSampleBig :: Store MyStoreTemplateBig+_storeSampleBig = mconcat+  [ storePiece #cIntsStore 1 ()+  , storePiece #cBoolsStore True True+  , storePiece #cIntsStore3 2 False+  ]++_lookupSampleBig :: Maybe Bool+_lookupSampleBig = storeLookup #cIntsStore3 2 _storeSampleBig
+ src/Lorentz/Test.hs view
@@ -0,0 +1,78 @@+module Lorentz.Test+  ( -- * Importing a contract+    specWithContract+  , specWithTypedContract+  , specWithUntypedContract++  -- * Unit testing+  , ContractReturn+  , ContractPropValidator+  , contractProp+  , contractPropVal+  , contractRepeatedProp+  , contractRepeatedPropVal++  -- * Integrational testing+  -- ** Testing engine+  , IntegrationalValidator+  , SuccessValidator+  , IntegrationalScenario+  , IntegrationalScenarioM+  , ValidationError (..)+  , integrationalTestExpectation+  , integrationalTestProperty+  , lOriginate+  , lOriginateEmpty+  , lTransfer+  , lCall+  , validate+  , setMaxSteps+  , setNow+  , withSender++  -- ** Validators+  , composeValidators+  , composeValidatorsList+  , expectAnySuccess+  , lExpectStorageUpdate+  , lExpectBalance+  , lExpectStorageConst+  , lExpectMichelsonFailed+  , lExpectFailWith+  , lExpectUserError+  , lExpectConsumerStorage+  , lExpectViewConsumerStorage++  -- ** Various+  , TxData (..)+  , genesisAddresses+  , genesisAddress+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6++  -- * General utilities+  , failedProp+  , succeededProp+  , qcIsLeft+  , qcIsRight++  -- * Dummy values+  , dummyContractEnv++  -- * Arbitrary data+  , minTimestamp+  , maxTimestamp+  , midTimestamp+  ) where++import Michelson.Test.Dummy+import Michelson.Test.Gen+import Michelson.Test.Import+import Michelson.Test.Unit+import Michelson.Test.Util++import Lorentz.Test.Integrational as Exports
+ src/Lorentz/Test/Integrational.hs view
@@ -0,0 +1,230 @@+-- | Mirrors 'Michelson.Test.Integrational' module in a Lorentz way.+module Lorentz.Test.Integrational+  (+    -- * Re-exports+    TxData (..)+  , genesisAddresses+  , genesisAddress+  -- * More genesis addresses which can be used in tests+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6++    -- * Testing engine+  , I.IntegrationalValidator+  , SuccessValidator+  , IntegrationalScenarioM+  , I.IntegrationalScenario+  , I.ValidationError (..)+  , I.integrationalTestExpectation+  , I.integrationalTestProperty+  , lOriginate+  , lOriginateEmpty+  , lTransfer+  , lCall+  , I.validate+  , I.setMaxSteps+  , I.setNow+  , I.withSender++  -- * Validators+  , I.composeValidators+  , I.composeValidatorsList+  , I.expectAnySuccess+  , lExpectStorageUpdate+  , lExpectBalance+  , lExpectStorageConst+  , lExpectMichelsonFailed+  , lExpectFailWith+  , lExpectUserError+  , lExpectConsumerStorage+  , lExpectViewConsumerStorage+  ) where++import Data.Default (Default(..))+import Data.Singletons (SingI(..))+import Data.Typeable (gcast)+import Fmt (Buildable, listF, (+|), (|+))+import Named ((:!), arg)++import qualified Lorentz as L+import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..))+import Michelson.Runtime+import Michelson.Runtime.GState+import Michelson.Test.Integrational (IntegrationalScenarioM, SuccessValidator)+import qualified Michelson.Test.Integrational as I+import Michelson.TypeCheck (typeVerifyValue)+import qualified Michelson.Typed as T+import Tezos.Address+import Tezos.Core+import Util.Named ((.!))++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- TODO: how to call they normally? :thinking:+-- Preserving just the same names like @transfer@ or @originate@+-- looks very bad because no one will import this or+-- 'Michelson.Test.Integrational' module qualified+-- and thus finding which exact function is used would become too painful.++-- | Like 'originate', but for typed contract and value.+tOriginate+  :: (SingI cp, SingI st, T.HasNoOp st)+  => T.Contract cp st -> Text -> T.Value st -> Mutez -> IntegrationalScenarioM Address+tOriginate contract name value balance =+  I.originate (T.convertContract contract) name (T.untypeValue value) balance++-- | Like 'originate', but for Lorentz contracts.+lOriginate+  :: ( SingI (T.ToT cp), SingI (T.ToT st), T.HasNoOp (T.ToT st)+     , T.IsoValue st+     )+  => L.Contract cp st+  -> Text+  -> st+  -> Mutez+  -> IntegrationalScenarioM (T.ContractAddr cp)+lOriginate contract name value balance =+  T.ContractAddr <$>+  tOriginate (L.compileLorentz contract) name (T.toVal value) balance++-- | Originate a contract with empty balance and default storage.+lOriginateEmpty+  :: ( SingI (T.ToT cp), SingI (T.ToT st), T.HasNoOp (T.ToT st)+     , T.IsoValue st, Default st+     )+  => L.Contract cp st+  -> Text+  -> IntegrationalScenarioM (T.ContractAddr cp)+lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)++-- | Similar to 'transfer', for typed values.+tTransfer+  :: (SingI cp, T.HasNoOp cp)+  => "from" :! Address+  -> "to" :! Address+  -> Mutez+  -> T.Value cp+  -> IntegrationalScenarioM ()+tTransfer (arg #from -> from) (arg #to -> to) money param =+  let txData = TxData+        { tdSenderAddress = from+        , tdParameter = T.untypeValue param+        , tdAmount = money+        }+  in I.transfer txData to++-- | Similar to 'transfer', for Lorentz values.+lTransfer+  :: (SingI (T.ToT cp), T.HasNoOp (T.ToT cp), T.IsoValue cp)+  => "from" :! Address+  -> "to" :! T.ContractAddr cp+  -> Mutez+  -> cp+  -> IntegrationalScenarioM ()+lTransfer from (arg #to -> T.ContractAddr to) money param =+  tTransfer from (#to .! to) money (T.toVal param)++-- | Call a contract without caring about source address and money.+lCall+  :: (SingI (T.ToT cp), T.HasNoOp (T.ToT cp), T.IsoValue cp)+  => T.ContractAddr cp -> cp -> IntegrationalScenarioM ()+lCall contract param =+  lTransfer (#from .! genesisAddress) (#to .! contract)+    (unsafeMkMutez 1000) param++----------------------------------------------------------------------------+-- Validators to be used within 'IntegrationalValidator'+----------------------------------------------------------------------------++-- | Similar to 'expectStorageUpdate', for Lorentz values.+lExpectStorageUpdate+  :: ( T.IsoValue st, Each [Typeable, SingI, T.HasNoOp] '[T.ToT st]+     , HasCallStack+     )+  => T.ContractAddr cp -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectStorageUpdate (T.ContractAddr addr) predicate =+  I.expectStorageUpdate addr $ \got -> do+    val <- first I.UnexpectedTypeCheckError $ typeCheck got+    predicate $ T.fromVal val+  where+    typeCheck uval =+      evaluatingState initSt . runExceptT $+      usingReaderT def $+      typeVerifyValue uval+    initSt = error "Typechecker state unavailable"++-- | Like 'expectBalance', for Lorentz values.+lExpectBalance :: T.ContractAddr cp -> Mutez -> SuccessValidator+lExpectBalance (T.ContractAddr addr) money = I.expectBalance addr money++-- | Similar to 'expectStorageConst', for Lorentz values.+lExpectStorageConst+  :: (T.IsoValue st, Each '[SingI, T.HasNoOp] '[T.ToT st])+  => T.ContractAddr cp -> st -> SuccessValidator+lExpectStorageConst (T.ContractAddr addr) expected =+  I.expectStorageConst addr (T.untypeValue $ T.toVal expected)++-- | Expect that interpretation of contract with given address ended+-- with [FAILED].+lExpectMichelsonFailed+  :: (MichelsonFailed -> Bool) -> T.ContractAddr cp -> InterpreterError -> Bool+lExpectMichelsonFailed predicate (T.ContractAddr addr) =+  I.expectMichelsonFailed predicate addr++-- | Expect contract to fail with "FAILWITH" instruction and provided value+-- to match against the given predicate.+lExpectFailWith+  :: forall e.+      (Typeable (T.ToT e), T.IsoValue e)+  => (e -> Bool) -> InterpreterError -> Bool+lExpectFailWith predicate =+  \case+    IEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->+        case gcast err of+          Just errT -> predicate $ T.fromVal @e errT+          Nothing -> False+    _ -> False++-- | Expect contract to fail with given 'LorentzUserError' error.+lExpectUserError+  :: forall e.+      (Typeable (T.ToT e), T.IsoValue e)+  => (e -> Bool) -> InterpreterError -> Bool+lExpectUserError predicate = lExpectFailWith (predicate . L.unLorentzUserError)++-- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract+-- (see 'Lorentz.Contracts.Consumer.contractConsumer').+lExpectConsumerStorage+  :: (st ~ [cp], T.IsoValue st, Each [Typeable, SingI, T.HasNoOp] '[T.ToT st])+  => T.ContractAddr cp -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectConsumerStorage = lExpectStorageUpdate++-- | Assuming that "consumer" contract receives a value from 'View', expect+-- this view return value to be the given one.+--+-- Despite consumer stores parameters it was called with in reversed order,+-- this function cares about it, so you should provide a list of expected values+-- in the same order in which the corresponding events were happenning.+lExpectViewConsumerStorage+  :: ( st ~ [cp], cp ~ (arg, Maybe res)+     , Eq res, Buildable res+     , T.IsoValue st, Each [Typeable, SingI, T.HasNoOp] '[T.ToT st]+     )+  => T.ContractAddr cp -> [res] -> SuccessValidator+lExpectViewConsumerStorage addr expected =+  lExpectConsumerStorage addr (extractJusts >=> matchExpected . reverse)+  where+    extractJusts = mapM $ \case+      (_, Just got) -> pure got+      (_, Nothing) -> mkError "Consumer got empty value unexpectedly"+    mkError = Left . I.CustomError+    matchExpected got+      | got == expected = pass+      | otherwise = mkError $ "Expected " +| listF expected |++                              ", but got " +| listF got |+ ""
+ src/Lorentz/Value.hs view
@@ -0,0 +1,42 @@+-- | Re-exports typed Value, CValue, some core types, some helpers and+-- defines aliases for constructors of typed values.++module Lorentz.Value+  ( Value+  , IsoValue (..)+  , IsoCValue (..)+  , CValue (..)+  , Integer+  , Natural+  , MText+  , Bool (..)+  , ByteString+  , Address+  , Mutez+  , Timestamp+  , KeyHash+  , PublicKey+  , Signature+  , Set+  , Map+  , M.BigMap (..)+  , M.Operation+  , Maybe (..)+  , List+  , M.ContractAddr (..)+  , toMutez+  , mt+  , Default (..)+  ) where++import Data.Default (Default(..))++import Michelson.Text+import Michelson.Typed (IsoCValue(..), IsoValue(..), Value)+import qualified Michelson.Typed as M+import Michelson.Typed.CValue (CValue(..))+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp, toMutez)+import Tezos.Crypto (KeyHash, PublicKey, Signature)++type List = []
+ src/Michelson/ErrorPos.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Michelson.ErrorPos+  ( mkPos+  , Pos (..)+  , SrcPos (..)+  , srcPos+  , InstrCallStack (..)+  , LetCallStack+  , LetName (..)+  ) where++import Data.Data (Data(..))+import qualified Data.Text as T+import Data.Default (Default (..))+import qualified Data.Aeson as Aeson++newtype Pos = Pos Word+  deriving (Eq, Ord, Show, Generic, Data)++mkPos :: Int -> Pos+mkPos x+  | x < 0     = error $ "negative pos: " <> show x+  | otherwise = Pos $ fromIntegral x++data SrcPos = SrcPos Pos Pos+  deriving (Eq, Ord, Show, Generic, Data)++srcPos :: Word -> Word -> SrcPos+srcPos x y = SrcPos (Pos x) (Pos y)++newtype LetName = LetName T.Text+  deriving (Eq, Ord, Show, Data, Generic)++type LetCallStack = [LetName]+data InstrCallStack = InstrCallStack+  { icsCallStack :: LetCallStack+  , icsSrcPos    :: SrcPos+  } deriving (Eq, Ord, Show, Generic, Data)++instance Default Pos where+  def = Pos 0++instance Default SrcPos where+  def = SrcPos def def++instance Default InstrCallStack where+  def = InstrCallStack def def++instance Aeson.ToJSON  Pos+instance Aeson.FromJSON Pos+instance Aeson.ToJSON SrcPos+instance Aeson.FromJSON SrcPos+instance Aeson.ToJSON LetName+instance Aeson.FromJSON LetName+instance Aeson.ToJSON InstrCallStack+instance Aeson.FromJSON InstrCallStack
src/Michelson/Interpret.hs view
@@ -4,14 +4,16 @@ -- instructions against given context and input stack. module Michelson.Interpret   ( ContractEnv (..)-  , InterpreterEnv (..)   , InterpreterState (..)   , MichelsonFailed (..)   , RemainingSteps (..)   , SomeItStack (..)   , EvalOp+  , MorleyLogs (..)+  , noMorleyLogs    , interpret+  , interpretRepeated   , ContractReturn    , interpretUntyped@@ -19,31 +21,36 @@   , InterpretUntypedResult (..)   , runInstr   , runInstrNoGas+  , runUnpack   ) where  import Prelude hiding (EQ, GT, LT)  import Control.Monad.Except (throwError)-import qualified Data.Aeson as Aeson import qualified Data.Map as Map+import Data.Default (Default (..)) import qualified Data.Set as Set import Data.Singletons (SingI(..)) import Data.Typeable ((:~:)(..)) import Data.Vinyl (Rec(..), (<+>)) import Fmt (Buildable(build), Builder, genericF)+import Michelson.EqParam (eqParam1, eqParam2) +import Michelson.Interpret.Pack (packValue')+import Michelson.Interpret.Unpack (UnpackError, unpackValue', UnpackEnv (..)) import Michelson.TypeCheck-  (ExtC, SomeContract(..), SomeVal(..), TCError, TcExtHandler, eqT', runTypeCheckT,-  typeCheckContract, typeCheckVal)+  ( SomeContract(..), SomeValue(..), TCError, TcOriginatedContracts,+  TCTypeError(..), compareTypes, eqType, runTypeCheck, typeCheckContract, typeCheckValue) import Michelson.Typed-  (CVal(..), Contract, ConversibleExt, CreateAccount(..), CreateContract(..), Instr(..),-  Operation(..), SetDelegate(..), Sing(..), T(..), TransferTokens(..), Val(..), fromUType,-  valToOpOrValue)+  (CValue(..), Contract, CreateAccount(..), CreateContract(..), HasNoBigMap, HasNoOp, Instr(..),+  OpPresence(..), Operation'(..), Operation, SetDelegate(..), Sing(..), T(..), TransferTokens(..), Value'(..),+  extractNotes, fromUType, withSomeSingT) import qualified Michelson.Typed as T import Michelson.Typed.Arith-import Michelson.Typed.Convert (convertContract, unsafeValToValue)+import Michelson.Typed.Convert (convertContract, untypeValue) import Michelson.Typed.Polymorphic import qualified Michelson.Untyped as U+import Util.Peano (Peano, LongerThan, Sing(SS, SZ)) import Tezos.Address (Address(..)) import Tezos.Core (Mutez, Timestamp(..)) import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512)@@ -56,7 +63,7 @@   -- ^ Number of steps after which execution unconditionally terminates.   , ceBalance :: !Mutez   -- ^ Current amount of mutez of the current contract.-  , ceContracts :: Map Address U.UntypedContract+  , ceContracts :: TcOriginatedContracts   -- ^ Mapping from existing contracts' addresses to their executable   -- representation.   , ceSelf :: !Address@@ -72,87 +79,108 @@ -- | Represents `[FAILED]` state of a Michelson program. Contains -- value that was on top of the stack when `FAILWITH` was called. data MichelsonFailed where-  MichelsonFailedWith :: Val Instr t -> MichelsonFailed-  MichelsonArithError :: ArithError (CVal n) (CVal m) -> MichelsonFailed+  MichelsonFailedWith :: (Typeable t, SingI t) => T.Value t -> MichelsonFailed+  MichelsonArithError :: (Typeable n, Typeable m) => ArithError (CValue n) (CValue m) -> MichelsonFailed   MichelsonGasExhaustion :: MichelsonFailed-  MichelsonFailedOther :: Text -> MichelsonFailed+  MichelsonFailedTestAssert :: Text -> MichelsonFailed  deriving instance Show MichelsonFailed -instance (ConversibleExt) => Buildable MichelsonFailed where+instance Eq MichelsonFailed where+  MichelsonFailedWith v1 == MichelsonFailedWith v2 = v1 `eqParam1` v2+  MichelsonFailedWith _ == _ = False+  MichelsonArithError ae1 == MichelsonArithError ae2 = ae1 `eqParam2` ae2+  MichelsonArithError _ == _ = False+  MichelsonGasExhaustion == MichelsonGasExhaustion = True+  MichelsonGasExhaustion == _ = False+  MichelsonFailedTestAssert t1 == MichelsonFailedTestAssert t2 = t1 == t2+  MichelsonFailedTestAssert _ == _ = False++instance Buildable MichelsonFailed where   build =     \case-      MichelsonFailedWith (v :: Val Instr t) ->+      MichelsonFailedWith (v :: T.Value t) ->         "Reached FAILWITH instruction with " <> formatValue v       MichelsonArithError v -> build v       MichelsonGasExhaustion ->         "Gas limit exceeded on contract execution"-      MichelsonFailedOther t -> build t+      MichelsonFailedTestAssert t -> build t     where-      formatValue :: forall t . Val Instr t -> Builder+      formatValue :: forall t . SingI t => Value' Instr t -> Builder       formatValue v =-        case valToOpOrValue v of-          Nothing -> "<value with operations>"-          Just untypedV -> build untypedV+        case T.checkOpPresence (sing @t) of+          OpPresent -> "<value with operations>"+          OpAbsent -> build (untypeValue v) -data InterpretUntypedError s-  = RuntimeFailure (MichelsonFailed, s)+data InterpretUntypedError+  = RuntimeFailure (MichelsonFailed, MorleyLogs)   | IllTypedContract TCError   | IllTypedParam TCError   | IllTypedStorage TCError-  | UnexpectedParamType Text-  | UnexpectedStorageType Text+  | UnexpectedParamType TCTypeError+  | UnexpectedStorageType TCTypeError   deriving (Generic) -deriving instance (Buildable U.ExpandedInstr, Show s) => Show (InterpretUntypedError s)+deriving instance Show InterpretUntypedError -instance (ConversibleExt, Buildable s) => Buildable (InterpretUntypedError s) where+instance Buildable InterpretUntypedError where   build = genericF -data InterpretUntypedResult s where+data InterpretUntypedResult where   InterpretUntypedResult     :: ( Typeable st        , SingI st+       , HasNoOp st        )-    => { iurOps :: [ Operation Instr ]-       , iurNewStorage :: Val Instr st-       , iurNewState   :: InterpreterState s+    => { iurOps :: [Operation]+       , iurNewStorage :: T.Value st+       , iurNewState   :: InterpreterState        }-    -> InterpretUntypedResult s+    -> InterpretUntypedResult -deriving instance Show s => Show (InterpretUntypedResult s)+deriving instance Show InterpretUntypedResult +-- | Morley interpreter state+newtype MorleyLogs = MorleyLogs+  { unMorleyLogs :: [Text]+  } deriving stock (Eq, Show)+    deriving newtype (Default, Buildable)++noMorleyLogs :: MorleyLogs+noMorleyLogs = MorleyLogs []+ -- | Interpret a contract without performing any side effects. interpretUntyped-  :: forall s . (ExtC, Aeson.ToJSON U.ExpandedInstrExtU)-  => TcExtHandler-  -> U.UntypedContract-  -> U.UntypedValue-  -> U.UntypedValue-  -> InterpreterEnv s-  -> s-  -> Either (InterpretUntypedError s) (InterpretUntypedResult s)-interpretUntyped typeCheckHandler U.Contract{..} paramU initStU env initState = do-    (SomeContract (instr :: Contract cp st) _ _)-       <- first IllTypedContract $ typeCheckContract typeCheckHandler-              (U.Contract para stor code)-    paramV :::: ((_ :: Sing cp1), _)-       <- first IllTypedParam $ runTypeCheckT typeCheckHandler para $-            typeCheckVal paramU (fromUType para)-    initStV :::: ((_ :: Sing st1), _)-       <- first IllTypedStorage $ runTypeCheckT typeCheckHandler para $-            typeCheckVal initStU (fromUType stor)-    Refl <- first UnexpectedStorageType $ eqT' @st @st1-    Refl <- first UnexpectedParamType   $ eqT' @cp @cp1-    bimap RuntimeFailure constructIUR $-      toRes $ interpret instr paramV initStV env initState+  :: U.Contract+  -> U.Value+  -> U.Value+  -> ContractEnv+  -> Either InterpretUntypedError InterpretUntypedResult+interpretUntyped U.Contract{..} paramU initStU env = do+  (SomeContract (instr :: Contract cp st) _ _)+      <- first IllTypedContract $ typeCheckContract (ceContracts env)+            (U.Contract para stor code)+  withSomeSingT (fromUType para) $ \sgp ->+    withSomeSingT (fromUType stor) $ \sgs -> do+      ntp <- first (UnexpectedParamType . ExtractionTypeMismatch) $ extractNotes para sgp+      nts <- first (UnexpectedStorageType . ExtractionTypeMismatch) $ extractNotes stor sgs+      paramV :::: ((_ :: Sing cp1), _)+          <- first IllTypedParam $ runTypeCheck para (ceContracts env) $ usingReaderT def $+               typeCheckValue paramU (sgp, ntp)+      initStV :::: ((_ :: Sing st1), _)+          <- first IllTypedStorage $ runTypeCheck para (ceContracts env) $ usingReaderT def $+               typeCheckValue initStU (sgs, nts)+      Refl <- first UnexpectedStorageType $ eqType @st @st1+      Refl <- first UnexpectedParamType   $ eqType @cp @cp1+      bimap RuntimeFailure constructIUR $+        toRes $ interpret instr paramV initStV env   where-    toRes (ei, s) = bimap (,isExtState s) (,s) ei+    toRes (ei, s) = bimap (,isMorleyLogs s) (,s) ei      constructIUR ::-      (Typeable st, SingI st) =>-      (([Operation Instr], Val Instr st), InterpreterState s) ->-      InterpretUntypedResult s+      (Typeable st, SingI st, HasNoOp st) =>+      (([Operation], Value' Instr st), InterpreterState) ->+      InterpretUntypedResult     constructIUR ((ops, val), st) =       InterpretUntypedResult       { iurOps = ops@@ -160,65 +188,87 @@       , iurNewState = st       } -type ContractReturn s st =-  (Either MichelsonFailed ([Operation Instr], Val Instr st), InterpreterState s)+type ContractReturn st =+  (Either MichelsonFailed ([Operation], T.Value st), InterpreterState) -interpret-  :: (ExtC, Aeson.ToJSON U.ExpandedInstrExtU, Typeable cp, Typeable st)-  => Contract cp st-  -> Val Instr cp-  -> Val Instr st-  -> InterpreterEnv s-  -> s-  -> ContractReturn s st-interpret instr param initSt env@InterpreterEnv{..} initState = first (fmap toRes) $+interpret'+  :: Contract cp st+  -> T.Value cp+  -> T.Value st+  -> ContractEnv+  -> InterpreterState+  -> ContractReturn st+interpret' instr param initSt env ist = first (fmap toRes) $   runEvalOp-    (runInstr instr (VPair (param, initSt) :& RNil))+    (runInstr instr (T.VPair (param, initSt) :& RNil))     env-    (InterpreterState initState $ ceMaxSteps ieContractEnv)+    ist   where     toRes-      :: (Rec (Val instr) '[ 'TPair ('TList 'TOperation) st ])-      -> ([Operation instr], Val instr st)-    toRes (VPair (VList ops_, newSt) :& RNil) =-      (map (\(VOp op) -> op) ops_, newSt)+      :: (Rec (T.Value' instr) '[ 'TPair ('TList 'TOperation) st ])+      -> ([T.Operation' instr], T.Value' instr st)+    toRes (T.VPair (T.VList ops_, newSt) :& RNil) =+      (map (\(T.VOp op) -> op) ops_, newSt) -data SomeItStack where-  SomeItStack :: Typeable inp => Rec (Val Instr) inp -> SomeItStack+interpret+  :: Contract cp st+  -> T.Value cp+  -> T.Value st+  -> ContractEnv+  -> ContractReturn st+interpret instr param initSt env =+  interpret' instr param initSt env (InterpreterState def $ ceMaxSteps env) -data InterpreterEnv s = InterpreterEnv-  { ieContractEnv :: ContractEnv-  , ieItHandler   :: (T.InstrExtT, SomeItStack) -> EvalOp s ()-  }+-- | Emulate multiple calls of a contract.+interpretRepeated+  :: Contract cp st+  -> [T.Value cp]+  -> T.Value st+  -> ContractEnv+  -> ContractReturn st+interpretRepeated instr params initSt env =+  foldl interpretDo+    (Right ([], initSt), (InterpreterState def $ ceMaxSteps env))+    params+  where+    interpretDo (!res, !ist) param =+      case res of+        Right (ops, st) ->+          let (res2, ist2) = interpret' instr param st env ist+          in (res2 <&> \(ops2, st2) -> (ops ++ ops2, st2), ist2)+        Left err ->+          (Left err, ist) +data SomeItStack where+  SomeItStack :: T.ExtInstr inp -> Rec T.Value inp -> SomeItStack+ newtype RemainingSteps = RemainingSteps Word64   deriving stock (Show)   deriving newtype (Eq, Ord, Buildable, Num) -data InterpreterState s = InterpreterState-  { isExtState       :: s+data InterpreterState = InterpreterState+  { isMorleyLogs     :: MorleyLogs   , isRemainingSteps :: RemainingSteps   } deriving (Show) -type EvalOp s a =+type EvalOp a =   ExceptT MichelsonFailed-    (ReaderT (InterpreterEnv s)-       (State (InterpreterState s))) a+    (ReaderT ContractEnv+       (State InterpreterState)) a  runEvalOp ::-     EvalOp s a-  -> InterpreterEnv s-  -> InterpreterState s-  -> (Either MichelsonFailed a, InterpreterState s)+     EvalOp a+  -> ContractEnv+  -> InterpreterState+  -> (Either MichelsonFailed a, InterpreterState) runEvalOp act env initSt =   flip runState initSt $ usingReaderT env $ runExceptT act  -- | Function to change amount of remaining steps stored in State monad runInstr-  :: (ExtC, Aeson.ToJSON U.ExpandedInstrExtU, Typeable inp)-  => Instr inp out-  -> Rec (Val Instr) inp-  -> EvalOp state (Rec (Val Instr) out)+  :: Instr inp out+  -> Rec (T.Value) inp+  -> EvalOp (Rec (T.Value) out) runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r runInstr i@Nop r = runInstrImpl runInstr i r runInstr i@(Nested _) r = runInstrImpl runInstr i r@@ -231,30 +281,24 @@     runInstrImpl runInstr i r  runInstrNoGas-  :: forall a b state .-  (ExtC, Aeson.ToJSON U.ExpandedInstrExtU, Typeable a)-  => T.Instr a b -> Rec (Val T.Instr) a -> EvalOp state (Rec (Val T.Instr) b)+  :: forall a b . T.Instr a b -> Rec T.Value a -> EvalOp (Rec T.Value b) runInstrNoGas = runInstrImpl runInstrNoGas  -- | Function to interpret Michelson instruction(s) against given stack. runInstrImpl-    :: forall state .-    (ExtC, Aeson.ToJSON U.ExpandedInstrExtU)-    => (forall inp1 out1 . Typeable inp1 =>-      Instr inp1 out1-    -> Rec (Val Instr) inp1-    -> EvalOp state (Rec (Val Instr) out1)-    )-    -> (forall inp out . Typeable inp =>-      Instr inp out-    -> Rec (Val Instr) inp-    -> EvalOp state (Rec (Val Instr) out)-    )+    :: (forall inp1 out1 .+           Instr inp1 out1+        -> Rec (T.Value) inp1+        -> EvalOp (Rec T.Value out1)+    ) ->+       (forall inp out .+           Instr inp out+        -> Rec (T.Value) inp+        -> EvalOp (Rec T.Value out)+      ) runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r' runInstrImpl _ Nop r = pure $ r-runInstrImpl _ (Ext nop) r = do-  handler <- asks ieItHandler-  r <$ handler (nop, SomeItStack r)+runInstrImpl _ (Ext nop) r = r <$ interpretExt (SomeItStack nop r) runInstrImpl runner (Nested sq) r = runInstrImpl runner sq r runInstrImpl _ DROP (_ :& r) = pure $ r runInstrImpl _ DUP (a :& r) = pure $ a :& a :& r@@ -272,8 +316,6 @@ runInstrImpl _ RIGHT (b :& r) = pure $ (VOr $ Right b) :& r runInstrImpl runner (IF_LEFT bLeft _) (VOr (Left a) :& r) = runner bLeft (a :& r) runInstrImpl runner (IF_LEFT _ bRight) (VOr (Right a) :& r) = runner bRight (a :& r)-runInstrImpl runner (IF_RIGHT bRight _) (VOr (Right a) :& r) = runner bRight (a :& r)-runInstrImpl runner (IF_RIGHT _ bLeft) (VOr (Left a) :& r) = runner bLeft (a :& r) -- More here runInstrImpl _ NIL r = pure $ VList [] :& r runInstrImpl _ CONS (a :& VList l :& r) = pure $ VList (a : l) :& r@@ -285,11 +327,11 @@ runInstrImpl runner (MAP ops) (a :& r) =   case ops of     (code :: Instr (MapOpInp c ': s) (b ': s)) -> do-      newList <- mapM (\(val :: Val Instr (MapOpInp c)) -> do+      newList <- mapM (\(val :: T.Value (MapOpInp c)) -> do         res <- runner code (val :& r)         case res of-          ((newVal :: Val Instr b) :& _) -> pure newVal)-        $ mapOpToList @c @b a+          ((newVal :: T.Value b) :& _) -> pure newVal)+        $ mapOpToList @c a       pure $ mapOpFromList a newList :& r runInstrImpl runner (ITER ops) (a :& r) =   case ops of@@ -322,9 +364,10 @@ runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith a runInstrImpl _ CAST (a :& r) = pure $ a :& r runInstrImpl _ RENAME (a :& r) = pure $ a :& r--- TODO-runInstrImpl _ PACK (_ :& _) = error "PACK not implemented yet"-runInstrImpl _ UNPACK (_ :& _) = error "UNPACK not implemented yet"+runInstrImpl _ PACK (a :& r) = pure $ (VC $ CvBytes $ packValue' a) :& r+runInstrImpl _ UNPACK (VC (CvBytes a) :& r) = do+  env <- asks ceContracts+  pure $ (VOption . rightToMaybe $ runUnpack env a) :& r runInstrImpl _ CONCAT (a :& b :& r) = pure $ evalConcat a b :& r runInstrImpl _ CONCAT' (VList a :& r) = pure $ evalConcat' a :& r runInstrImpl _ SLICE (VC (CvNat o) :& VC (CvNat l) :& s :& r) =@@ -347,21 +390,26 @@ runInstrImpl _ XOR (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r runInstrImpl _ NOT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Not) a) :& rest runInstrImpl _ COMPARE (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Compare) l r-runInstrImpl _ T.EQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Eq') a) :& rest+runInstrImpl _ EQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Eq') a) :& rest runInstrImpl _ NEQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Neq) a) :& rest-runInstrImpl _ T.LT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Lt) a) :& rest-runInstrImpl _ T.GT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Gt) a) :& rest+runInstrImpl _ LT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Lt) a) :& rest+runInstrImpl _ GT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Gt) a) :& rest runInstrImpl _ LE (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Le) a) :& rest runInstrImpl _ GE (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Ge) a) :& rest runInstrImpl _ INT (VC (CvNat n) :& r) = pure $ VC (CvInt $ toInteger n) :& r runInstrImpl _ SELF r = do-  ContractEnv{..} <- asks ieContractEnv+  ContractEnv{..} <- ask   pure $ VContract ceSelf :& r-runInstrImpl _ CONTRACT (VC (CvAddress addr) :& r) = do-  ContractEnv{..} <- asks ieContractEnv-  if Map.member addr ceContracts-  then pure $ VOption (Just $ VContract addr) :& r-  else pure $ VOption Nothing :& r+runInstrImpl _ (CONTRACT (nt :: T.Notes p)) (VC (CvAddress addr) :& r) = do+  ContractEnv{..} <- ask+  case Map.lookup addr ceContracts of+    Just tc -> do+      pure $+        either (const $ VOption Nothing)+               (const $ VOption (Just $ VContract addr))+               (compareTypes (sing @p, nt) tc)+        :& r+    Nothing -> pure $ VOption Nothing :& r runInstrImpl _ TRANSFER_TOKENS (p :& VC (CvMutez mutez) :& contract :& r) =   pure $ VOp (OpTransferTokens $ TransferTokens p mutez contract) :& r runInstrImpl _ SET_DELEGATE (VOption mbKeyHash :& r) =@@ -373,14 +421,7 @@     (VC (CvBool spendable)) :& (VC (CvMutez m)) :& r) =   pure (VOp (OpCreateAccount $ CreateAccount k (unwrapMbKeyHash mbKeyHash) spendable m)     :& (VC . CvAddress) (KeyAddress k) :& r)-runInstrImpl _ CREATE_CONTRACT-  (VC (CvKeyHash k) :& VOption mbKeyHash :& (VC (CvBool spendable)) :&-    (VC (CvBool delegetable)) :& (VC (CvMutez m)) :& VLam ops :& g :& r) =-  pure (VOp (OpCreateContract $-    CreateContract k (unwrapMbKeyHash mbKeyHash) spendable delegetable m g ops)-    :& (VC . CvAddress) (U.mkContractAddress $-      createOrigOp k mbKeyHash spendable delegetable m ops g) :& r)-runInstrImpl _ (CREATE_CONTRACT2 ops)+runInstrImpl _ (CREATE_CONTRACT ops)   (VC (CvKeyHash k) :& VOption mbKeyHash :& (VC (CvBool spendable)) :&     (VC (CvBool delegetable)) :& (VC (CvMutez m)) :& g :& r) =   pure (VOp (OpCreateContract $@@ -390,13 +431,13 @@ runInstrImpl _ IMPLICIT_ACCOUNT (VC (CvKeyHash k) :& r) =   pure $ VContract (KeyAddress k) :& r runInstrImpl _ NOW r = do-  ContractEnv{..} <- asks ieContractEnv+  ContractEnv{..} <- ask   pure $ VC (CvTimestamp ceNow) :& r runInstrImpl _ AMOUNT r = do-  ContractEnv{..} <- asks ieContractEnv+  ContractEnv{..} <- ask   pure $ VC (CvMutez ceAmount) :& r runInstrImpl _ BALANCE r = do-  ContractEnv{..} <- asks ieContractEnv+  ContractEnv{..} <- ask   pure $ VC (CvMutez ceBalance) :& r runInstrImpl _ CHECK_SIGNATURE (VKey k :& VSignature v :&   VC (CvBytes b) :& r) = pure $ VC (CvBool $ checkSignature k v b) :& r@@ -408,31 +449,43 @@   RemainingSteps x <- gets isRemainingSteps   pure $ VC (CvNat $ (fromInteger . toInteger) x) :& r runInstrImpl _ SOURCE r = do-  ContractEnv{..} <- asks ieContractEnv+  ContractEnv{..} <- ask   pure $ VC (CvAddress ceSource) :& r runInstrImpl _ SENDER r = do-  ContractEnv{..} <- asks ieContractEnv+  ContractEnv{..} <- ask   pure $ VC (CvAddress ceSender) :& r runInstrImpl _ ADDRESS (VContract a :& r) = pure $ VC (CvAddress a) :& r  -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp-  :: ArithOp aop n m+  :: (ArithOp aop n m, Typeable n, Typeable m)   => proxy aop-  -> CVal n-  -> CVal m-  -> EvalOp s (Val instr ('Tc (ArithRes aop n m)))+  -> CValue n+  -> CValue m+  -> EvalOp (T.Value' instr ('Tc (ArithRes aop n m))) runArithOp op l r = case evalOp op l r of   Left  err -> throwError (MichelsonArithError err)-  Right res -> pure (VC res)+  Right res -> pure (T.VC res) +-- | Unpacks given raw data into a typed value.+runUnpack+  :: forall t. (SingI t, HasNoOp t, HasNoBigMap t)+  => TcOriginatedContracts+  -> ByteString+  -> Either UnpackError (T.Value t)+runUnpack contracts bs =+  -- TODO [TM-80] Gas consumption here should depend on unpacked data size+  -- and size of resulting expression, errors would also spend some (all equally).+  -- Fortunatelly, the inner decoding logic does not need to know anything about gas use.+  unpackValue' (UnpackEnv contracts) bs+ createOrigOp-  :: (SingI param, SingI store, ConversibleExt)+  :: (SingI param, SingI store, HasNoOp store)   => KeyHash-  -> Maybe (Val Instr ('Tc 'U.CKeyHash))+  -> Maybe (T.Value ('Tc 'U.CKeyHash))   -> Bool -> Bool -> Mutez   -> Contract param store-  -> Val Instr t+  -> Value' Instr store   -> U.OriginationOperation createOrigOp k mbKeyHash delegetable spendable m contract g =   U.OriginationOperation@@ -441,10 +494,40 @@     , ooSpendable = spendable     , ooDelegatable = delegetable     , ooBalance = m-    , ooStorage = unsafeValToValue g+    , ooStorage = untypeValue g     , ooContract = convertContract contract     } -unwrapMbKeyHash :: Maybe (Val Instr ('Tc 'U.CKeyHash)) -> Maybe KeyHash-unwrapMbKeyHash (Just (VC (CvKeyHash keyHash))) = Just keyHash+unwrapMbKeyHash :: Maybe (T.Value ('Tc 'U.CKeyHash)) -> Maybe KeyHash+unwrapMbKeyHash (Just (T.VC (CvKeyHash keyHash))) = Just keyHash unwrapMbKeyHash Nothing = Nothing++interpretExt :: SomeItStack -> EvalOp ()+interpretExt (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do+  let getEl (Left l) = l+      getEl (Right str) = withStackElem str st show+  modify (\s -> s {isMorleyLogs = MorleyLogs $ mconcat (map getEl pc) : unMorleyLogs (isMorleyLogs s)})++interpretExt (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do+  ost <- runInstrNoGas instr st+  let ((T.fromVal -> succeeded) :& _) = ost+  unless succeeded $ do+    interpretExt (SomeItStack (T.PRINT pc) st)+    throwError $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed"++-- | Access given stack reference (in CPS style).+withStackElem+  :: forall st a.+     T.StackRef st+  -> Rec T.Value st+  -> (forall t. T.Value t -> a)+  -> a+withStackElem (T.StackRef sn) vals cont =+  loop (vals, sn)+  where+    loop+      :: forall s (n :: Peano). (LongerThan s n)+      => (Rec T.Value s, Sing n) -> a+    loop = \case+      (e :& _, SZ) -> cont e+      (_ :& es, SS n) -> loop (es, n)
+ src/Michelson/Interpret/Pack.hs view
@@ -0,0 +1,348 @@+-- | Module, carrying logic of @PACK@ instruction.+--+-- This is nearly symmetric to adjacent Unpack.hs module.+module Michelson.Interpret.Pack+  ( packValue+  , packValue'+  ) where++import Prelude hiding (EQ, GT, LT)++import Control.Exception (assert)+import qualified Data.Binary.Put as Bi+import qualified Data.Bits as Bits+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as Map+import Data.Singletons (SingI(..))++import Michelson.Text+import Michelson.Typed+import Tezos.Address (Address(..))+import Tezos.Core (Mutez(..), timestampToSeconds)+import Tezos.Crypto (KeyHash(..), PublicKey(unPublicKey), Signature(..))++-- | Serialize a value given to @PACK@ instruction.+packValue :: (SingI t, HasNoOp t, HasNoBigMap t) => Value t -> LByteString+packValue x = "\x05" <> encodeValue x++-- | Same as 'packValue', for strict bytestring.+packValue' :: (SingI t, HasNoOp t, HasNoBigMap t) => Value t -> ByteString+packValue' = LBS.toStrict . packValue++encodeValue :: forall t. (SingI t, HasNoOp t, HasNoBigMap t) => Value t -> LByteString+encodeValue val = case (val, sing @t) of+  (VC cval, _) -> encodeCValue cval+  (VKey s, _) ->+    encodeBytes "\x00" "" $+      LBS.fromStrict . ByteArray.convert $ unPublicKey s+  (VUnit, _) -> "\x03\x0b"+  (VSignature x, _) ->+    encodeBytes "" "" $+      LBS.fromStrict . ByteArray.convert $ unSignature x+  (VOption (Just x), STOption _) -> "\x05\x09" <> encodeValue x+  (VOption Nothing, _) -> "\x03\x06"+  (VList xs, STList _) -> encodeList encodeValue xs+  (VSet xs, _) -> encodeList encodeCValue (toList xs)+  (VContract addr, _) -> encodeAddress addr+  (VPair (v1, v2), STPair l _) ->+    case (checkOpPresence l, checkBigMapPresence l) of+      (OpAbsent, BigMapAbsent) -> "\x07\x07" <> encodeValue v1 <> encodeValue v2+  (VOr (Left v), STOr l _) ->+    case (checkOpPresence l, checkBigMapPresence l) of+      (OpAbsent, BigMapAbsent) -> "\x05\x05" <> encodeValue v+  (VOr (Right v), STOr l _) ->+    case (checkOpPresence l, checkBigMapPresence l) of+      (OpAbsent, BigMapAbsent) -> "\x05\x08" <> encodeValue v+  (VLam lam, _) -> encodeInstrs lam+  (VMap m, STMap _ _) -> encodeMap m++encodeCValue :: CValue t -> LByteString+encodeCValue = \case+  CvInt x        -> encodeNumeric x+  CvNat x        -> encodeNumeric x+  CvString text  -> encodeString text+  CvBytes bytes  -> encodeBytes "" "" (LBS.fromStrict bytes)+  CvMutez x      -> encodeNumeric (unMutez x)+  CvBool True    -> "\x03\x0a"+  CvBool False   -> "\x03\x03"+  CvKeyHash s    -> encodeBytes "\x00" "" (LBS.fromStrict $ unKeyHash s)+  CvTimestamp x  -> encodeNumeric (timestampToSeconds @Integer x)+  CvAddress addr -> encodeAddress addr++encodeLength :: Int -> LByteString+encodeLength = Bi.runPut . Bi.putWord32be . fromIntegral++-- | Lift encoded list content to an entire encoded list.+encodeAsList :: LByteString -> LByteString+encodeAsList bs = encodeLength (length bs) <> bs++-- | Encode a list-like structure.+encodeList :: (a -> LByteString) -> [a] -> LByteString+encodeList encodeElem l = "\x02" <> encodeAsList (LBS.concat $ map encodeElem l)++-- | Encode a text.+encodeString :: MText -> LByteString+encodeString text = "\x01" <> encodeAsList (encodeUtf8 $ unMText text)++-- | Encode some raw data.+encodeBytes :: ByteString -> ByteString -> LByteString -> LByteString+encodeBytes (LBS.fromStrict -> prefix) (LBS.fromStrict -> suffix) bs =+  "\x0a" <> encodeAsList (prefix <> bs <> suffix)++-- | Encode some map.+encodeMap :: (SingI v, HasNoOp v, HasNoBigMap v) => Map (CValue k) (Value v) -> LByteString+encodeMap m =+  encodeList (\(k, v) -> "\x07\x04" <> encodeCValue k <> encodeValue v) (Map.toList m)++encodeAddress :: Address -> LByteString+encodeAddress = \case+  KeyAddress keyHash -> encodeBytes "\x00\x00" "" (LBS.fromStrict $ unKeyHash keyHash)+  ContractAddress address -> encodeBytes "\x01" "\x00" (LBS.fromStrict address)++-- | Encode contents of a given number.+encodeIntPayload :: Integer -> LByteString+encodeIntPayload = LBS.pack . toList . doEncode True+  where+    {- Numbers are represented as follows:++    byte 0:         1              _         ______   ||  lowest digits+            has continuation  is negative   payload   ||+                                                      ||+    byte 1:         1                       _______   ||+    ...             1                       _______   ||+    byte n:         0                       _______   ||+            has continuation                payload   \/  highest digits+    -}+    doEncode :: Bool -> Integer -> NonEmpty Word8+    doEncode isFirst a+      | a >= byteWeight =+          let (hi, lo) = a `divMod` byteWeight+              byte = Bits.setBit (fromIntegral @_ @Word8 lo) 7+          in byte :| toList (doEncode False hi)+      | a >= 0 =+          one (fromIntegral @_ @Word8 a)+      | otherwise = assert isFirst $+          let h :| t = doEncode True (-a)+          in Bits.setBit h 6 :| t+      where+        byteWeight = if isFirst then 64 else 128++-- | Encode an int-like value.+encodeNumeric :: Integral i => i -> LByteString+encodeNumeric i = "\x00" <> encodeIntPayload (fromIntegral i)++-- | Encode a code block.+encodeInstrs :: Instr inp out -> LByteString+encodeInstrs = encodeList id . one . encodeInstr++-- | Encode an instruction.+encodeInstr :: forall inp out. Instr inp out -> LByteString+encodeInstr = \case+  Seq a b ->+    encodeInstr a <> encodeInstr b+  Nop ->+    mempty+  Nested i ->+    encodeInstrs i+  Ext _ ->+    ""+  DROP ->+    "\x03\x20"+  DUP ->+    "\x03\x21"+  SWAP ->+    "\x03\x4c"+  PUSH (a :: Value t) ->+    "\x07\x43" <> encodeT' @t <> encodeValue a+  SOME ->+    "\x03\x46"+  NONE | _ :: Proxy ('TOption t ': s) <- Proxy @out ->+    "\x05\x3e" <> encodeT' @t+  UNIT ->+    "\x03\x4f"+  IF_NONE a b ->+    "\x07\x2f" <> encodeInstrs a <> encodeInstrs b+  PAIR ->+    "\x03\x42"+  CAR ->+    "\x03\x16"+  CDR ->+    "\x03\x17"+  LEFT | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->+    "\x05\x33" <> encodeT' @r+  RIGHT | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->+    "\x05\x44" <> encodeT' @l+  IF_LEFT a b ->+    "\x07\x2e" <> encodeInstrs a <> encodeInstrs b+  NIL | _ :: Proxy ('TList t ': s) <- Proxy @out ->+    "\x05\x3d" <> encodeT' @t+  CONS ->+    "\x03\x1b"+  IF_CONS a b ->+    "\x07\x2d" <> encodeInstrs a <> encodeInstrs b+  SIZE ->+    "\x03\x45"+  EMPTY_SET | _ :: Proxy ('TSet t ': s) <- Proxy @out ->+    "\x05\x24" <> encodeT' @('Tc t)+  EMPTY_MAP | _ :: Proxy ('TMap k v ': s) <- Proxy @out ->+    "\x07\x23" <> encodeT' @('Tc k) <> encodeT' @v+  MAP a ->+    "\x05\x38" <> encodeInstrs a+  ITER a ->+    "\x05\x52" <> encodeInstrs a+  MEM ->+    "\x03\x39"+  GET ->+    "\x03\x29"+  UPDATE ->+    "\x03\x50"+  IF a b ->+    "\x07\x2c" <> encodeInstrs a <> encodeInstrs b+  LOOP a ->+    "\x05\x34" <> encodeInstrs a+  LOOP_LEFT a ->+    "\x05\x53" <> encodeInstrs a+  LAMBDA (v :: Value ('TLambda i o)) ->+    "\x09\x31" <>+    encodeAsList (encodeT' @i <> encodeT' @o <> encodeValue v) <>+    encodeLength 0  -- @martoon: dunno where does it come from+  EXEC ->+    "\x03\x26"+  DIP a ->+    "\x05\x1f" <> encodeInstrs a+  FAILWITH ->+    "\x03\x27"+  CAST | _ :: Proxy (t ': s) <- Proxy @out ->+    "\x05\x57" <> encodeT' @t+  RENAME ->+    "\x03\x58"+  PACK ->+    "\x03\x0c"+  UNPACK | _ :: Proxy ('TOption t ': s) <- Proxy @out ->+    "\x05\x0d" <> encodeT' @t+  CONCAT ->+    "\x03\x1a"+  CONCAT' ->+    "\x03\x1a"+  SLICE ->+    "\x03\x6f"+  ISNAT ->+    "\x03\x56"+  ADD ->+    "\x03\x12"+  SUB ->+    "\x03\x4b"+  MUL ->+    "\x03\x3a"+  EDIV ->+    "\x03\x22"+  ABS ->+    "\x03\x11"+  NEG ->+    "\x03\x3b"+  LSL ->+    "\x03\x35"+  LSR ->+    "\x03\x36"+  OR ->+    "\x03\x41"+  AND ->+    "\x03\x14"+  XOR ->+    "\x03\x51"+  NOT ->+    "\x03\x3f"+  COMPARE ->+    "\x03\x19"+  EQ ->+    "\x03\x25"+  NEQ ->+    "\x03\x3c"+  LT ->+    "\x03\x37"+  GT ->+    "\x03\x2a"+  LE ->+    "\x03\x32"+  GE ->+    "\x03\x28"+  INT ->+    "\x03\x30"+  SELF ->+    error "SELF should not appear in lambda"+  CONTRACT _ | _ :: Proxy ('TOption ('TContract t) ': s) <- Proxy @out ->+    "\x05\x55" <> encodeT' @t+  TRANSFER_TOKENS ->+    "\x03\x4d"+  SET_DELEGATE ->+    "\x03\x4e"+  CREATE_ACCOUNT ->+    "\x03\x1c"+  CREATE_CONTRACT (instr :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ]) ->+    let contents =+          [ "\x05\x00" <> encodeT' @p+          , "\x05\x01" <> encodeT' @g+          , "\x05\x02" <> encodeInstrs instr+          ]+    -- TODO [TM-96] These ^ should be encoded in the same order in which+    -- they appear in the original code+    in "\x05\x1d" <> encodeList id contents+  IMPLICIT_ACCOUNT ->+   "\x03\x1e"+  NOW ->+   "\x03\x40"+  AMOUNT ->+   "\x03\x13"+  BALANCE ->+   "\x03\x15"+  CHECK_SIGNATURE ->+   "\x03\x18"+  SHA256 ->+   "\x03\x0f"+  SHA512 ->+   "\x03\x10"+  BLAKE2B ->+   "\x03\x0e"+  HASH_KEY ->+   "\x03\x2b"+  STEPS_TO_QUOTA ->+   "\x03\x4a"+  SOURCE ->+   "\x03\x47"+  SENDER ->+   "\x03\x48"+  ADDRESS ->+   "\x03\x54"++encodeT :: T -> LByteString+encodeT = \case+  Tc ct -> encodeCT ct+  TKey  -> "\x03\x5c"+  TUnit -> "\x03\x6c"+  TSignature -> "\x03\x67"+  TOption t -> "\x05\x63" <> encodeT t+  TList t -> "\x05\x5f" <> encodeT t+  TSet t -> "\x05\x66" <> encodeCT t+  TOperation -> "\x03\x6d"+  TContract t -> "\x05\x5a" <> encodeT t+  TPair a b -> "\x07\x65" <> encodeT a <> encodeT b+  TOr a b -> "\x07\x64" <> encodeT a <> encodeT b+  TLambda a r -> "\x07\x5e" <> encodeT a <> encodeT r+  TMap k v -> "\x07\x60" <> encodeCT k <> encodeT v+  TBigMap k v -> "\x07\x61" <> encodeCT k <> encodeT v++encodeT' :: forall (t :: T). SingI t => LByteString+encodeT' = encodeT (fromSingT $ sing @t)++encodeCT :: CT -> LByteString+encodeCT = ("\x03" <>) . \case+  CInt -> "\x5b"+  CNat -> "\x62"+  CString -> "\x68"+  CBytes -> "\x69"+  CMutez -> "\x6a"+  CBool -> "\x59"+  CKeyHash -> "\x5d"+  CTimestamp -> "\x6b"+  CAddress -> "\x6e"
+ src/Michelson/Interpret/Unpack.hs view
@@ -0,0 +1,586 @@+{- | Module, carrying logic of @UNPACK@ instruction.++This is nearly symmetric to adjacent Pack.hs module.++When implementing this the following sources were used:++* https://pastebin.com/8gfXaRvp++* https://gitlab.com/tezos/tezos/blob/master/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501++* https://github.com/tezbridge/tezbridge-crypto/blob/master/src/PsddFKi3/codec.js#L513++-}+module Michelson.Interpret.Unpack+  ( UnpackError (..)+  , unpackValue+  , unpackValue'+  , UnpackEnv (..)+  ) where++import Prelude hiding (EQ, Ordering(..), get)++import Control.Monad.Except (throwError)+import Data.Binary (Get)+import qualified Data.Binary.Get as Get+import qualified Data.Bits as Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Constraint (Dict(..))+import Data.Default (def)+import qualified Data.Kind as Kind+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Singletons (SingI(..))+import Data.Typeable ((:~:)(..))+import Fmt (Buildable, build, fmt, hexF, (+|), (+||), (|+), (||+))+import Text.Hex (encodeHex)++import Michelson.Text+import Michelson.TypeCheck+  (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TcOriginatedContracts,+  TypeCheckEnv(..))+import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1)+import Michelson.TypeCheck.Instr (typeCheckList)+import Michelson.Typed (Sing(..))+import qualified Michelson.Typed as T+import Michelson.Typed.Scope+  (BigMapPresence(..), HasNoBigMap, HasNoOp, OpPresence(..), bigMapAbsense, checkBigMapPresence,+  checkOpPresence, opAbsense)+import Michelson.Untyped+import Tezos.Address (Address(..))+import Tezos.Core (mkMutez, timestampFromSeconds)+import Tezos.Crypto (KeyHash(..), mkPublicKey, mkSignature)++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Any decoding error.+newtype UnpackError = UnpackError { unUnpackError :: Text }+  deriving (Show, Eq)++instance Buildable UnpackError where+  build (UnpackError msg) = build msg++data UnpackEnv = UnpackEnv+  { ueContracts :: TcOriginatedContracts+  }++-- | Alias for label attaching.+(?) :: Get a -> String -> Get a+(?) = flip Get.label+infix 0 ?++-- | Get a bytestring of the given length leaving no references to the+-- original data in serialized form.+getByteStringCopy :: Int -> Get ByteString+getByteStringCopy = fmap BS.copy . Get.getByteString++-- | Read a byte and match it against given value.+expectTag :: String -> Word8 -> Get ()+expectTag desc t =+  Get.label desc $ do+    t' <- Get.getWord8+    unless (t == t') $+      fail . fmt $ "Unexpected tag value (expected 0x" +| hexF t |++                   ", but got 0x" +| hexF t' |+ ")"++-- | Fail with "unknown tag" error.+unknownTag :: Text -> Word8 -> Get a+unknownTag desc tag =+  fail . fmt $ "Unknown " <> build desc <> " tag: 0x" <> hexF tag++-- | Read a byte describing the primitive going further and match it against+-- expected tag in the given conditions.+--+-- Aside of context description, you have to specify number of arguments which+-- given instruction accepts when written in Michelson. For instance, @PUSH@+-- accepts two arguments - type and value.+expectDescTag :: HasCallStack => String -> Word16 -> Get ()+expectDescTag desc argsNum =+  Get.label desc $ do+    tag <- Get.getWord8+    unless (tag == expected) $+      fail . fmt $ "Unexpected preliminary tag: 0x" <> hexF tag+  where+    expected = case argsNum of+      0 -> 0x03+      1 -> 0x05+      2 -> 0x07+      3 -> 0x08+      _ -> error "Bad arguments num"+      -- Intermediate values of tag are also used and designate that annotations+      -- are also attached to the packed data. But they are never produced by+      -- @PACK@, neither @UNPACK@ seem to expect them, so for now we pretend+      -- that annotations do not exist.++ensureEnd :: Get ()+ensureEnd =+  unlessM Get.isEmpty $ do+    remainder <- Get.getRemainingLazyByteString+    fail $ "Expected end of entry, unconsumed bytes \+           \(" +| length remainder |+ "): "+           +|| encodeHex (LBS.toStrict remainder) ||+ ""++-- | Like 'many', but doesn't backtrack if next entry failed to parse+-- yet there are some bytes to consume ahead.+--+-- This function exists primarily for better error messages.+manyForced :: Get a -> Get [a]+manyForced decode = do+  emp <- Get.isEmpty+  if emp+    then return []+    else (:) <$> decode <*> manyForced decode++----------------------------------------------------------------------------+-- Michelson serialisation+----------------------------------------------------------------------------++{- Implementation notes:++* We need to know which exact type we unpack to.+For instance, serialized signatures are indistinguishable from+plain serialized bytes, so if we want to return "Value" (typed or untyped),+we need to know currently expected type. The reference implementation does+the same.++* It occured to be easier to decode to typed values and untyped instructions.+When decoding lambda, we type check given instruction, and when decoding+@PUSH@ call we untype decoded value.+One may say that this gives unreasonable performance overhead, but with the+current definition of "Value" types (typed and untyped) we cannot avoid it+anyway, because when deserializing bytearray-like data (keys, signatures, ...),+we have to convert raw bytes to human-readable 'Text' and later parse them+to bytes back at type check stage.+We console ourselves that lambdas are rarely packed.++-}++-- | Deserialize bytes into the given value.+-- Suitable for @UNPACK@ operation only.+unpackValue+  :: (SingI t, HasNoOp t, HasNoBigMap t)+  => UnpackEnv -> LByteString -> Either UnpackError (T.Value t)+unpackValue env bs =+  case Get.runGetOrFail (unpackDecoder env) bs of+    Left (_remainder, _offset, err) -> Left . UnpackError $ toText err+    Right (_remainder, _offset, res) -> Right res++-- | Like 'unpackValue', for strict byte array.+unpackValue'+  :: (SingI t, HasNoOp t, HasNoBigMap t)+  => UnpackEnv -> ByteString -> Either UnpackError (T.Value t)+unpackValue' env = unpackValue env . LBS.fromStrict++-- | Overall value decoder we use in @UNPACK@.+unpackDecoder+  :: (SingI t, HasNoOp t, HasNoBigMap t)+  => UnpackEnv -> Get (T.Value t)+unpackDecoder env =+  expectTag "Packed data start" 0x05 *> decodeValue env <* ensureEnd++decodeValue+  :: forall t.+     (SingI t, HasNoOp t, HasNoBigMap t)+  => UnpackEnv -> Get (T.Value t)+decodeValue env = Get.label "Value" $+  case sing @t of+    STc _ ->+      T.VC <$> decodeCValue+    STKey ->+      decodeAsBytes $ do+        expectTag "Key pad" 0x00+        bs <- getByteStringCopy 32+        case mkPublicKey bs of+          Left err -> fail $ "Wrong public key format: " <> toString err+          Right pk -> pure (T.VKey pk)+    STUnit -> do+      expectDescTag "Unit" 0+      expectTag "Unit" 0x0B+      return T.VUnit+    STSignature -> do+      decodeAsBytes $ do+        bs <- getByteStringCopy 64+        case mkSignature bs of+          Left err -> fail $ "Wrong signature format: " <> toString err+          Right s -> pure (T.VSignature s)+    STOption _ -> do+      Get.getByteString 2 >>= \case+        "\x03\x06" -> pure (T.VOption Nothing)+        "\x05\x09" -> T.VOption . Just <$> decodeValue env+        other -> fail $ "Unknown option tag: " <> show other+    STList _ -> do+      decodeAsList $ T.VList <$> manyForced (decodeValue env)+    STSet _ -> do+      decodeAsList $ do+        vals <- manyForced decodeCValue+        either (fail . toString) pure $+          T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals+    STContract _ ->+      T.VContract <$> decodeAddress+    STPair lt _ ->+      case (checkOpPresence lt, checkBigMapPresence lt) of+        (OpAbsent, BigMapAbsent) -> do+          expectDescTag "Pair" 2+          expectTag "Pair" 0x07+          T.VPair ... (,) <$> decodeValue env <*> decodeValue env+    STOr lt _ ->+      case (checkOpPresence lt, checkBigMapPresence lt) of+        (OpAbsent, BigMapAbsent) -> do+          expectDescTag "Or" 1+          Get.getWord8 >>= \case+            0x05 -> T.VOr . Left <$> decodeValue env+            0x08 -> T.VOr . Right <$> decodeValue env+            other -> unknownTag "or constructor" other+    STLambda _ _ -> do+      uinstr <- decodeOps env+      T.VLam <$> decodeTypeCheckLam env uinstr+    STMap _ _ -> do+      T.VMap <$> decodeMap env++decodeCValue :: forall ct. SingI ct => Get (T.CValue ct)+decodeCValue = case sing @ct of+  -- TODO [TM-140]: The reference implementation allows to decode some+  -- of cases below both from bytes and from string; consider this.+  SCInt -> do+    expectTag "Int" 0x00+    T.CvInt <$> decodeInt+  SCNat -> do+    expectTag "Nat" 0x00+    T.CvNat <$> decodeInt+  SCString -> do+    expectTag "String" 0x01+    T.CvString <$> decodeString+  SCBytes -> do+    expectTag "Bytes" 0x0a+    T.CvBytes <$> decodeBytes+  SCMutez -> do+    expectTag "Mutez" 0x00+    mmutez <- mkMutez <$> decodeInt+    maybe (fail "Negative mutez") (pure . T.CvMutez) mmutez+  SCBool -> do+    expectDescTag "Bool" 0+    Get.getWord8 >>= \case+      0x0A -> pure (T.CvBool True)+      0x03 -> pure (T.CvBool False)+      other -> unknownTag "bool" other+  SCKeyHash ->+    decodeAsBytes $ do+      expectTag "key address pad" 0x00+      T.CvKeyHash . KeyHash <$> getByteStringCopy 20+  SCTimestamp -> do+    expectTag "Timestamp" 0x00+    T.CvTimestamp . timestampFromSeconds @Integer <$> decodeInt+  SCAddress ->+    T.CvAddress <$> decodeAddress++-- | Read length of something (list, string, ...).+decodeLength :: Get Int+decodeLength = Get.label "Length" $ do+  len <- Get.getWord32be+  -- @martoon: I'm not sure whether returning 'Int' is valid here.+  -- Strictly speaking, it may be 'Word32', but there seems to be no easy way+  -- to check the reference implementation on that.+  -- One more reason to go with just 'Int' for now is that we need to be able to+  -- deserialize byte arrays, and 'BS.ByteString' keeps length of type 'Int'+  -- inside.+  let len' = fromIntegral @_ @Int len+  unless (fromIntegral len' == len && len' >= 0) $+    fail "Length overflow"+  return len'++decodeAsListRaw :: Get a -> Get a+decodeAsListRaw getElems = do+  l <- decodeLength ? "List length"+  Get.isolate l (getElems ? "List content")++-- | Given decoder for list content, get a whole list decoder.+decodeAsList :: Get a -> Get a+decodeAsList getElems = do+  expectTag "List" 0x02+  decodeAsListRaw getElems++decodeString :: Get MText+decodeString = do+  l <- decodeLength ? "String length"+  ss <- replicateM l Get.getWord8 ? "String content"+  ss' <- decodeUtf8' (BS.pack ss)+    & either (fail . show) pure+    ? "String UTF-8 decoding"+  mkMText ss'+    & either (fail . show) pure+    ? "Michelson string validity analysis"++decodeAsBytesRaw :: (Int -> Get a) -> Get a+decodeAsBytesRaw decode = do+  l <- decodeLength ? "Byte array length"+  decode l ? "Byte array content"++decodeAsBytes :: Get a -> Get a+decodeAsBytes decode = do+  expectTag "Bytes" 0x0A+  decodeAsBytesRaw (const decode)++decodeBytes :: Get ByteString+decodeBytes = decodeAsBytesRaw getByteStringCopy++decodeMap+  :: (SingI k, SingI v, HasNoOp v, HasNoBigMap v)+  => UnpackEnv -> Get $ Map (T.CValue k) (T.Value v)+decodeMap env = Get.label "Map" $+  decodeAsList $ do+    es <- manyForced $ do+      expectDescTag "Elt" 2+      expectTag "Elt" 0x04+      (,) <$> decodeCValue <*> decodeValue env+    either (fail . toString) pure $+      Map.fromDistinctAscList <$> ensureDistinctAsc fst es++decodeAddress :: Get Address+decodeAddress = Get.label "Address" $+  decodeAsBytes $ (Get.getWord8 ? "Address tag") >>= \case+    0x00 -> Get.label "Plain address" $ do+      expectTag "key address pad" 0x00+      KeyAddress . KeyHash <$> getByteStringCopy 20+    0x01 -> Get.label "Contract address" $ do+      addr <- getByteStringCopy 20+      expectTag "contract address pad" 0x00+      return $ ContractAddress addr+    other -> unknownTag "address" other++-- | Read a numeric value.+decodeInt :: Num i => Get i+decodeInt = fromIntegral @Integer <$> loop 0 0 ? "Number"+  where+    loop !offset !acc = do+      byte <- Get.getWord8++      let hasCont = Bits.testBit byte 7+      let doCont shft = if hasCont then loop (shft + offset) else pure+      let addAndCont shft bytePayload =+            doCont shft $ acc + Bits.shiftL (fromIntegral bytePayload) offset++      let payload = Bits.clearBit byte 7+      if offset > 0+        then addAndCont 7 payload+        else do+          let sign = if Bits.testBit byte 6 then -1 else 1+          let upayload = Bits.clearBit payload 6+          (sign *) <$> addAndCont 6 upayload++-- | For @UNPACK@ we do not consider annotations at all.+-- If they start matter for other purposes some day, remove this function.+decodeAnn :: forall (t :: Kind.Type). Get (Annotation t)+decodeAnn = pure noAnn++-- | Type check instruction occured from a lambda.+decodeTypeCheckLam+  :: forall inp out m.+     (Typeable inp, SingI inp, SingI out, Typeable out, MonadFail m)+  => UnpackEnv+  -> [ExpandedOp]+  -> m (T.Instr '[inp] '[out])+decodeTypeCheckLam UnpackEnv{..} uinstr =+  either tcErrToFail pure . evaluatingState tcInitEnv . runExceptT $ do+    let inp = (sing @inp, T.NStar, noAnn) ::& SNil+    _ :/ instr' <- typeCheckList uinstr inp+    case instr' of+      instr ::: out' ->+        case eqHST1 @out out' of+          Right Refl ->+            pure instr+          Left err ->+                -- dummy types, we have no full information to build untyped+                -- 'T' anyway+            let tinp = Type TUnit noAnn+                tout = Type TUnit noAnn+            in throwError $+              TCFailedOnInstr (LAMBDA noAnn tinp tout uinstr) (SomeHST inp)+              "Unexpected lambda output type" def (Just err)+      AnyOutInstr instr ->+        return instr+  where+    tcErrToFail err = fail $ "Type check failed: " +| err |+ ""+    tcInitEnv =+      TypeCheckEnv+      { tcExtFrames = error "runInstrImpl(UNPACK): tcExtFrames touched"+        --- ^ This is safe because @UNPACK@ never produces Ext instructions+      , tcContractParam = error "runInstrImpl(UNPACK): tcContractParam touched"+        --- ^ Used only in @SELF@ interpretation,+        ---   but there is no way for @SELF@ to appear in packed data+      , tcContracts = ueContracts+      }++decodeInstr :: UnpackEnv -> Get ExpandedInstr+decodeInstr env = Get.label "Instruction" $ do+  pretag <- Get.getWord8 ? "Pre instr tag"+  tag <- Get.getWord8 ? "Instr tag"+  case (pretag, tag) of+    (0x03, 0x20) -> pure $ DROP+    (0x03, 0x21) -> pure $ DUP noAnn+    (0x03, 0x4C) -> pure $ SWAP+    (0x07, 0x43) -> do+      an :: VarAnn <- decodeAnn+      typ <- decodeType+      T.withSomeSingT (T.fromUType typ) $ \(st :: Sing t) ->+        case (opAbsense st, bigMapAbsense st) of+          (Nothing, _) -> fail "Operation type in PUSH"+          (_, Nothing) -> fail "BigMap type in PUSH"+          (Just Dict, Just Dict) -> do+            tval <- decodeValue @t env+            return $ PUSH an typ (T.untypeValue tval)+    (0x03, 0x46) -> SOME <$> decodeAnn <*> decodeAnn <*> decodeAnn+    (0x05, 0x3E) -> NONE <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeType+    (0x03, 0x4F) -> UNIT <$> decodeAnn <*> decodeAnn+    (0x07, 0x2F) -> IF_NONE <$> decodeOps env <*> decodeOps env+    (0x03, 0x42) -> PAIR <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn+    (0x03, 0x16) -> CAR <$> decodeAnn <*> decodeAnn+    (0x03, 0x17) -> CDR <$> decodeAnn <*> decodeAnn+    (0x05, 0x33) -> LEFT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn+                         <*> decodeType+    (0x05, 0x44) -> RIGHT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn+                          <*> decodeType+    (0x07, 0x2E) -> IF_LEFT <$> decodeOps env <*> decodeOps env+    (0x05, 0x3D) -> NIL <$> decodeAnn <*> decodeAnn <*> decodeType+    (0x03, 0x1B) -> CONS <$> decodeAnn+    (0x07, 0x2D) -> IF_CONS <$> decodeOps env <*> decodeOps env+    (0x03, 0x45) -> SIZE <$> decodeAnn+    (0x05, 0x24) -> EMPTY_SET <$> decodeAnn <*> decodeAnn <*> decodeComparable+    (0x07, 0x23) -> EMPTY_MAP <$> decodeAnn <*> decodeAnn <*> decodeComparable+                              <*> decodeType+    (0x05, 0x38) -> MAP <$> decodeAnn <*> decodeOps env+    (0x05, 0x52) -> ITER <$> decodeOps env+    (0x03, 0x39) -> MEM <$> decodeAnn+    (0x03, 0x29) -> GET <$> decodeAnn+    (0x03, 0x50) -> pure UPDATE+    (0x07, 0x2C) -> IF <$> decodeOps env <*> decodeOps env+    (0x05, 0x34) -> LOOP <$> decodeOps env+    (0x05, 0x53) -> LOOP_LEFT <$> decodeOps env+    (0x09, 0x31) -> do+      res <- decodeAsListRaw $+        LAMBDA <$> decodeAnn <*> decodeType <*> decodeType <*> decodeOps env+      void decodeLength+      return res+    (0x03, 0x26) -> EXEC <$> decodeAnn+    (0x05, 0x1F) -> DIP <$> decodeOps env+    (0x03, 0x27) -> pure FAILWITH+    (0x05, 0x57) -> CAST <$> decodeAnn <*> decodeType+    (0x03, 0x58) -> RENAME <$> decodeAnn+    (0x03, 0x0C) -> PACK <$> decodeAnn+    (0x05, 0x0D) -> UNPACK <$> decodeAnn <*> decodeType+    (0x03, 0x1A) -> CONCAT <$> decodeAnn+    (0x03, 0x6F) -> SLICE <$> decodeAnn+    (0x03, 0x56) -> ISNAT <$> decodeAnn+    (0x03, 0x12) -> ADD <$> decodeAnn+    (0x03, 0x4B) -> SUB <$> decodeAnn+    (0x03, 0x3A) -> MUL <$> decodeAnn+    (0x03, 0x22) -> EDIV <$> decodeAnn+    (0x03, 0x11) -> ABS <$> decodeAnn+    (0x03, 0x3B) -> pure NEG+    (0x03, 0x35) -> LSL <$> decodeAnn+    (0x03, 0x36) -> LSR <$> decodeAnn+    (0x03, 0x41) -> OR <$> decodeAnn+    (0x03, 0x14) -> AND <$> decodeAnn+    (0x03, 0x51) -> XOR <$> decodeAnn+    (0x03, 0x3F) -> NOT <$> decodeAnn+    (0x03, 0x19) -> COMPARE <$> decodeAnn+    (0x03, 0x25) -> EQ <$> decodeAnn+    (0x03, 0x3C) -> NEQ <$> decodeAnn+    (0x03, 0x37) -> LT <$> decodeAnn+    (0x03, 0x2A) -> GT <$> decodeAnn+    (0x03, 0x32) -> LE <$> decodeAnn+    (0x03, 0x28) -> GE <$> decodeAnn+    (0x03, 0x30) -> INT <$> decodeAnn+    (0x05, 0x55) -> CONTRACT <$> decodeAnn <*> decodeType+    (0x03, 0x4D) -> TRANSFER_TOKENS <$> decodeAnn+    (0x03, 0x4E) -> SET_DELEGATE <$> decodeAnn+    (0x03, 0x1C) -> CREATE_ACCOUNT <$> decodeAnn <*> decodeAnn+    (0x05, 0x1D) ->+      decodeAsList $ do+        an1 <- decodeAnn+        an2 <- decodeAnn+        expectTag "Pre contract parameter" 0x05+        expectTag "Contract parameter" 0x00+        p <- decodeType+        expectTag "Pre contract storage" 0x05+        expectTag "Contract storage" 0x01+        s <- decodeType+        expectTag "Pre contract code" 0x05+        expectTag "Contract code" 0x02+        c <- decodeOps env+        return $ CREATE_CONTRACT an1 an2 (Contract p s c)+    (0x03, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeAnn+    (0x03, 0x40) -> NOW <$> decodeAnn+    (0x03, 0x13) -> AMOUNT <$> decodeAnn+    (0x03, 0x15) -> BALANCE <$> decodeAnn+    (0x03, 0x18) -> CHECK_SIGNATURE <$> decodeAnn+    (0x03, 0x0F) -> SHA256 <$> decodeAnn+    (0x03, 0x10) -> SHA512 <$> decodeAnn+    (0x03, 0x0E) -> BLAKE2B <$> decodeAnn+    (0x03, 0x2B) -> HASH_KEY <$> decodeAnn+    (0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeAnn+    (0x03, 0x47) -> SOURCE <$> decodeAnn+    (0x03, 0x48) -> SENDER <$> decodeAnn+    (0x03, 0x54) -> ADDRESS <$> decodeAnn+    (other1, other2) -> fail $ "Unknown instruction tag: 0x" +|+                        hexF other1 |+ hexF other2 |+ ""++decodeOp :: UnpackEnv -> Get ExpandedOp+decodeOp env = Get.label "Op" $ do+  tag <- Get.lookAhead Get.getWord8+  if tag == 0x02+    then SeqEx <$> decodeOps env ? "Ops seq"+    else PrimEx <$> decodeInstr env ? "One op"++decodeOps :: UnpackEnv -> Get [ExpandedOp]+decodeOps env = decodeAsList $ manyForced (decodeOp env)++decodeComparable :: Get Comparable+decodeComparable = Get.label "Comparable primitive type" $+  Comparable <$> decodeCT <*> decodeAnn++decodeCT :: Get CT+decodeCT = Get.label "CT" $ do+  pretag <- Get.getWord8 ? "Pre simple comparable type tag"+  tag <- Get.getWord8 ? "Simple comparable type tag"+  case (pretag, tag) of+    (0x03, 0x5B) -> pure CInt+    (0x03, 0x62) -> pure CNat+    (0x03, 0x68) -> pure CString+    (0x03, 0x69) -> pure CBytes+    (0x03, 0x6A) -> pure CMutez+    (0x03, 0x59) -> pure CBool+    (0x03, 0x5D) -> pure CKeyHash+    (0x03, 0x6B) -> pure CTimestamp+    (0x03, 0x6E) -> pure CAddress+    (other1, other2) -> fail $ "Unknown primitive tag: 0x" +|+                        hexF other1 |+ hexF other2 |+ ""++decodeT :: Get T+decodeT = Get.label "T" $+  doDecode <|> (Tc <$> decodeCT)+  where+    doDecode = do+      pretag <- Get.getWord8 ? "Pre complex type tag"+      tag <- Get.getWord8 ? "Complex type tag"+      case (pretag, tag) of+        (0x03, 0x5C) -> pure TKey+        (0x03, 0x6C) -> pure TUnit+        (0x03, 0x67) -> pure TSignature+        (0x05, 0x63) -> TOption <$> decodeAnn <*> decodeType+        (0x05, 0x5F) -> TList <$> decodeType+        (0x05, 0x66) -> TSet <$> decodeComparable+        (0x03, 0x6D) -> pure TOperation+        (0x05, 0x5A) -> TContract <$> decodeType+        (0x07, 0x65) -> TPair <$> decodeAnn <*> decodeAnn <*> decodeType <*> decodeType+        (0x07, 0x64) -> TOr <$> decodeAnn <*> decodeAnn <*> decodeType <*> decodeType+        (0x07, 0x5E) -> TLambda <$> decodeType <*> decodeType+        (0x07, 0x60) -> TMap <$> decodeComparable <*> decodeType+        (0x07, 0x61) -> TBigMap <$> decodeComparable <*> decodeType+        (other1, other2) -> fail $ "Unknown primitive tag: 0x" +|+                            hexF other1 |+ hexF other2 |+ ""++decodeType :: Get Type+decodeType = Type <$> decodeT <*> decodeAnn ? "Type"
+ src/Michelson/Let.hs view
@@ -0,0 +1,26 @@+module Michelson.Let+  ( LetType (..)+  , LetValue (..)+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import qualified Data.Text as T++import Michelson.Macro (ParsedOp)+import Michelson.Untyped (Type, Value')++-- | A programmer-defined constant+data LetValue = LetValue+  { lvName :: T.Text+  , lvSig :: Type+  , lvVal :: (Value' ParsedOp)+  } deriving (Eq, Show)++-- | A programmer-defined type-synonym+data LetType = LetType+  { ltName :: T.Text+  , ltSig :: Type+  } deriving (Eq, Show)++deriveJSON defaultOptions ''LetValue+deriveJSON defaultOptions ''LetType
+ src/Michelson/Macro.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++module Michelson.Macro+  (+  -- * Macros types+    CadrStruct (..)+  , PairStruct (..)+  , Macro (..)+  , LetMacro (..)++  -- * Morley Parsed value types+  , ParsedValue++  -- * Morley Parsed instruction types+  , ParsedInstr+  , ParsedOp (..)+  , ParsedUTestAssert+  , ParsedUExtInstr++    -- * For utilities+  , expandContract+  , expandValue++    -- * For parsing+  , mapLeaves++    -- * Internals exported for tests+  , expand+  , expandList+  , expandMacro+  , expandPapair+  , expandUnpapair+  , expandCadr+  , expandSetCadr+  , expandMapCadr+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Generics (everywhere, mkT)+import qualified Data.Text as T+import Fmt (Buildable(build), genericF, (+|), (+||), (|+), (||+))+import qualified Text.PrettyPrint.Leijen.Text as PP (empty)++import Michelson.ErrorPos+import Michelson.Printer (RenderDoc(..))+import Michelson.Untyped+import Util.Generic++-- | A programmer-defined macro+data LetMacro = LetMacro+  { lmName :: T.Text+  , lmSig :: StackFn+  , lmExpr :: [ParsedOp]+  } deriving (Eq, Show, Data, Generic)++instance Buildable LetMacro where+  build = genericF++data PairStruct+  = F (VarAnn, FieldAnn)+  | P PairStruct PairStruct+  deriving (Eq, Show, Data, Generic)++instance Buildable PairStruct where+  build = genericF++data CadrStruct+  = A+  | D+  deriving (Eq, Show, Data, Generic)++instance Buildable CadrStruct where+  build = genericF++-- | Unexpanded instructions produced directly by the @ops@ parser, which+-- contains primitive Michelson Instructions, inline-able macros and sequences+data ParsedOp+  = Prim ParsedInstr SrcPos -- ^ Primitive Michelson instruction+  | Mac Macro        SrcPos -- ^ Built-in Michelson macro defined by the specification+  | LMac LetMacro    SrcPos -- ^ User-defined macro with instructions to be inlined+  | Seq [ParsedOp]   SrcPos -- ^ A sequence of instructions+  deriving (Eq, Show, Data, Generic)++-- dummy value+instance RenderDoc ParsedOp where+  renderDoc _ = PP.empty++instance Buildable ParsedOp where+  build (Prim parseInstr _) = "<Prim: "+|parseInstr|+">"+  build (Mac macro _)       = "<Mac: "+|macro|+">"+  build (LMac letMacro _)   = "<LMac: "+|letMacro|+">"+  build (Seq parsedOps _)     = "<Seq: "+|parsedOps|+">"++-------------------------------------+-- Types produced by parser+-------------------------------------++type ParsedUTestAssert = TestAssert ParsedOp++type ParsedUExtInstr = ExtInstrAbstract ParsedOp++type ParsedInstr = InstrAbstract ParsedOp++type ParsedValue = Value' ParsedOp++-- | Built-in Michelson Macros defined by the specification+data Macro+  = CASE (NonEmpty [ParsedOp])+  | TAG Natural (NonEmpty Type)+  | VIEW [ParsedOp]+  | VOID [ParsedOp]+  | CMP ParsedInstr VarAnn+  | IFX ParsedInstr [ParsedOp] [ParsedOp]+  | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]+  | FAIL+  | PAPAIR PairStruct TypeAnn VarAnn+  | UNPAIR PairStruct+  | CADR [CadrStruct] VarAnn FieldAnn+  | SET_CADR [CadrStruct] VarAnn FieldAnn+  | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]+  | DIIP Integer [ParsedOp]+  | DUUP Integer VarAnn+  | ASSERT+  | ASSERTX ParsedInstr+  | ASSERT_CMP ParsedInstr+  | ASSERT_NONE+  | ASSERT_SOME+  | ASSERT_LEFT+  | ASSERT_RIGHT+  | IF_SOME [ParsedOp] [ParsedOp]+  | IF_RIGHT [ParsedOp] [ParsedOp]+  deriving (Eq, Show, Data, Generic)++instance Buildable Macro where+  build (TAG idx ty) = "<TAG: #"+||idx||+" from "+|toList ty|+""+  build (CASE parsedInstrs) = "<CASE: "+|toList parsedInstrs|+">"+  build (VIEW code) = "<VIEW: "+|code|+">"+  build (VOID code) = "<VOID: "+|code|+">"+  build (CMP parsedInstr carAnn) = "<CMP: "+|parsedInstr|+", "+|carAnn|+">"+  build (IFX parsedInstr parsedOps1 parsedOps2) = "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"+  build (IFCMP parsedInstr varAnn parsedOps1 parsedOps2) = "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"+  build FAIL = "FAIL"+  build (PAPAIR pairStruct typeAnn varAnn) = "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"+  build (UNPAIR pairStruct) = "<UNPAIR: "+|pairStruct|+">"+  build (CADR cadrStructs varAnn fieldAnn) = "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+  build (SET_CADR cadrStructs varAnn fieldAnn) = "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+  build (MAP_CADR cadrStructs varAnn fieldAnn parsedOps) = "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"+  build (DIIP integer parsedOps) = "<DIIP: "+|integer|+", "+|parsedOps|+">"+  build (DUUP integer varAnn) = "<DUUP: "+|integer|+", "+|varAnn|+">"+  build ASSERT = "ASSERT"+  build (ASSERTX parsedInstr) = "<ASSERTX: "+|parsedInstr|+">"+  build (ASSERT_CMP parsedInstr) = "<ASSERT_CMP: "+|parsedInstr|+">"+  build ASSERT_NONE  = "ASSERT_NONE"+  build ASSERT_SOME  = "ASSERT_SOME"+  build ASSERT_LEFT  = "ASSERT_LEFT"+  build ASSERT_RIGHT = "ASSERT_RIGHT"+  build (IF_SOME parsedOps1 parsedOps2) = "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"+  build (IF_RIGHT parsedOps1 parsedOps2) = "<IF_RIGHT: "+|parsedOps1|+", "+|parsedOps2|+">"++expandList :: [ParsedOp] -> [ExpandedOp]+expandList = fmap (expand [])++-- | Expand all macros in parsed contract.+expandContract :: Contract' ParsedOp -> Contract+expandContract Contract {..} =+  Contract para stor (map (substituteTypes para stor) . expandList $ code)++substituteTypes :: Parameter -> Storage -> ExpandedOp -> ExpandedOp+substituteTypes param stor =+  everywhere $ mkT $ \case+    TypeParameter -> param+    TypeStorage -> stor+    t@(Type {}) -> t++-- Probably, some SYB can be used here+expandValue :: ParsedValue -> Value+expandValue = \case+  ValuePair l r -> ValuePair (expandValue l) (expandValue r)+  ValueLeft x -> ValueLeft (expandValue x)+  ValueRight x -> ValueRight (expandValue x)+  ValueSome x -> ValueSome (expandValue x)+  ValueNil -> ValueNil+  ValueSeq valueList -> ValueSeq (map expandValue valueList)+  ValueMap eltList -> ValueMap (map expandElt eltList)+  ValueLambda opList ->+    maybe ValueNil ValueLambda $+    nonEmpty (expandList $ toList opList)+  x -> fmap (expand []) x++expandElt :: Elt ParsedOp -> Elt ExpandedOp+expandElt (Elt l r) = Elt (expandValue l) (expandValue r)++expand :: LetCallStack -> ParsedOp -> ExpandedOp+-- 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.+expand cs (Mac (PAPAIR (P (F a) (F b)) t v) pos) =+  WithSrcEx (InstrCallStack cs pos) $ PrimEx (PAIR t v (snd a) (snd b))+expand cs (Mac m pos)  = let ics = InstrCallStack cs pos in+  WithSrcEx ics $ SeqEx $ expandMacro ics m+expand cs (Prim i pos) = WithSrcEx (InstrCallStack cs pos) $ PrimEx $ expand cs <$> i+expand cs (Seq s pos)  = WithSrcEx (InstrCallStack cs pos) $ SeqEx $ expand cs <$> s+expand cs (LMac l pos) = expandLetMac l+  where+    expandLetMac :: LetMacro -> ExpandedOp+    expandLetMac LetMacro {..} =+      let newCS = LetName lmName : cs in+      let ics = InstrCallStack newCS pos in+      WithSrcEx ics $ PrimEx . EXT . FN lmName lmSig $ expand newCS <$> lmExpr++expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]+expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case+  VIEW a             -> expandMacro p (UNPAIR $ P (F (noAnn,noAnn)) (F (noAnn,noAnn))) +++                        [ PrimEx (DIP $ expandMacro p $ DUUP 2 noAnn)+                        , PrimEx $ DUP noAnn+                        , PrimEx $ DIP $ concat [+                              [PrimEx $ PAIR noAnn noAnn noAnn noAnn]+                            , expand cs <$> a+                            , [PrimEx $ SOME noAnn noAnn noAnn]+                            ]+                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn+                        , PrimEx (DIP [PrimEx $ AMOUNT noAnn])+                        , PrimEx $ TRANSFER_TOKENS noAnn+                        , PrimEx $ NIL noAnn noAnn (Type TOperation noAnn)+                        , PrimEx $ SWAP+                        , PrimEx $ CONS noAnn+                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn+                        ]+  VOID a             -> expandMacro p (UNPAIR (P (F (noAnn,noAnn)) (F (noAnn,noAnn)))) +++                        [ PrimEx SWAP+                        , PrimEx $ DIP $ expand cs <$> a+                        , PrimEx SWAP+                        , PrimEx $ EXEC noAnn+                        , PrimEx FAILWITH+                        ]+  CASE is            -> mkGenericTree (\_ l r -> one . PrimEx $ IF_LEFT l r)+                                      (map (expand cs) <$> is)+  TAG idx uty        -> expandTag (fromIntegral idx) uty+  CMP i v            -> [PrimEx (COMPARE v), xo i]+  IFX i bt bf        -> [xo i, PrimEx $ IF (xp bt) (xp bf)]+  IFCMP i v bt bf    -> PrimEx <$> [COMPARE v, expand cs <$> i, IF (xp bt) (xp bf)]+  IF_SOME bt bf      -> [PrimEx (IF_NONE (xp bf) (xp bt))]+  IF_RIGHT bt bf     -> [PrimEx (IF_LEFT (xp bf) (xp bt))]+  FAIL               -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH]+  ASSERT             -> oprimEx $ IF [] (expandMacro p FAIL)+  ASSERTX i          -> [expand cs $ mac $ IFX i [] [mac FAIL]]+  ASSERT_CMP i       -> [expand cs $ mac $ IFCMP i noAnn [] [mac FAIL]]+  ASSERT_NONE        -> oprimEx $ IF_NONE [] (expandMacro p FAIL)+  ASSERT_SOME        -> oprimEx $ IF_NONE (expandMacro p FAIL) []+  ASSERT_LEFT        -> oprimEx $ IF_LEFT [] (expandMacro p FAIL)+  ASSERT_RIGHT       -> oprimEx $ IF_LEFT (expandMacro p FAIL) []+  PAPAIR ps t v      -> expandPapair p ps t v+  UNPAIR ps          -> expandUnpapair p ps+  CADR c v f         -> expandCadr p c v f+  SET_CADR c v f     -> expandSetCadr p c v f+  MAP_CADR c v f ops -> expandMapCadr p c v f ops+  DIIP 1 ops         -> oprimEx $ DIP (xp ops)+  DIIP n ops         -> oprimEx $ DIP $ expandMacro p (DIIP (n - 1) ops)+  DUUP 1 v           -> oprimEx $ DUP v+  DUUP n v           -> PrimEx <$> [DIP (expandMacro p (DUUP (n - 1) v)), SWAP]+  where+    mac = flip Mac macroPos+    oprimEx = one . PrimEx+    xo = PrimEx . fmap (expand cs)+    xp = fmap (expand cs)++-- the correctness of type-annotation expansion is currently untested, as these+-- expansions are not explicitly documented in the Michelson Specification+expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]+expandPapair ics ps t v = case ps of+  P (F a) (F b) -> [PrimEx $ PAIR t v (snd a) (snd b)]+  P (F a) r     -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)+                              , PAIR t v (snd a) noAnn]+  P l     (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) +++                   [PrimEx $ PAIR t v noAnn (snd b)]+  P l     r     -> expandMacro ics (PAPAIR l noAnn noAnn) +++                   [ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)+                   , PrimEx $ PAIR t v noAnn noAnn]+  F _           -> [] -- Do nothing in this case.+  -- It's impossible from the structure of PairStruct and considered cases above,+  -- but if it accidentally happened let's just do nothing.++expandUnpapair :: InstrCallStack -> PairStruct -> [ExpandedOp]+expandUnpapair ics = \case+  P (F (v,f)) (F (w,g)) ->+    PrimEx <$> [ DUP noAnn+               , CAR v f+               , DIP [PrimEx $ CDR w g]+               ]+  P (F (v, f)) r ->+    PrimEx <$> [ DUP noAnn+               , CAR v f+               , DIP (PrimEx (CDR noAnn noAnn) : expandMacro ics (UNPAIR r))+               ]+  P l     (F (v, f))    ->+    map PrimEx [ DUP noAnn+               , DIP [PrimEx $ CDR v f]+               , CAR noAnn noAnn+               ] +++               expandMacro ics (UNPAIR l)+  P l      r ->+    expandMacro ics unpairOne +++    [PrimEx $ DIP $ expandMacro ics $ UNPAIR r] +++    expandMacro ics (UNPAIR l)+  F _                   -> [] -- Do nothing in this case.+  -- It's impossible from the structure of PairStruct and considered cases above,+  -- but if it accidentally happened let's just do nothing.+  where+    unpairOne = UNPAIR (P fn fn)+    fn = F (noAnn, noAnn)++expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]+expandCadr ics cs v f = case cs of+  []    -> []+  [A]  -> [PrimEx $ CAR v f]+  [D]  -> [PrimEx $ CDR v f]+  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 = CAR noAnn noAnn++cdrNoAnn :: InstrAbstract op+cdrNoAnn = CDR noAnn noAnn++pairNoAnn :: VarAnn -> InstrAbstract op+pairNoAnn v = PAIR noAnn v noAnn noAnn++expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]+expandSetCadr ics 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+           CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]+  [D]   -> [DUP noAnn, CDR noAnn f, DROP,+           -- ↑ These operations just check that the right element of pair has %f+           CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") 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]++expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]+expandMapCadr ics@InstrCallStack{icsCallStack=cls} cs v f ops = case cs of+  []    -> []+  [A]   -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, pairNoAnn v]+  [D]   -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, pairNoAnn v]]+  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]++expandTag :: Int -> NonEmpty Type -> [ExpandedOp]+expandTag idx unionTy =+  reverse . fst $ mkGenericTree merge (([], ) <$> unionTy)+  where+    merge i (li, lt) (ri, rt) =+      let ty = Type (TOr noAnn noAnn lt rt) noAnn+      in if idx < i+          then (PrimEx (LEFT noAnn noAnn noAnn noAnn rt) : li, ty)+          else (PrimEx (RIGHT noAnn noAnn noAnn noAnn lt) : ri, ty)++mapLeaves :: [(VarAnn, FieldAnn)] -> PairStruct -> PairStruct+mapLeaves fs p = evalState (leavesST p) fs++leavesST :: PairStruct -> State [(VarAnn, FieldAnn)] PairStruct+leavesST (P l r) = do+  l' <- leavesST l+  r' <- leavesST r+  return $ P l' r'+leavesST (F _) = do+  f <- state getLeaf+  return $ F f+  where+    getLeaf (a:as) = (a, as)+    getLeaf _      = ((noAnn, noAnn), [])++deriveJSON defaultOptions ''ParsedOp+deriveJSON defaultOptions ''LetMacro+deriveJSON defaultOptions ''PairStruct+deriveJSON defaultOptions ''CadrStruct+deriveJSON defaultOptions ''Macro
+ src/Michelson/Parser.hs view
@@ -0,0 +1,177 @@+module Michelson.Parser+  ( -- * Main parser type+    Parser++  -- * Parsers+  , program+  , value++  -- * Errors+  , CustomParserException (..)+  , ParseErrorBundle+  , ParserException (..)+  , StringLiteralParserException (..)++  -- * Additional helpers+  , parseNoEnv++  -- * For tests+  , codeEntry+  , type_+  , explicitType+  , letType+  , stringLiteral+  , bytesLiteral+  , intLiteral+  , printComment+  ) where++import Prelude hiding (try)++import Control.Applicative.Permutations (intercalateEffect, toPermutation)+import Text.Megaparsec (Parsec, choice, eitherP, getSourcePos, parse, try)+import Text.Megaparsec.Pos (SourcePos(..), unPos)++import Michelson.ErrorPos (SrcPos(..), mkPos)+import Michelson.Macro (LetMacro, Macro(..), ParsedInstr, ParsedOp(..), ParsedValue)+import Michelson.Parser.Error+import Michelson.Parser.Ext+import Michelson.Parser.Instr+import Michelson.Parser.Let+import Michelson.Parser.Lexer+import Michelson.Parser.Macro+import Michelson.Parser.Type+import Michelson.Parser.Types+import Michelson.Parser.Value+import Michelson.Untyped++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Parse with empty environment+parseNoEnv ::+     Parser a+  -> String+  -> Text+  -> Either (ParseErrorBundle Text CustomParserException) a+parseNoEnv p = parse (runReaderT p noLetEnv)++-------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------++-- Contract+------------------++-- | Michelson contract with let definitions+program :: Parsec CustomParserException Text (Contract' ParsedOp)+program = runReaderT programInner noLetEnv+  where+    programInner :: Parser (Contract' ParsedOp)+    programInner = do+      mSpace+      env <- fromMaybe noLetEnv <$> (optional (letBlock parsedOp))+      local (const env) contract++-- | Michelson contract+contract :: Parser (Contract' ParsedOp)+contract = do+  mSpace+  (p,s,c) <- intercalateEffect semicolon $+              (,,) <$> toPermutation parameter+                   <*> toPermutation storage+                   <*> toPermutation code+  return $ Contract p s c+  where+    parameter :: Parser Type+    parameter = symbol "parameter" *> explicitType++    storage :: Parser Type+    storage = symbol "storage" *> explicitType++    code :: Parser [ParsedOp]+    code = symbol "code" *> codeEntry+++-- Value+------------------++value :: Parser ParsedValue+value = value' parsedOp+++-- Primitive instruction+------------------++prim :: Parser ParsedInstr+prim = primInstr contract parsedOp++-- 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 = ops++parsedOp :: Parser ParsedOp+parsedOp = do+  lms <- asks letMacros+  pos <- getSrcPos+  choice+    [ flip Prim pos <$> (EXT <$> extInstr ops)+    , lmacWithPos (mkLetMac lms)+    , flip Prim pos <$> prim+    , flip Mac pos <$> macro parsedOp+    , primOrMac+    , flip Seq pos <$> ops+    ]+  where+    lmacWithPos :: Parser LetMacro -> Parser ParsedOp+    lmacWithPos act = do+      srcPos <- getSrcPos+      flip LMac srcPos <$> act++getSrcPos :: Parser SrcPos+getSrcPos = do+  sp <- getSourcePos+  let l = unPos $ sourceLine sp+  let c = unPos $ sourceColumn sp+  -- reindexing starting from 0+  pure $ SrcPos (mkPos $ l - 1) (mkPos $ c - 1)++primWithPos :: Parser ParsedInstr -> Parser ParsedOp+primWithPos act = do+  srcPos <- getSrcPos+  flip Prim srcPos <$> act++macWithPos :: Parser Macro -> Parser ParsedOp+macWithPos act = do+  srcPos <- getSrcPos+  flip Mac srcPos <$> act++ops :: Parser [ParsedOp]+ops = ops' parsedOp++-------------------------------------------------------------------------------+-- Mixed parsers+-- These are needed for better error messages+-------------------------------------------------------------------------------++ifOrIfX :: Parser ParsedOp+ifOrIfX = do+  pos <- getSrcPos+  symbol' "IF"+  a <- eitherP cmpOp ops+  case a of+    Left cmp -> flip Mac pos <$> (IFX cmp <$> ops <*> 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 = (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)+  <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))+  <|> (try (primWithPos pairOp) <|> macWithPos pairMac)
+ src/Michelson/Parser/Annotations.hs view
@@ -0,0 +1,83 @@+module Michelson.Parser.Annotations+  ( noteV+  , noteF+  , noteFDef+  , noteTDef+  , noteVDef+  , notesTVF+  , notesTVF2+  , notesTV+  , notesVF+  , fieldType+  , permute2Def+  , permute3Def+  ) where++import Prelude hiding (note)++import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)+import Data.Char (isAlpha, isAlphaNum, isAscii)+import qualified Data.Text as T+import Text.Megaparsec (satisfy, takeWhileP)+import Text.Megaparsec.Char (string)++import Michelson.Parser.Helpers (parseDef)+import Michelson.Parser.Lexer+import Michelson.Parser.Types (Parser)+import Michelson.Untyped as U+import Util.Default++-- General T/V/F Annotation parser+note :: T.Text -> Parser T.Text+note c = lexeme $ string c >> (note' <|> emptyNote)+  where+    emptyNote = pure ""+    note' = do+      a <- string "@"+           <|> string "%%"+           <|> string "%"+           <|> T.singleton <$> satisfy (\ x -> isAlpha x && isAscii x)+      let validChar x =+            isAscii x && (isAlphaNum x || x == '\\' || x == '.' || x == '_')+      b <- takeWhileP Nothing validChar+      return $ T.append a b++noteT :: Parser U.TypeAnn+noteT = U.ann <$> note ":"++noteV :: Parser U.VarAnn+noteV = U.ann <$> note "@"++noteF :: Parser U.FieldAnn+noteF = U.ann <$> note "%"++noteFDef :: Parser U.FieldAnn+noteFDef = parseDef noteF++noteF2 :: Parser (U.FieldAnn, U.FieldAnn)+noteF2 = do a <- noteF; b <- noteF; return (a, b)++noteTDef :: Parser U.TypeAnn+noteTDef = parseDef noteT++noteVDef :: Parser U.VarAnn+noteVDef = parseDef noteV++notesTVF :: Parser (U.TypeAnn, U.VarAnn, U.FieldAnn)+notesTVF = permute3Def noteT noteV noteF++notesTVF2 :: Parser (U.TypeAnn, U.VarAnn, (U.FieldAnn, U.FieldAnn))+notesTVF2 = permute3Def noteT noteV noteF2++notesTV :: Parser (U.TypeAnn, U.VarAnn)+notesTV = permute2Def noteT noteV++notesVF :: Parser (U.VarAnn, U.FieldAnn)+notesVF  = permute2Def noteV noteF++fieldType :: Default a+          => Parser a+          -> Parser (a, U.TypeAnn)+fieldType fp = runPermutation $+  (,) <$> toPermutationWithDefault  def     fp+      <*> toPermutationWithDefault U.noAnn noteT
+ src/Michelson/Parser/Error.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- |  Custom exceptions that can happen during parsing.++module Michelson.Parser.Error+  ( CustomParserException (..)+  , StringLiteralParserException (..)+  , ParseErrorBundle+  , ParserException (..)+  ) where++import Data.Data (Data(..))+import Fmt (Buildable(build))+import Text.Megaparsec (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty)+import qualified Text.Show (show)++data CustomParserException+  = UnknownTypeException+  | StringLiteralException StringLiteralParserException+  | OddNumberBytesException+  | ProhibitedLetType Text+  deriving stock (Eq, Data, Ord, Show)++instance ShowErrorComponent CustomParserException where+  showErrorComponent UnknownTypeException = "unknown type"+  showErrorComponent (StringLiteralException e) = showErrorComponent e+  showErrorComponent OddNumberBytesException = "odd number bytes"+  showErrorComponent (ProhibitedLetType t) =+    "prohibited name for type alias in let macros: " <> toString t++data StringLiteralParserException+  = InvalidEscapeSequence Char+  | InvalidChar Char+  deriving stock (Eq, Data, Ord, Show)++instance ShowErrorComponent StringLiteralParserException where+  showErrorComponent (InvalidEscapeSequence c) =+    "invalid escape sequence '\\" <> [c] <> "'"+  showErrorComponent (InvalidChar c) =+    "invalid character '" <> [c] <> "'"++data ParserException =+  ParserException (ParseErrorBundle Text CustomParserException)+  deriving (Eq)++instance Show ParserException where+  show (ParserException bundle) = errorBundlePretty bundle++instance Exception ParserException where+  displayException (ParserException bundle) = errorBundlePretty bundle++instance Buildable ParserException where+  build = build @String . show
+ src/Michelson/Parser/Ext.hs view
@@ -0,0 +1,69 @@+-- | Parsing logic for extra instructions (Morley extensions)++module Michelson.Parser.Ext+  ( extInstr+  , stackType++  -- * For tests+  , printComment+  ) where++import Prelude hiding (try)+++import Text.Megaparsec (choice, satisfy, try)+import Text.Megaparsec.Char (alphaNumChar, string)+import qualified Text.Megaparsec.Char.Lexer as L++import Michelson.Macro (ParsedOp(..), ParsedUExtInstr, ParsedUTestAssert)+import Michelson.Parser.Lexer+import Michelson.Parser.Type+import Michelson.Parser.Types (Parser)+import qualified Michelson.Untyped as U++extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr+extInstr opsParser = choice [stackOp, testAssertOp opsParser, printOp]++stackOp :: Parser ParsedUExtInstr+stackOp = symbol' "STACKTYPE" >> U.STACKTYPE <$> stackType++testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr+testAssertOp opsParser =+  symbol' "TEST_ASSERT" >> U.UTEST_ASSERT <$> testAssert opsParser++printOp :: Parser ParsedUExtInstr+printOp = symbol' "PRINT" >> U.UPRINT <$> printComment++testAssert :: Parser [ParsedOp] -> Parser ParsedUTestAssert+testAssert opsParser = do+  n <- lexeme (toText <$> some alphaNumChar)+  c <- printComment+  o <- opsParser+  return $ U.TestAssert n c o++printComment :: Parser U.PrintComment+printComment = do+  string "\""+  let validChar = toText <$> some (satisfy (\x -> x /= '%' && x /= '"'))+  c <- many (Right <$> stackRef <|> Left <$> validChar)+  symbol "\""+  return $ U.PrintComment c++stackRef :: Parser U.StackRef+stackRef = do+  string "%"+  n <- brackets' L.decimal+  return $ U.StackRef n++stackType :: Parser U.StackTypePattern+stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)+  where+    emptyStk = try $ symbol "]" >> return U.StkEmpty+    stkRest = try $ symbol "..." >> symbol "]" >> return U.StkRest+    stkCons = try $ do+      t <- tyVar+      s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk+      return $ U.StkCons t s++tyVar :: Parser U.TyVar+tyVar = (U.TyCon <$> type_) <|> (U.VarID <$> varID)
+ src/Michelson/Parser/Helpers.hs view
@@ -0,0 +1,32 @@+module Michelson.Parser.Helpers+  ( mkParser+  , sepEndBy1+  , sepBy2+  , parseDef+  ) where++import Data.Default (Default(..))+import qualified Data.List.NonEmpty as NE+import qualified Text.Megaparsec as P++import Michelson.Parser.Lexer (symbol')+import Michelson.Parser.Types (Parser)++sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)+sepEndBy1 = fmap NE.fromList ... P.sepEndBy1++-- | @endBy2 p sep@ parses two or more occurrences of @p@, separated by @sep@.+sepBy2 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)+sepBy2 parser sep = do+  e <- parser+  void sep+  es <- P.sepBy1 parser sep+  return $ e :| es++-- | Make a parser from a string+mkParser :: (a -> Text) -> a -> Parser a+mkParser f a = (P.try $ symbol' (f a)) >> return a++-- | Apply given parser and return default value if it fails.+parseDef :: Default a => Parser a -> Parser a+parseDef a = P.try a <|> pure def
+ src/Michelson/Parser/Instr.hs view
@@ -0,0 +1,336 @@+-- | Parsing of Michelson instructions.++module Michelson.Parser.Instr+  ( primInstr+  , ops'+  -- * These are handled separately to have better error messages+  , mapOp+  , pairOp+  , cmpOp+  ) where++import Prelude hiding (EQ, GT, LT, many, note, some, try)++import Text.Megaparsec (choice, sepEndBy, try)++import Michelson.Let (LetValue(..))+import Michelson.Macro (ParsedInstr, ParsedOp(..))+import Michelson.Parser.Annotations+import Michelson.Parser.Lexer+import Michelson.Parser.Type+import Michelson.Parser.Types (Parser, letValues)+import Michelson.Parser.Value+import Michelson.Untyped++-- | Parser for primitive Michelson instruction (no macros and extensions).+primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr+primInstr contractParser opParser = choice+  [ dropOp, dupOp, swapOp, pushOp opParser, someOp, noneOp, unitOp+  , ifNoneOp opParser, carOp, cdrOp, leftOp, rightOp, ifLeftOp opParser, nilOp+  , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, iterOp opParser+  , memOp, getOp, updateOp, loopLOp opParser, loopOp opParser+  , lambdaOp opParser, execOp, dipOp opParser, failWithOp, castOp, renameOp+  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, addOp, subOp+  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp+  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp+  , transferTokensOp, setDelegateOp, createAccountOp+  , createContractOp contractParser, implicitAccountOp, nowOp, amountOp+  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp+  , stepsToQuotaOp, sourceOp, senderOp+  ]++-- | Parse a sequence of instructions.+ops' :: Parser ParsedOp -> Parser [ParsedOp]+ops' opParser = braces $ sepEndBy opParser semicolon++-- Control Structures++failWithOp :: Parser ParsedInstr+failWithOp = do symbol' "FAILWITH"; return FAILWITH++loopOp :: Parser ParsedOp -> Parser ParsedInstr+loopOp opParser = do void $ symbol' "LOOP"; LOOP <$> ops' opParser++loopLOp :: Parser ParsedOp -> Parser ParsedInstr+loopLOp opParser = do void $ symbol' "LOOP_LEFT"; LOOP_LEFT <$> ops' opParser++execOp :: Parser ParsedInstr+execOp = do void $ symbol' "EXEC"; EXEC <$> noteVDef++dipOp :: Parser ParsedOp -> Parser ParsedInstr+dipOp opParser = do void $ symbol' "DIP"; DIP <$> ops' opParser++-- Stack Operations++dropOp :: Parser ParsedInstr+dropOp = do symbol' "DROP"; return DROP;++dupOp :: Parser ParsedInstr+dupOp = do void $ symbol' "DUP"; DUP <$> noteVDef++swapOp :: Parser ParsedInstr+swapOp = do symbol' "SWAP"; return SWAP;++pushOp :: Parser ParsedOp -> Parser ParsedInstr+pushOp opParser = do+  symbol' "PUSH"+  v <- noteVDef+  (try $ pushLet v) <|> (push' v)+  where+    pushLet v = do+      lvs <- asks letValues+      lv <- mkLetVal lvs+      return $ PUSH v (lvSig lv) (lvVal lv)+    push' v = PUSH v <$> type_ <*> value' opParser++unitOp :: Parser ParsedInstr+unitOp = do symbol' "UNIT"; (t, v) <- notesTV; return $ UNIT t v++lambdaOp :: Parser ParsedOp -> Parser ParsedInstr+lambdaOp opParser =+  symbol' "LAMBDA" *>+  (LAMBDA <$> noteVDef <*> type_ <*> type_ <*> ops' opParser)++-- Generic comparison++cmpOp :: Parser ParsedInstr+cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp++eqOp :: Parser ParsedInstr+eqOp = do void $ symbol' "EQ"; EQ <$> noteVDef++neqOp :: Parser ParsedInstr+neqOp = do void $ symbol' "NEQ"; NEQ <$> noteVDef++ltOp :: Parser ParsedInstr+ltOp = do void $ symbol' "LT"; LT <$> noteVDef++gtOp :: Parser ParsedInstr+gtOp = do void $ symbol' "GT"; GT <$> noteVDef++leOp :: Parser ParsedInstr+leOp = do void $ symbol' "LE"; LE <$> noteVDef++geOp :: Parser ParsedInstr+geOp = do void $ symbol' "GE"; GE <$> noteVDef++-- ad-hoc comparison++compareOp :: Parser ParsedInstr+compareOp = do void $ symbol' "COMPARE"; COMPARE <$> noteVDef++-- Operations on booleans++orOp :: Parser ParsedInstr+orOp = do void $ symbol' "OR";  OR <$> noteVDef++andOp :: Parser ParsedInstr+andOp = do void $ symbol' "AND"; AND <$> noteVDef++xorOp :: Parser ParsedInstr+xorOp = do void $ symbol' "XOR"; XOR <$> noteVDef++notOp :: Parser ParsedInstr+notOp = do void $ symbol' "NOT"; NOT <$> noteVDef++-- Operations on integers and natural numbers++addOp :: Parser ParsedInstr+addOp = do void $ symbol' "ADD"; ADD <$> noteVDef++subOp :: Parser ParsedInstr+subOp = do void $ symbol' "SUB"; SUB <$> noteVDef++mulOp :: Parser ParsedInstr+mulOp = do void $ symbol' "MUL"; MUL <$> noteVDef++edivOp :: Parser ParsedInstr+edivOp = do void $ symbol' "EDIV";EDIV <$> noteVDef++absOp :: Parser ParsedInstr+absOp = do void $ symbol' "ABS"; ABS <$> noteVDef++negOp :: Parser ParsedInstr+negOp = do symbol' "NEG"; return NEG;++-- Bitwise logical operators++lslOp :: Parser ParsedInstr+lslOp = do void $ symbol' "LSL"; LSL <$> noteVDef++lsrOp :: Parser ParsedInstr+lsrOp = do void $ symbol' "LSR"; LSR <$> noteVDef++-- Operations on string's++concatOp :: Parser ParsedInstr+concatOp = do void $ symbol' "CONCAT"; CONCAT <$> noteVDef++sliceOp :: Parser ParsedInstr+sliceOp = do void $ symbol' "SLICE"; SLICE <$> noteVDef++-- Operations on pairs+pairOp :: Parser ParsedInstr+pairOp = do symbol' "PAIR"; (t, v, (p, q)) <- notesTVF2; return $ PAIR t v p q++carOp :: Parser ParsedInstr+carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ CAR v f++cdrOp :: Parser ParsedInstr+cdrOp = do symbol' "CDR"; (v, f) <- notesVF; return $ CDR v f++-- Operations on collections (sets, maps, lists)++emptySetOp :: Parser ParsedInstr+emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;+                EMPTY_SET t v <$> comparable++emptyMapOp :: Parser ParsedInstr+emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- comparable;+                EMPTY_MAP t v a <$> type_++memOp :: Parser ParsedInstr+memOp = do void $ symbol' "MEM"; MEM <$> noteVDef++updateOp :: Parser ParsedInstr+updateOp = do symbol' "UPDATE"; return UPDATE++iterOp :: Parser ParsedOp -> Parser ParsedInstr+iterOp opParser = do void $ symbol' "ITER"; ITER <$> ops' opParser++sizeOp :: Parser ParsedInstr+sizeOp = do void $ symbol' "SIZE"; SIZE <$> noteVDef++mapOp :: Parser ParsedOp -> Parser ParsedInstr+mapOp opParser = do symbol' "MAP"; v <- noteVDef; MAP v <$> ops' opParser++getOp :: Parser ParsedInstr+getOp = do void $ symbol' "GET"; GET <$> noteVDef++nilOp :: Parser ParsedInstr+nilOp = do symbol' "NIL"; (t, v) <- notesTV; NIL t v <$> type_++consOp :: Parser ParsedInstr+consOp = do void $ symbol' "CONS"; CONS <$> noteVDef++ifConsOp :: Parser ParsedOp -> Parser ParsedInstr+ifConsOp opParser =+  symbol' "IF_CONS" *>+  (IF_CONS <$> ops' opParser <*> ops' opParser)++-- Operations on options++someOp :: Parser ParsedInstr+someOp = do symbol' "SOME"; (t, v, f) <- notesTVF; return $ SOME t v f++noneOp :: Parser ParsedInstr+noneOp = do symbol' "NONE"; (t, v, f) <- notesTVF; NONE t v f <$> type_++ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr+ifNoneOp opParser =+  symbol' "IF_NONE" *>+  (IF_NONE <$> ops' opParser <*> ops' opParser)++-- Operations on unions++leftOp :: Parser ParsedInstr+leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2;+               LEFT t v f f' <$> type_++rightOp :: Parser ParsedInstr+rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2;+               RIGHT t v f f' <$> type_++ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr+ifLeftOp opParser = do+  symbol' "IF_LEFT"+  a <- ops' opParser+  IF_LEFT a <$> ops' opParser++-- Operations on contracts++createContractOp :: Parser (Contract' ParsedOp) -> Parser ParsedInstr+createContractOp contractParser =+  symbol' "CREATE_CONTRACT" *>+  (CREATE_CONTRACT <$> noteVDef <*> noteVDef <*> braces contractParser)++createAccountOp :: Parser ParsedInstr+createAccountOp = do symbol' "CREATE_ACCOUNT"; v <- noteVDef; v' <- noteVDef;+                       return $ CREATE_ACCOUNT v v'++transferTokensOp :: Parser ParsedInstr+transferTokensOp = do void $ symbol' "TRANSFER_TOKENS"; TRANSFER_TOKENS <$> noteVDef++setDelegateOp :: Parser ParsedInstr+setDelegateOp = do void $ symbol' "SET_DELEGATE"; SET_DELEGATE <$> noteVDef++balanceOp :: Parser ParsedInstr+balanceOp = do void $ symbol' "BALANCE"; BALANCE <$> noteVDef++contractOp :: Parser ParsedInstr+contractOp = do void $ symbol' "CONTRACT"; CONTRACT <$> noteVDef <*> type_++sourceOp :: Parser ParsedInstr+sourceOp = do void $ symbol' "SOURCE"; SOURCE <$> noteVDef++senderOp :: Parser ParsedInstr+senderOp = do void $ symbol' "SENDER"; SENDER <$> noteVDef++amountOp :: Parser ParsedInstr+amountOp = do void $ symbol' "AMOUNT"; AMOUNT <$> noteVDef++implicitAccountOp :: Parser ParsedInstr+implicitAccountOp = do void $ symbol' "IMPLICIT_ACCOUNT"; IMPLICIT_ACCOUNT <$> noteVDef++selfOp :: Parser ParsedInstr+selfOp = do void $ symbol' "SELF"; SELF <$> noteVDef++addressOp :: Parser ParsedInstr+addressOp = do void $ symbol' "ADDRESS"; ADDRESS <$> noteVDef++-- Special Operations++nowOp :: Parser ParsedInstr+nowOp = do void $ symbol' "NOW"; NOW <$> noteVDef++stepsToQuotaOp :: Parser ParsedInstr+stepsToQuotaOp = do void $ symbol' "STEPS_TO_QUOTA"; STEPS_TO_QUOTA <$> noteVDef++-- Operations on bytes++packOp :: Parser ParsedInstr+packOp = do void $ symbol' "PACK"; PACK <$> noteVDef++unpackOp :: Parser ParsedInstr+unpackOp = do symbol' "UNPACK"; v <- noteVDef; UNPACK v <$> type_++-- Cryptographic Primitives++checkSigOp :: Parser ParsedInstr+checkSigOp = do void $ symbol' "CHECK_SIGNATURE"; CHECK_SIGNATURE <$> noteVDef++blake2BOp :: Parser ParsedInstr+blake2BOp = do void $ symbol' "BLAKE2B"; BLAKE2B <$> noteVDef++sha256Op :: Parser ParsedInstr+sha256Op = do void $ symbol' "SHA256"; SHA256 <$> noteVDef++sha512Op :: Parser ParsedInstr+sha512Op = do void $ symbol' "SHA512"; SHA512 <$> noteVDef++hashKeyOp :: Parser ParsedInstr+hashKeyOp = do void $ symbol' "HASH_KEY"; HASH_KEY <$> noteVDef++-- Type operations++castOp :: Parser ParsedInstr+castOp = do void $ symbol' "CAST"; CAST <$> noteVDef <*> type_;++renameOp :: Parser ParsedInstr+renameOp = do void $ symbol' "RENAME"; RENAME <$> noteVDef++isNatOp :: Parser ParsedInstr+isNatOp = do void $ symbol' "ISNAT"; ISNAT <$> noteVDef++intOp :: Parser ParsedInstr+intOp = do void $ symbol' "INT"; INT <$> noteVDef
+ src/Michelson/Parser/Let.hs view
@@ -0,0 +1,115 @@+-- | Parsing of let blocks++module Michelson.Parser.Let+  ( letBlock+  , mkLetMac+  -- * For tests+  , letType+  ) where++import Prelude hiding (try)++import qualified Data.Char as Char+import qualified Data.Map as Map+import qualified Data.Set as Set++import Text.Megaparsec (choice, customFailure, satisfy, try)+import Text.Megaparsec.Char (lowerChar, upperChar)++import Michelson.Let (LetValue(..), LetType(..))+import Michelson.Macro (ParsedOp(..), LetMacro(..))+import Michelson.Parser.Error+import Michelson.Parser.Ext+import Michelson.Parser.Helpers+import Michelson.Parser.Instr+import Michelson.Parser.Lexer+import Michelson.Parser.Type+import Michelson.Parser.Types (LetEnv(..), Parser, noLetEnv)+import Michelson.Parser.Value+import Michelson.Untyped (StackFn(..), Type(..), ann, noAnn)++-- | Element of a let block+data Let = LetM LetMacro | LetV LetValue | LetT LetType++-- | let block parser+letBlock :: Parser ParsedOp -> Parser LetEnv+letBlock opParser = do+  symbol "let"+  symbol "{"+  ls <- local (const noLetEnv) (letInner opParser)+  symbol "}"+  semicolon+  return ls++-- | Incrementally build the let environment+letInner :: Parser ParsedOp -> Parser LetEnv+letInner opParser = do+  env <- ask+  l <- lets opParser+  semicolon+  local (addLet l) (letInner opParser) <|> return (addLet l env)++-- | add a Let to the environment in the correct place+addLet :: Let -> LetEnv -> LetEnv+addLet l (LetEnv lms lvs lts) = case l of+  LetM lm -> LetEnv (Map.insert (lmName lm) lm lms) lvs lts+  LetV lv -> LetEnv lms (Map.insert (lvName lv) lv lvs) lts+  LetT lt -> LetEnv lms lvs (Map.insert (ltName lt) lt lts)++lets :: Parser ParsedOp -> Parser Let+lets opParser = choice+  [ (LetM <$> (try $ letMacro opParser))+  , (LetV <$> (try $ letValue opParser))+  , (LetT <$> (try letType))+  ]++-- | build a let name parser from a leading character parser+letName :: Parser Char -> Parser Text+letName p = lexeme $ do+  v <- p+  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')+  vs <- many (satisfy validChar)+  return $ toText (v:vs)++letMacro :: Parser ParsedOp -> Parser LetMacro+letMacro opParser = lexeme $ do+  n <- letName lowerChar+  symbol "::"+  s <- stackFn+  symbol "="+  o <- ops' opParser+  return $ LetMacro n s o++letType :: Parser LetType+letType = lexeme $ do+  symbol "type"+  n <- letName upperChar <|> letName lowerChar+  when (n == "Parameter" || n == "Storage") (customFailure $ ProhibitedLetType n)+  symbol "="+  t <- type_+  case t of+    (Type t' a) ->+      if a == noAnn+      then return $ LetType n (Type t' (ann n))+      else return $ LetType n t+    _ -> return $ LetType n t++letValue :: Parser ParsedOp -> Parser LetValue+letValue opParser = lexeme $ do+  n <- letName upperChar+  symbol "::"+  t <- type_+  symbol "="+  v <- value' opParser+  return $ LetValue n t v++mkLetMac :: Map Text LetMacro -> Parser LetMacro+mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms)++stackFn :: Parser StackFn+stackFn = do+  vs <- (optional (symbol "forall" >> some varID <* symbol "."))+  a <- stackType+  symbol "->"+  b <- stackType+  return $ StackFn (Set.fromList <$> vs) a b
+ src/Michelson/Parser/Lexer.hs view
@@ -0,0 +1,66 @@+module Michelson.Parser.Lexer+  ( lexeme+  , mSpace+  , symbol+  , symbol'+  , string'+  , parens+  , braces+  , brackets+  , brackets'+  , semicolon+  , comma+  , varID+  ) where++import Data.Char (isDigit, isLower, toLower)+import qualified Data.Text as T+import Text.Megaparsec (MonadParsec, Tokens, between, satisfy)+import Text.Megaparsec.Char (lowerChar, space1, string)+import qualified Text.Megaparsec.Char.Lexer as L++import Michelson.Parser.Types (Parser)+import qualified Michelson.Untyped as U++-- Lexing+lexeme :: Parser a -> Parser a+lexeme = L.lexeme mSpace++mSpace :: Parser ()+mSpace = L.space space1 (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")++symbol :: Tokens Text -> Parser ()+symbol = void . L.symbol mSpace++symbol' :: Text -> Parser ()+symbol' str = void $ symbol str <|> symbol (T.map toLower str)++string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text+string' str = string str <|> string (T.map toLower str)++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++brackets' :: Parser a -> Parser a+brackets' = between (string "[") (string "]")++semicolon :: Parser ()+semicolon = symbol ";"++comma :: Parser ()+comma = symbol ","++varID :: Parser U.Var+varID = lexeme $ do+  v <- lowerChar+  vs <- many lowerAlphaNumChar+  return $ U.Var (toText (v:vs))+  where+    lowerAlphaNumChar :: Parser Char+    lowerAlphaNumChar = satisfy (\x -> isLower x || isDigit x)
+ src/Michelson/Parser/Macro.hs view
@@ -0,0 +1,124 @@+-- | Parsing of built-in Michelson macros.++module Michelson.Parser.Macro+  ( macro+  -- * These are handled separately to have better error messages+  , pairMac+  , ifCmpMac+  , mapCadrMac+  ) where++import Prelude hiding (try)++import Fmt ((+|), (+||), (|+), (||+))+import Text.Megaparsec (notFollowedBy, try)+import Text.Megaparsec.Char.Lexer (decimal)++import Michelson.Macro (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..))+import qualified Michelson.Macro as Macro+import Michelson.Parser.Annotations+import Michelson.Parser.Instr+import Michelson.Parser.Lexer+import Michelson.Parser.Type+import Michelson.Parser.Types (Parser)+import Michelson.Untyped (T(..), Type(..), noAnn)+import Util.Alternative (someNE)++macro :: Parser ParsedOp -> Parser Macro+macro opParser =+      do symbol' "CASE"; is <- someNE ops; return $ CASE is+  <|> do symbol' "TAG"; tagMac+  <|> do symbol' "VIEW"; a <- ops; return $ VIEW a+  <|> do symbol' "VOID"; a <- ops; return $ VOID a+  <|> do symbol' "CMP"; a <- cmpOp; CMP a <$> noteVDef+  <|> do void $ symbol' "IF_SOME"; IF_SOME <$> ops <*> ops+  <|> do void $ symbol' "IF_RIGHT"; IF_RIGHT <$> ops <*> ops+  <|> do symbol' "FAIL"; return FAIL+  <|> do void $ symbol' "ASSERT_CMP"; ASSERT_CMP <$> cmpOp+  <|> do symbol' "ASSERT_NONE"; return ASSERT_NONE+  <|> do symbol' "ASSERT_SOME"; return ASSERT_SOME+  <|> do symbol' "ASSERT_LEFT"; return ASSERT_LEFT+  <|> do symbol' "ASSERT_RIGHT"; return ASSERT_RIGHT+  <|> do void $ symbol' "ASSERT_"; ASSERTX <$> cmpOp+  <|> do symbol' "ASSERT"; return ASSERT+  <|> do string' "DI"; n <- num "I"; symbol' "P"; DIIP (n + 1) <$> ops+  <|> do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteVDef+  <|> unpairMac+  <|> cadrMac+  <|> setCadrMac+  where+   ops = ops' opParser+   num str = fromIntegral . length <$> some (string' str)++pairMac :: Parser Macro+pairMac = do+  a <- pairMacInner+  symbol' "R"+  (tn, vn, fns) <- permute3Def noteTDef noteV (some noteF)+  let ps = Macro.mapLeaves ((noAnn,) <$> fns) a+  return $ PAPAIR ps tn vn++pairMacInner :: Parser PairStruct+pairMacInner = do+  string' "P"+  l <- (string' "A" >> return (F (noAnn, noAnn))) <|> pairMacInner+  r <- (string' "I" >> return (F (noAnn, noAnn))) <|> pairMacInner+  return $ P l r++unpairMac :: Parser Macro+unpairMac = do+  string' "UN"+  a <- pairMacInner+  symbol' "R"+  (vns, fns) <- permute2Def (some noteV) (some noteF)+  return $ UNPAIR (Macro.mapLeaves (zip vns fns) a)++cadrMac :: Parser Macro+cadrMac = lexeme $ do+  string' "C"+  a <- some $ try $ cadrInner <* notFollowedBy (string' "R")+  b <- cadrInner+  symbol' "R"+  (vn, fn) <- notesVF+  return $ CADR (a ++ pure b) vn fn++cadrInner :: Parser CadrStruct+cadrInner = (string' "A" >> return A) <|> (string' "D" >> return D)++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}+setCadrMac :: Parser Macro+setCadrMac = do+  string' "SET_C"+  a <- some cadrInner+  symbol' "R"+  (v, f) <- notesVF+  return $ SET_CADR a v f++mapCadrMac :: Parser ParsedOp -> Parser Macro+mapCadrMac opParser = do+  string' "MAP_C"+  a <- some cadrInner+  symbol' "R"+  (v, f) <- notesVF+  MAP_CADR a v f <$> ops' opParser++ifCmpMac :: Parser ParsedOp -> Parser Macro+ifCmpMac opParser =+  symbol' "IFCMP" *>+  (IFCMP <$> cmpOp <*> noteVDef <*> ops' opParser <*> ops' opParser)++tagMac :: Parser Macro+tagMac = do+  idx <- decimal+  mSpace+  ty <- type_+  let utys = unrollUnion ty []+  when (idx >= fromIntegral (length utys)) $+    fail $ "TAG: too large index: " +|| idx ||+ " \+           \exceedes size of union " +| toList utys |+ ""+  return $ TAG idx utys+  where+  unrollUnion ty =+    case ty of+      Type (TOr _ _ l r) _ -> unrollUnion l . toList . unrollUnion r+      _ -> (ty :|)
+ src/Michelson/Parser/Type.hs view
@@ -0,0 +1,267 @@+-- | Parsing of Michelson types.++module Michelson.Parser.Type+  ( type_+  , explicitType+  , comparable+  ) where++import Prelude hiding (many, note, some, try)++import Data.Default (Default)+import qualified Data.Map as Map+import Text.Megaparsec (choice, customFailure, try)++import Michelson.Let (LetType(..))+import Michelson.Parser.Annotations+import Michelson.Parser.Error+import Michelson.Parser.Helpers+import Michelson.Parser.Lexer+import Michelson.Parser.Types (Parser, letTypes)+import Michelson.Untyped+import Util.Generic++-- | Parse untyped Michelson 'Type` (i. e. one with annotations).+type_ :: Parser Type+type_ = typeHelper implicitTypes++-- | Parse only explicit `Type`, `Parameter` and `Storage` are prohibited+explicitType :: Parser Type+explicitType = typeHelper empty++typeHelper :: Parser Type -> Parser Type+typeHelper implicitParser = ti <|> parens ti <|> customFailure UnknownTypeException+  where+    ti = snd <$> (lexeme $ typeInner implicitParser (pure noAnn)) <|> implicitParser++typeInner+  :: Parser Type+  -> Parser FieldAnn -> Parser (FieldAnn, Type)+typeInner implicit fp = choice $ (\x -> x fp) <$>+  [ t_ct, t_key, t_unit, t_signature, t_option implicit, t_list implicit, t_set+  , t_operation, t_contract implicit, t_pair implicit, t_or implicit+  , t_lambda implicit, t_map implicit, t_big_map implicit, t_view implicit+  , t_void implicit, t_letType+  ]++implicitTypes :: Parser Type+implicitTypes = choice [t_parameter, t_storage]++----------------------------------------------------------------------------+-- Comparable types+----------------------------------------------------------------------------++comparable :: Parser Comparable+comparable = let c = do ct' <- ct; Comparable ct' <$> noteTDef in parens c <|> c++t_parameter :: Parser Type+t_parameter = do void $ symbol' "Parameter"; return TypeParameter++t_storage :: Parser Type+t_storage = do void $ symbol' "Storage"; return TypeStorage++t_ct :: (Default a) => Parser a -> Parser (a, Type)+t_ct fp = do ct' <- ct; (f,t) <- fieldType fp; return (f, Type (Tc ct') t)++ct :: Parser CT+ct =  (symbol' "Int" >> return CInt)+  <|> (symbol' "Nat" >> return CNat)+  <|> (symbol' "String" >> return CString)+  <|> (symbol' "Bytes" >> return CBytes)+  <|> (symbol' "Mutez" >> return CMutez)+  <|> (symbol' "Bool" >> return CBool)+  <|> ((symbol' "KeyHash" <|> symbol "key_hash") >> return CKeyHash)+  <|> (symbol' "Timestamp" >> return CTimestamp)+  <|> (symbol' "Address" >> return CAddress)++----------------------------------------------------------------------------+-- Non-comparable types+----------------------------------------------------------------------------++field :: Parser Type -> Parser (FieldAnn, Type)+field implicit = lexeme (fi <|> parens fi)+  where+    fi = typeInner implicit noteF++t_key :: (Default a) => Parser a -> Parser (a, Type)+t_key fp = do symbol' "Key"; (f,t) <- fieldType fp; return (f, Type TKey t)++t_signature :: (Default a) => Parser a -> Parser (a, Type)+t_signature fp = do symbol' "Signature"; (f, t) <- fieldType fp; return (f, Type TSignature t)++t_operation :: (Default a) => Parser a -> Parser (a, Type)+t_operation fp = do symbol' "Operation"; (f, t) <- fieldType fp; return (f, Type TOperation t)++t_contract :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_contract implicit fp = do+  symbol' "Contract"+  (f, t) <- fieldType fp+  a <- typeHelper implicit+  return (f, Type (TContract a) t)++t_unit :: (Default a) => Parser a -> Parser (a, Type)+t_unit fp = do+  symbol' "Unit" <|> symbol "()"+  (f,t) <- fieldType fp+  return (f, Type TUnit t)++t_pair_like+  :: (Default a)+  => (FieldAnn -> FieldAnn -> Type -> Type -> T)+  -> Parser Type+  -> Parser a+  -> Parser (a, Type)+t_pair_like mkPair implicit fp = do+  (f, t) <- fieldType fp+  (l, a) <- implicitF+  (r, b) <- implicitF+  return (f, Type (mkPair l r a b) t)+  where+    implicitF = field implicit <|> (,) <$> noteFDef <*> implicit++t_pair :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_pair implicit fp = core <|> tuple+  where+    core = do+      symbol' "Pair"+      t_pair_like TPair implicit fp+    tuple = try $ do+      symbol "("+      (l, r, a, b) <- typePair+      symbol ")"+      (f, t) <- fieldType fp+      return (f, Type (TPair l r a b) t)+    tupleInner = try $ do+      (l, r, a, b) <- typePair+      return (noAnn, Type (TPair l r a b) noAnn)+    implicitF = field implicit <|> (,) <$> noteFDef <*> implicit+    typePair = do+      (l, a) <- implicitF+      comma+      (r, b) <- tupleInner <|> implicitF+      return (l, r, a, b)++t_or :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_or implicit fp = core <|> bar+  where+    core = do+      symbol' "Or"+      t_pair_like TOr implicit fp+    bar = try $ do+      symbol "("+      (_, Type ty _) <- barInner+      symbol ")"+      (f, t) <- fieldType fp+      return (f, Type ty t)+    barInner = do+      fs <- sepBy2 implicitF (symbol "|")+      let mergeTwo _ (l, a) (r, b) = (noAnn, Type (TOr l r a b) noAnn)+      return $ mkGenericTree mergeTwo fs+    implicitF = field implicit <|> (,) <$> noteFDef <*> implicit++t_option :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_option implicit fp = do+  symbol' "Option"+  (f, t) <- fieldType fp+  (fa, a) <- field implicit <|> (,) <$> noteFDef <*> implicit+  return (f, Type (TOption fa a) t)++t_lambda :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_lambda implicit fp = core <|> slashLambda+  where+    core = do+      symbol' "Lambda"+      (f, t) <- fieldType fp+      a <- implicitType+      b <- implicitType+      return (f, Type (TLambda a b) t)+    slashLambda = do+      symbol "\\"+      (f, t) <- fieldType fp+      a <- implicitType+      symbol "->"+      b <- implicitType+      return (f, Type (TLambda a b) t)+    implicitType = typeHelper implicit++-- Container types+t_list :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_list implicit fp = core <|> bracketList+  where+    core = do+      symbol' "List"+      (f, t) <- fieldType fp+      a <- typeHelper implicit+      return (f, Type (TList a) t)+    bracketList = do+      a <- brackets (typeHelper implicit)+      (f, t) <- fieldType fp+      return (f, Type (TList a) t)++t_set :: (Default a) => Parser a -> Parser (a, Type)+t_set fp = core <|> braceSet+  where+    core = do+      symbol' "Set"+      (f, t) <- fieldType fp+      a <- comparable+      return (f, Type (TSet a) t)+    braceSet = do+      a <- braces comparable+      (f, t) <- fieldType fp+      return (f, Type (TSet a) t)++t_map_like+  :: Default a+  => Parser Type -> Parser a -> Parser (Comparable, Type, a, TypeAnn)+t_map_like implicit fp = do+  (f, t) <- fieldType fp+  a <- comparable+  b <- typeHelper implicit+  return (a, b, f, t)++t_map :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_map implicit fp = do+  symbol' "Map"+  (a, b, f, t) <- t_map_like implicit fp+  return (f, Type (TMap a b) t)++t_big_map :: (Default a) => Parser Type -> Parser a -> Parser (a, Type)+t_big_map implicit fp = do+  symbol' "BigMap" <|> symbol "big_map"+  (a, b, f, t) <- t_map_like implicit fp+  return (f, Type (TBigMap a b) t)++----------------------------------------------------------------------------+-- Non-standard types (Morley extensions)+----------------------------------------------------------------------------++t_view :: Default a => Parser Type -> Parser a -> Parser (a, Type)+t_view implicit fp = do+  symbol' "View"+  a <- typeHelper implicit+  r <- typeHelper implicit+  (f, t) <- fieldType fp+  let r' = Type (TOption noAnn r) noAnn+  let c = Type (TPair noAnn noAnn a r') noAnn+  let c' = Type (TContract c) noAnn+  return (f, Type (TPair noAnn noAnn a c') t)++t_void :: Default a => Parser Type -> Parser a -> Parser (a, Type)+t_void implicit fp = do+  symbol' "Void"+  a <- typeHelper implicit+  b <- typeHelper implicit+  (f, t) <- fieldType fp+  let c = Type (TLambda b b) noAnn+  return (f, Type (TPair noAnn noAnn a c) t)++t_letType :: Default fp => Parser fp -> Parser (fp, Type)+t_letType fp = do+  lts <- asks letTypes+  lt <- ltSig <$> (mkLetType lts)+  f <- parseDef fp+  return (f, lt)++mkLetType :: Map Text LetType -> Parser LetType+mkLetType lts = choice $ mkParser ltName <$> (Map.elems lts)
+ src/Michelson/Parser/Types.hs view
@@ -0,0 +1,30 @@+-- | Core parser types++module Michelson.Parser.Types+  ( Parser+  , LetEnv (..)+  , noLetEnv+  ) where++import Data.Default (Default(..))+import qualified Data.Map as Map+import Text.Megaparsec (Parsec)++import Michelson.Parser.Error+import Michelson.Let (LetType, LetValue)+import Michelson.Macro (LetMacro)++type Parser = ReaderT LetEnv (Parsec CustomParserException Text)++instance Default a => Default (Parser a) where+  def = pure def++-- | The environment containing lets from the let-block+data LetEnv = LetEnv+  { letMacros :: Map Text LetMacro+  , letValues :: Map Text LetValue+  , letTypes  :: Map Text LetType+  } deriving (Show, Eq)++noLetEnv :: LetEnv+noLetEnv = LetEnv Map.empty Map.empty Map.empty
+ src/Michelson/Parser/Value.hs view
@@ -0,0 +1,150 @@+-- | Parsing of untyped Michelson values.++module Michelson.Parser.Value+  ( value'+  , mkLetVal++  -- * For tests+  , stringLiteral+  , bytesLiteral+  , intLiteral+  ) where++import Prelude hiding (many, note, some, try)++import qualified Data.ByteString.Base16 as B16+import qualified Data.Char as Char+import qualified Data.Map as Map++import Text.Megaparsec (anySingle, choice, customFailure, manyTill, satisfy, takeWhileP, try)+import Text.Megaparsec.Char (char, string)+import qualified Text.Megaparsec.Char.Lexer as L++import Michelson.Let (LetValue(..))+import Michelson.Macro (ParsedOp, ParsedValue)+import Michelson.Parser.Error+import Michelson.Parser.Helpers+import Michelson.Parser.Lexer+import Michelson.Parser.Types (Parser, letValues)+import Michelson.Text (isMChar, mkMTextUnsafe)+import qualified Michelson.Untyped as U++-- | 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 = lexeme $ valueInner' <|> parens valueInner'+  where+    valueInner' = valueInner opParser++valueInner :: Parser ParsedOp -> Parser ParsedValue+valueInner opParser = choice $+  [ stringLiteral, bytesLiteral, intLiteral, unitValue+  , trueValue, falseValue, pairValue opParser, leftValue opParser+  , rightValue opParser, someValue opParser, noneValue, nilValue+  , seqValue opParser, mapValue opParser, lambdaValue opParser, dataLetValue+  ]++stringLiteral :: Parser ParsedValue+stringLiteral = U.ValueString . mkMTextUnsafe . toText <$> do+  _ <- try $ string "\""+  manyTill validChar (string "\"")+  where+      validChar :: Parser Char+      validChar = choice+        [ strEscape+        , satisfy (\x -> x /= '"' && isMChar x)+        , anySingle >>= stringLiteralFailure . InvalidChar+        ]++      strEscape :: Parser Char+      strEscape = try (char '\\') >> esc+        where+          esc = choice+            [ char '\\'+            , char '"'+            , char 'n' $> '\n'+            , anySingle >>= stringLiteralFailure . InvalidEscapeSequence+            ]+      stringLiteralFailure = customFailure . StringLiteralException++-- 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 = do+  symbol "0x"+  hexdigits <- takeWhileP Nothing Char.isHexDigit+  let (bytes, remain) = B16.decode $ encodeUtf8 hexdigits+  if remain == ""+  then return . U.ValueBytes . U.InternalByteString $ bytes+  else customFailure OddNumberBytesException++intLiteral :: Parser (U.Value' op)+intLiteral = try $ U.ValueInt <$> L.signed pass L.decimal++unitValue :: Parser ParsedValue+unitValue = do symbol "Unit"; return U.ValueUnit++trueValue :: Parser ParsedValue+trueValue = do symbol "True"; return U.ValueTrue++falseValue :: Parser ParsedValue+falseValue = do symbol "False"; return U.ValueFalse++pairValue :: Parser ParsedOp -> Parser ParsedValue+pairValue opParser = core <|> tuple+  where+    core = do+      void $ symbol "Pair"+      a <- value' opParser+      U.ValuePair a <$> value' opParser+    tuple = try $ do+      symbol "("+      ty <- tupleInner+      symbol ")"+      return ty+    tupleInner = try $ do+      a <- value' opParser+      comma+      b <- tupleInner <|> value' opParser+      return $ U.ValuePair a b++leftValue :: Parser ParsedOp -> Parser ParsedValue+leftValue opParser = do void $ symbol "Left"; U.ValueLeft <$> value' opParser++rightValue :: Parser ParsedOp -> Parser ParsedValue+rightValue opParser = do void $ symbol "Right"; U.ValueRight <$> value' opParser++someValue :: Parser ParsedOp -> Parser ParsedValue+someValue opParser = do void $ symbol "Some"; U.ValueSome <$> value' opParser++noneValue :: Parser ParsedValue+noneValue = U.ValueNone <$ symbol "None"++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++seqValue :: Parser ParsedOp -> Parser ParsedValue+seqValue opParser =+  U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon)++eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)+eltValue opParser = do+  void $ symbol "Elt"+  U.Elt <$> value' opParser <*> value' opParser++mapValue :: Parser ParsedOp -> Parser ParsedValue+mapValue opParser = U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)++dataLetValue :: Parser ParsedValue+dataLetValue = do+  lvs <- asks letValues+  lvVal <$> (mkLetVal lvs)++mkLetVal :: Map Text LetValue -> Parser LetValue+mkLetVal lvs = choice $ mkParser lvName <$> Map.elems lvs
src/Michelson/Printer.hs view
@@ -2,14 +2,22 @@   ( RenderDoc(..)   , printDoc   , printUntypedContract+  , printTypedContract   ) where +import Data.Singletons (SingI) import qualified Data.Text.Lazy as TL  import Michelson.Printer.Util (RenderDoc(..), printDoc)-import qualified Michelson.Untyped as Un+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U  -- | Convert an untyped contract into a textual representation which -- will be accepted by the OCaml reference client.-printUntypedContract :: (RenderDoc op) => Un.Contract op -> TL.Text+printUntypedContract :: (RenderDoc op) => U.Contract' op -> TL.Text printUntypedContract = printDoc . renderDoc++-- | Convert a typed contract into a textual representation which+-- will be accepted by the OCaml reference client.+printTypedContract :: (SingI p, SingI s) => T.Contract p s -> TL.Text+printTypedContract = printUntypedContract . T.convertContract
src/Michelson/Printer/Util.hs view
@@ -40,7 +40,7 @@  spacecat :: NonEmpty Doc -> Doc spacecat = foldr (<+>) mempty-  + renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc renderOpsList oneLine ops =   braces $ cat' $ punctuate semi (renderDoc <$> filter isRenderable ops)
+ src/Michelson/Runtime.hs view
@@ -0,0 +1,508 @@+-- | Interpreter and typechecker of a contract in Morley language.++module Michelson.Runtime+       (+         -- * High level interface for end user+         originateContract+       , runContract+       , transfer++       -- * Other helpers+       , parseContract+       , parseExpandContract+       , readAndParseContract+       , prepareContract+       , typeCheckWithDb++       -- * Re-exports+       , ContractState (..)+       , AddressState (..)+       , TxData (..)++       -- * For testing+       , InterpreterOp (..)+       , InterpreterRes (..)+       , InterpreterError' (..)+       , InterpreterError+       , interpreterPure++       -- * To avoid warnings (can't generate lenses only for some fields)+       , irInterpretResults+       , irUpdates+       ) where++import Control.Lens (at, makeLenses, (%=))+import Control.Monad.Except (Except, runExcept, throwError)+import Data.Text.IO (getContents)+import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+))+import Named ((:!), (:?), arg, argDef, defaults, (!))+import Text.Megaparsec (parse)++import Michelson.Interpret+  (ContractEnv(..), InterpretUntypedError(..), InterpretUntypedResult(..), InterpreterState(..),+  MorleyLogs(..), RemainingSteps(..), interpretUntyped)+import Michelson.Macro (ParsedOp, expandContract)+import qualified Michelson.Parser as P+import Michelson.Runtime.GState+import Michelson.Runtime.TxData+import Michelson.TypeCheck (SomeContract, TCError, typeCheckContract)+import Michelson.Typed+  (CreateContract(..), Operation'(..), TransferTokens(..), convertContract, untypeValue)+import qualified Michelson.Typed as T+import Michelson.Untyped (Contract, OriginationOperation(..), mkContractAddress)+import qualified Michelson.Untyped as U+import Tezos.Address (Address(..))+import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez)+import Tezos.Crypto (parseKeyHash)+import Util.IO (readFileUtf8)++----------------------------------------------------------------------------+-- Auxiliary types+----------------------------------------------------------------------------++-- | Operations executed by interpreter.+-- In our model one Michelson's operation (`operation` type in Michelson)+-- corresponds to 0 or 1 interpreter operation.+--+-- Note: 'Address' is not part of 'TxData', because 'TxData' is+-- supposed to be provided by the user, while 'Address' can be+-- computed by our code.+data InterpreterOp+  = OriginateOp !OriginationOperation+  -- ^ Originate a contract.+  | TransferOp Address+               TxData+  -- ^ Send a transaction to given address which is assumed to be the+  -- address of an originated contract.+  deriving (Show)++-- | Result of a single execution of interpreter.+data InterpreterRes = InterpreterRes+  { _irGState :: !GState+  -- ^ New 'GState'.+  , _irOperations :: [InterpreterOp]+  -- ^ List of operations to be added to the operations queue.+  , _irUpdates :: ![GStateUpdate]+  -- ^ Updates applied to 'GState'.+  , _irInterpretResults :: [(Address, InterpretUntypedResult)]+  -- ^ During execution a contract can print logs and in the end it returns+  -- a pair. All logs and returned values are kept until all called contracts+  -- are executed. In the end they are printed.+  , _irSourceAddress :: !(Maybe Address)+  -- ^ As soon as transfer operation is encountered, this address is+  -- set to its input.+  , _irRemainingSteps :: !RemainingSteps+  -- ^ Now much gas all remaining executions can consume.+  } deriving (Show)++makeLenses ''InterpreterRes++-- Note that it's not commutative.+-- It applies to the case when we have some InterpreterRes already+-- and get a new one after performing some operations.+instance Semigroup InterpreterRes where+  a <> b =+    InterpreterRes+      { _irGState = _irGState b+      , _irOperations = _irOperations b+      , _irUpdates = _irUpdates a <> _irUpdates b+      , _irInterpretResults = _irInterpretResults a <> _irInterpretResults b+      , _irSourceAddress = _irSourceAddress a <|> _irSourceAddress b+      , _irRemainingSteps = _irRemainingSteps b+      }++-- | Errors that can happen during contract interpreting.+-- Type parameter @a@ determines how contracts will be represented+-- in these errors, e.g. @Address@+data InterpreterError' a+  = IEUnknownContract !a+  -- ^ The interpreted contract hasn't been originated.+  | IEInterpreterFailed !a+                        !InterpretUntypedError+  -- ^ Interpretation of Michelson contract failed.+  | IEAlreadyOriginated !a+                        !ContractState+  -- ^ A contract is already originated.+  | IEUnknownSender !a+  -- ^ Sender address is unknown.+  | IEUnknownManager !a+  -- ^ Manager address is unknown.+  | IENotEnoughFunds !a !Mutez+  -- ^ Sender doesn't have enough funds.+  | IEFailedToApplyUpdates !GStateUpdateError+  -- ^ Failed to apply updates to GState.+  | IEIllTypedContract !TCError+  -- ^ A contract is ill-typed.+  deriving (Show)++instance (Buildable a) => Buildable (InterpreterError' a) where+  build =+    \case+      IEUnknownContract addr -> "The contract is not originated " +| addr |+ ""+      IEInterpreterFailed addr err ->+        "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""+      IEAlreadyOriginated addr cs ->+        "The following contract is already originated: " +| addr |++        ", " +| cs |+ ""+      IEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""+      IEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""+      IENotEnoughFunds addr amount ->+        "The sender (" +| addr |++        ") doesn't  have enough funds (has only " +| amount |+ ")"+      IEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""+      IEIllTypedContract err -> "The contract is ill-typed " +| err |+ ""++type InterpreterError = InterpreterError' Address++instance (Typeable a, Show a, Buildable a) => Exception (InterpreterError' a) where+  displayException = pretty++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- | Parse a contract from 'Text'.+parseContract ::+     Maybe FilePath -> Text -> Either P.ParserException (U.Contract' ParsedOp)+parseContract mFileName =+  first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)++-- | Parse a contract from 'Text' and expand macros.+parseExpandContract ::+     Maybe FilePath -> Text -> Either P.ParserException Contract+parseExpandContract mFileName = fmap expandContract . parseContract mFileName++-- | Read and parse a contract from give path or `stdin` (if the+-- argument is 'Nothing'). The contract is not expanded.+readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp)+readAndParseContract mFilename = do+  code <- readCode mFilename+  either throwM pure $ parseContract mFilename code+  where+    readCode :: Maybe FilePath -> IO Text+    readCode = maybe getContents readFileUtf8++-- | Read a contract using 'readAndParseContract', expand and+-- flatten. The contract is not type checked.+prepareContract :: Maybe FilePath -> IO Contract+prepareContract mFile = expandContract <$> readAndParseContract mFile++-- | Originate a contract. Returns the address of the originated+-- contract.+originateContract ::+     FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address+originateContract dbPath origination verbose =+  -- pass 100500 as maxSteps, because it doesn't matter for origination,+  -- as well as 'now'+  mkContractAddress origination <$+  interpreter Nothing 100500 dbPath [OriginateOp origination] verbose+  ! defaults++-- | Run a contract. The contract is originated first (if it's not+-- already) and then we pretend that we send a transaction to it.+runContract+  :: Maybe Timestamp+  -> Word64+  -> Mutez+  -> FilePath+  -> U.Value+  -> Contract+  -> TxData+  -> "verbose" :! Bool+  -> "dryRun" :! Bool+  -> IO ()+runContract maybeNow maxSteps initBalance dbPath storageValue contract txData+  verbose (arg #dryRun -> dryRun) =+  interpreter maybeNow maxSteps dbPath operations verbose ! #dryRun dryRun+  where+    -- We hardcode some random key hash here as delegate to make sure that:+    -- 1. Contract's address won't clash with already originated one (because+    -- it may have different storage value which may be confusing).+    -- 2. If one uses this functionality twice with the same contract and+    -- other data, the contract will have the same address.+    delegate =+      either (error . mappend "runContract can't parse delegate: " . pretty) id $+      parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"+    origination = OriginationOperation+      { ooManager = genesisKeyHash+      , ooDelegate = Just delegate+      , ooSpendable = False+      , ooDelegatable = False+      , ooBalance = initBalance+      , ooStorage = storageValue+      , ooContract = contract+      }+    addr = mkContractAddress origination+    operations =+      [ OriginateOp origination+      , TransferOp addr txData+      ]++-- | Send a transaction to given address with given parameters.+transfer ::+     Maybe Timestamp+  -> Word64+  -> FilePath+  -> Address+  -> TxData+  -> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()+transfer maybeNow maxSteps dbPath destination txData =+  interpreter maybeNow maxSteps dbPath [TransferOp destination txData]++----------------------------------------------------------------------------+-- Interpreter+----------------------------------------------------------------------------++-- | Interpret a contract on some global state (read from file) and+-- transaction data (passed explicitly).+interpreter ::+     Maybe Timestamp+  -> Word64+  -> FilePath+  -> [InterpreterOp]+  -> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()+interpreter maybeNow maxSteps dbPath operations+  (arg #verbose -> verbose)+  (argDef #dryRun False -> dryRun)+    = do+  now <- maybe getCurrentTime pure maybeNow+  gState <- readGState dbPath+  let eitherRes =+        interpreterPure now (RemainingSteps maxSteps) gState operations+  InterpreterRes {..} <- either throwM pure eitherRes+  mapM_ printInterpretResult _irInterpretResults+  when (verbose && not (null _irUpdates)) $ do+    fmtLn $ nameF "Updates:" (blockListF _irUpdates)+    putTextLn $ "Remaining gas: " <> pretty _irRemainingSteps+  unless dryRun $+    writeGState dbPath _irGState+  where+    printInterpretResult+      :: (Address, InterpretUntypedResult) -> IO ()+    printInterpretResult (addr, InterpretUntypedResult {..}) = do+      putTextLn $ "Executed contract " <> pretty addr+      case iurOps of+        [] -> putTextLn "It didn't return any operations"+        _ -> fmt $ nameF "It returned operations:" (blockListF iurOps)+      putTextLn $+        "It returned storage: " <> pretty (untypeValue iurNewStorage)+      let MorleyLogs logs = isMorleyLogs iurNewState+      unless (null logs) $+        mapM_ putTextLn logs+      putTextLn "" -- extra break line to separate logs from two sequence contracts++-- | Implementation of interpreter outside 'IO'.  It reads operations,+-- interprets them one by one and updates state accordingly.+-- Each operation from the passed list is fully interpreted before+-- the next one is considered.+interpreterPure ::+  Timestamp -> RemainingSteps -> GState -> [InterpreterOp] -> Either InterpreterError InterpreterRes+interpreterPure now maxSteps gState =+  foldM step initialState+  where+    -- Note that we can't just put all operations into '_irOperations'+    -- and call 'statefulInterpreter' once, because in this case the+    -- order of operations will be wrong. We need to consider+    -- top-level operations (passed to this function) and operations returned by contracts separatety.+    -- Specifically, suppose that we want to interpreter two 'TransferOp's: [t1, t2].+    -- If t1 returns an operation, it should be performed before t2, but if we just+    -- pass [t1, t2] as '_irOperations' then 't2' will done immediately after 't1'.+    initialState = InterpreterRes+      { _irGState = gState+      , _irOperations = []+      , _irUpdates = mempty+      , _irInterpretResults = []+      , _irSourceAddress = Nothing+      , _irRemainingSteps = maxSteps+      }++    step :: InterpreterRes -> InterpreterOp -> Either InterpreterError InterpreterRes+    step currentRes op =+      let start = currentRes { _irOperations = [op] }+       in (currentRes <>) <$> runExcept (execStateT (statefulInterpreter now) start)++statefulInterpreter+  :: Timestamp+  -> StateT InterpreterRes (Except InterpreterError) ()+statefulInterpreter now = do+  curGState <- use irGState+  mSourceAddr <- use irSourceAddress+  remainingSteps <- use irRemainingSteps+  use irOperations >>= \case+    [] -> pass+    (op:opsTail) ->+      either throwError (processIntRes opsTail) $+      interpretOneOp now remainingSteps mSourceAddr curGState op+  where+    processIntRes opsTail ir = do+      -- Not using `<>=` because it requires `Monoid` for no reason.+      id %= (<> ir)+      irOperations %= (opsTail <>)+      statefulInterpreter now++-- | Run only one interpreter operation and update 'GState' accordingly.+interpretOneOp+  :: Timestamp+  -> RemainingSteps+  -> Maybe Address+  -> GState+  -> InterpreterOp+  -> Either InterpreterError InterpreterRes+interpretOneOp _ remainingSteps _ gs (OriginateOp origination) = do+  void $ first IEIllTypedContract $+    typeCheckContract (extractAllContracts gs) (ooContract origination)+  let originatorAddress = KeyAddress (ooManager origination)+  originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of+    Nothing -> Left (IEUnknownManager originatorAddress)+    Just (asBalance -> oldBalance)+      | oldBalance < ooBalance origination ->+        Left (IENotEnoughFunds originatorAddress oldBalance)+      | otherwise ->+        -- Subtraction is safe because we have checked its+        -- precondition in guard.+        Right (oldBalance `unsafeSubMutez` ooBalance origination)+  let+    updates =+      [ GSAddAddress address (ASContract contractState)+      , GSSetBalance originatorAddress originatorBalance+      ]+  case applyUpdates updates gs of+    Left _ -> Left (IEAlreadyOriginated address contractState)+    Right newGS -> Right $+      InterpreterRes+      { _irGState = newGS+      , _irOperations = mempty+      , _irUpdates = updates+      , _irInterpretResults = []+      , _irSourceAddress = Nothing+      , _irRemainingSteps = remainingSteps+      }+  where+    contractState = ContractState+      { csBalance = ooBalance origination+      , csStorage = ooStorage origination+      , csContract = ooContract origination+      }+    address = mkContractAddress origination+interpretOneOp now remainingSteps mSourceAddr gs (TransferOp addr txData) = do+    let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr+    let senderAddr = tdSenderAddress txData+    decreaseSenderBalance <- case addresses ^. at senderAddr of+      Nothing -> Left (IEUnknownSender senderAddr)+      Just (asBalance -> balance)+        | balance < tdAmount txData ->+          Left (IENotEnoughFunds senderAddr balance)+        | otherwise ->+          -- Subtraction is safe because we have checked its+          -- precondition in guard.+          Right (GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData))+    let onlyUpdates updates = Right (updates, [], Nothing, remainingSteps)+    (otherUpdates, sideEffects, maybeInterpretRes, newRemSteps)+        <- case (addresses ^. at addr, addr) of+      (Nothing, ContractAddress _) ->+        Left (IEUnknownContract addr)+      (Nothing, KeyAddress _) -> do+        let+          addrState = ASSimple (tdAmount txData)+          upd = GSAddAddress addr addrState+        onlyUpdates [upd]+      (Just (ASSimple oldBalance), _) -> do+        -- can't overflow if global state is correct (because we can't+        -- create money out of nowhere)+        let+          newBalance = oldBalance `unsafeAddMutez` tdAmount txData+          upd = GSSetBalance addr newBalance+        onlyUpdates [upd]+      (Just (ASContract cs), _) -> do+        let+          contract = csContract cs+          existingContracts = extractAllContracts gs+          contractEnv = ContractEnv+            { ceNow = now+            , ceMaxSteps = remainingSteps+            , ceBalance = csBalance cs+            , ceContracts = existingContracts+            , ceSelf = addr+            , ceSource = sourceAddr+            , ceSender = senderAddr+            , ceAmount = tdAmount txData+            }+        iur@InterpretUntypedResult+          { iurOps = sideEffects+          , iurNewStorage = newValue+          , iurNewState = InterpreterState _ newRemainingSteps+          }+          <- first (IEInterpreterFailed addr) $+                interpretUntyped contract (tdParameter txData)+                                 (csStorage cs) contractEnv+        let+          newValueU = untypeValue newValue+          -- can't overflow if global state is correct (because we can't+          -- create money out of nowhere)+          newBalance = csBalance cs `unsafeAddMutez` tdAmount txData+          updBalance = GSSetBalance addr newBalance+          updStorage = GSSetStorageValue addr newValueU+          updates =+            [ updBalance+            , updStorage+            ]+        Right (updates, sideEffects, Just iur, newRemainingSteps)++    let+      updates = decreaseSenderBalance:otherUpdates++    newGState <- first IEFailedToApplyUpdates $ applyUpdates updates gs++    return InterpreterRes+      { _irGState = newGState+      , _irOperations = mapMaybe (convertOp addr) sideEffects+      , _irUpdates = updates+      , _irInterpretResults = maybe mempty (one . (addr,)) maybeInterpretRes+      , _irSourceAddress = Just sourceAddr+      , _irRemainingSteps = newRemSteps+      }+  where+    addresses :: Map Address AddressState+    addresses = gsAddresses gs++----------------------------------------------------------------------------+-- TypeCheck+----------------------------------------------------------------------------+typeCheckWithDb+  :: FilePath+  -> U.Contract+  -> IO (Either TCError SomeContract)+typeCheckWithDb dbPath morleyContract = do+  gState <- readGState dbPath+  pure . typeCheckContract (extractAllContracts gState) $ morleyContract++----------------------------------------------------------------------------+-- Simple helpers+----------------------------------------------------------------------------++-- The argument is the address of the contract that generation this operation.+convertOp :: Address -> T.Operation -> Maybe InterpreterOp+convertOp interpretedAddr =+  \case+    OpTransferTokens tt ->+      let txData =+            TxData+              { tdSenderAddress = interpretedAddr+              , tdParameter = untypeValue (ttContractParameter tt)+              , tdAmount = ttAmount tt+              }+          T.VContract destAddress = ttContract tt+       in Just (TransferOp destAddress txData)+    OpSetDelegate {} -> Nothing+    OpCreateAccount {} -> Nothing+    OpCreateContract cc ->+      let origination = OriginationOperation+            { ooManager = ccManager cc+            , ooDelegate = ccDelegate cc+            , ooSpendable = ccSpendable cc+            , ooDelegatable = ccDelegatable cc+            , ooBalance = ccBalance cc+            , ooStorage = untypeValue (ccStorageVal cc)+            , ooContract = convertContract (ccContractCode cc)+            }+       in Just (OriginateOp origination)
+ src/Michelson/Runtime/GState.hs view
@@ -0,0 +1,273 @@+-- | Global blockchain state (emulated).++module Michelson.Runtime.GState+       (+         -- * Auxiliary types+         ContractState (..)+       , AddressState (..)+       , asBalance++       -- * GState+       , GState (..)+       , genesisAddresses+       , genesisKeyHashes+       , genesisAddress+       -- * More genesisAddresses which can be used in tests+       , genesisAddress1+       , genesisAddress2+       , genesisAddress3+       , genesisAddress4+       , genesisAddress5+       , genesisAddress6+       , genesisKeyHash+       , initGState+       , readGState+       , writeGState++       -- * Operations on GState+       , GStateUpdate (..)+       , GStateUpdateError (..)+       , applyUpdate+       , applyUpdates+       , extractAllContracts+       ) where++import Control.Lens (at)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Aeson+import Data.Aeson.Options (defaultOptions)+import Data.Aeson.TH (deriveJSON)+import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty ((!!))+import qualified Data.Map.Strict as Map+import Fmt (genericF, (+|), (|+))+import Formatting.Buildable (Buildable(build))+import System.IO.Error (IOError, isDoesNotExistError)++import Michelson.TypeCheck (TcOriginatedContracts)+import Michelson.Untyped (Contract, Type, Value, para)+import Tezos.Address (Address(..))+import Tezos.Core (Mutez, divModMutezInt)+import Tezos.Crypto++-- | State of a contract with code.+data ContractState = ContractState+  { csBalance :: !Mutez+  -- ^ Amount of mutez owned by this contract.+  , csStorage :: !Value+  -- ^ Storage value associated with this contract.+  , csContract :: !Contract+  -- ^ Contract itself (untyped).+  } deriving (Show, Generic, Eq)++instance Buildable ContractState where+  build = genericF++deriveJSON defaultOptions ''ContractState++-- | State of an arbitrary address.+data AddressState+  = ASSimple !Mutez+  -- ^ For contracts without code we store only its balance.+  | ASContract !ContractState+  -- ^ For contracts with code we store more state represented by+  -- 'ContractState'.+  deriving (Show, Generic, Eq)++instance Buildable AddressState where+  build =+    \case+      ASSimple balance -> "Balance = " +| balance |+ ""+      ASContract cs -> build cs++deriveJSON defaultOptions ''AddressState++-- | Extract balance from 'AddressState'.+asBalance :: AddressState -> Mutez+asBalance =+  \case+    ASSimple b -> b+    ASContract cs -> csBalance cs++-- | Persistent data passed to Morley contracts which can be updated+-- as result of contract execution.+data GState = GState+  { gsAddresses :: Map Address AddressState+  -- ^ All known addresses and their state.+  } deriving Show++deriveJSON defaultOptions ''GState++-- | Number of genesis addresses.+genesisAddressesNum :: Word+genesisAddressesNum = 10++-- | Secrets from which genesis addresses are derived from.+genesisSecrets :: NonEmpty SecretKey+genesisSecrets = do+  i <- 1 :| [2 .. genesisAddressesNum]+  let seed = encodeUtf8 (show i :: Text)+  return $ detSecretKey seed++-- | KeyHash of genesis address.+genesisKeyHashes :: NonEmpty KeyHash+genesisKeyHashes = hashKey . toPublic <$> genesisSecrets++-- | Initially these addresses have a lot of money.+genesisAddresses :: NonEmpty Address+genesisAddresses = KeyAddress <$> genesisKeyHashes++-- | One of genesis key hashes.+genesisKeyHash :: KeyHash+genesisKeyHash = head genesisKeyHashes++-- | One of genesis addresses.+genesisAddress :: Address+genesisAddress = head genesisAddresses++-- | More genesis addresses+--+-- We know size of @genesisAddresses@, so it is safe to use @!!@+genesisAddress1, genesisAddress2, genesisAddress3 :: Address+genesisAddress4, genesisAddress5, genesisAddress6 :: Address+genesisAddress1 = genesisAddresses !! 1+genesisAddress2 = genesisAddresses !! 2+genesisAddress3 = genesisAddresses !! 3+genesisAddress4 = genesisAddresses !! 4+genesisAddress5 = genesisAddresses !! 5+genesisAddress6 = genesisAddresses !! 6++-- | Initial 'GState'. It's supposed to be used if no 'GState' is+-- provided. It puts plenty of money on each genesis address.+initGState :: GState+initGState =+  GState+  { gsAddresses = Map.fromList+    [ (genesis, ASSimple money)+    | genesis <- toList genesisAddresses+    , let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum+                    ?: error "Number of genesis addresses is 0"+    ]+  }++data GStateParseError =+  GStateParseError String+  deriving Show++instance Exception GStateParseError where+  displayException (GStateParseError str) = "Failed to parse GState: " <> str++-- | Read 'GState' from a file.+readGState :: FilePath -> IO GState+readGState fp = (LBS.readFile fp >>= parseFile) `catch` onExc+  where+    parseFile :: LByteString -> IO GState+    parseFile lByteString =+      if null lByteString+      then pure initGState+      else (either (throwM . GStateParseError) pure . Aeson.eitherDecode') lByteString+    onExc :: IOError -> IO GState+    onExc exc+      | isDoesNotExistError exc = pure initGState+      | otherwise = throwM exc++-- | Write 'GState' to a file.+writeGState :: FilePath -> GState -> IO ()+writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs)+  where+    config =+      Aeson.defConfig+      { Aeson.confTrailingNewline = True+      }++-- | Updates that can be applied to 'GState'.+data GStateUpdate+  = GSAddAddress !Address+                 !AddressState+  | GSSetStorageValue !Address+                      !Value+  | GSSetBalance !Address+                 !Mutez+  deriving (Show, Eq)++instance Buildable GStateUpdate where+  build =+    \case+      GSAddAddress addr st ->+        "Add address " +| addr |+ " with state " +| st |+ ""+      GSSetStorageValue addr val ->+        "Set storage value of address " +| addr |+ " to " +| val |+ ""+      GSSetBalance addr balance ->+        "Set balance of address " +| addr |+ " to " +| balance |+ ""++data GStateUpdateError+  = GStateAddressExists !Address+  | GStateUnknownAddress !Address+  | GStateNotContract !Address+  deriving (Show)++instance Buildable GStateUpdateError where+  build =+    \case+      GStateAddressExists addr -> "Address already exists: " <> build addr+      GStateUnknownAddress addr -> "Unknown address: " <> build addr+      GStateNotContract addr -> "Address doesn't have contract: " <> build addr++-- | Apply 'GStateUpdate' to 'GState'.+applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState+applyUpdate =+  \case+    GSAddAddress addr st ->+      maybeToRight (GStateAddressExists addr) . addAddress addr st+    GSSetStorageValue addr newValue -> setStorageValue addr newValue+    GSSetBalance addr newBalance -> setBalance addr newBalance++-- | Apply a list of 'GStateUpdate's to 'GState'.+applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState+applyUpdates = flip (foldM (flip applyUpdate))++-- | Add an address if it hasn't been added before.+addAddress :: Address -> AddressState -> GState -> Maybe GState+addAddress addr st gs+    | addr `Map.member` accounts = Nothing+    | otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st})+  where+    accounts = gsAddresses gs++-- | Updare storage value associated with given address.+setStorageValue ::+     Address -> Value -> GState -> Either GStateUpdateError GState+setStorageValue addr newValue = updateAddressState addr modifier+  where+    modifier (ASSimple _) = Left (GStateNotContract addr)+    modifier (ASContract cs) = Right $ ASContract $ cs { csStorage = newValue }++-- | Updare storage value associated with given address.+setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState+setBalance addr newBalance = updateAddressState addr (Right . modifier)+  where+    modifier (ASSimple _) = ASSimple newBalance+    modifier (ASContract cs) = ASContract (cs {csBalance = newBalance})++updateAddressState ::+     Address+  -> (AddressState -> Either GStateUpdateError AddressState)+  -> GState+  -> Either GStateUpdateError GState+updateAddressState addr f gs =+  case addresses ^. at addr of+    Nothing -> Left (GStateUnknownAddress addr)+    Just as -> do+      newState <- f as+      return $ gs { gsAddresses = addresses & at addr .~ Just newState }+  where+    addresses = gsAddresses gs++-- | Retrive all contracts stored in GState+extractAllContracts :: GState -> TcOriginatedContracts+extractAllContracts = Map.mapMaybe extractContract . gsAddresses+ where+    extractContract :: AddressState -> Maybe Type+    extractContract =+      \case ASSimple {} -> Nothing+            ASContract cs -> Just (para $ csContract cs)
+ src/Michelson/Runtime/TxData.hs view
@@ -0,0 +1,24 @@+-- | 'TxData' type and associated functionality.++module Michelson.Runtime.TxData+       ( TxData (..)+       , tdSenderAddressL+       , tdParameterL+       , tdAmountL+       ) where++import Control.Lens (makeLensesWith)++import Michelson.Untyped (Value)+import Tezos.Address (Address)+import Tezos.Core (Mutez)+import Util.Lens (postfixLFields)++-- | Data associated with a particular transaction.+data TxData = TxData+  { tdSenderAddress :: !Address+  , tdParameter :: !Value+  , tdAmount :: !Mutez+  } deriving (Show, Eq)++makeLensesWith postfixLFields ''TxData
+ src/Michelson/Test.hs view
@@ -0,0 +1,70 @@+-- | Module containing some utilities for testing Michelson contracts using+-- Haskell testing frameworks (hspec and QuickCheck in particular).+-- It's Morley testing EDSL.++module Michelson.Test+  ( -- * Importing a contract+    specWithContract+  , specWithContractL+  , specWithTypedContract+  , specWithUntypedContract+  , importUntypedContract++  -- * Unit testing+  , ContractReturn+  , ContractPropValidator+  , contractProp+  , contractPropVal+  , contractRepeatedProp+  , contractRepeatedPropVal++  -- * Integrational testing+  -- ** Testing engine+  , IntegrationalValidator+  , SuccessValidator+  , IntegrationalScenario+  , IntegrationalScenarioM+  , integrationalTestExpectation+  , integrationalTestProperty+  , originate+  , transfer+  , validate+  , setMaxSteps+  , setNow++  -- ** Validators+  , composeValidators+  , composeValidatorsList+  , expectAnySuccess+  , expectStorageUpdate+  , expectStorageUpdateConst+  , expectBalance+  , expectStorageConst+  , expectGasExhaustion+  , expectMichelsonFailed++  -- ** Various+  , TxData (..)+  , genesisAddress++  -- * General utilities+  , failedProp+  , succeededProp+  , qcIsLeft+  , qcIsRight++  -- * Dummy values+  , dummyContractEnv++  -- * Arbitrary data+  , minTimestamp+  , maxTimestamp+  , midTimestamp+  ) where++import Michelson.Test.Dummy+import Michelson.Test.Gen+import Michelson.Test.Import+import Michelson.Test.Integrational+import Michelson.Test.Unit+import Michelson.Test.Util
+ src/Michelson/Test/Dummy.hs view
@@ -0,0 +1,58 @@+-- | Dummy data to be used in tests where it's not essential.++module Michelson.Test.Dummy+  ( dummyNow+  , dummyMaxSteps+  , dummyContractEnv+  , dummyOrigination+  ) where++import Michelson.Interpret (ContractEnv(..), RemainingSteps)+import Michelson.Runtime.GState (genesisAddress, genesisKeyHash)+import Michelson.Untyped+import Tezos.Core (Timestamp(..), unsafeMkMutez)++-- | Dummy timestamp, can be used to specify current `NOW` value or+-- maybe something else.+dummyNow :: Timestamp+dummyNow = Timestamp 100++-- | Dummy value for maximal number of steps a contract can+-- make. Intentionally quite large, because most likely if you use+-- dummy value you don't want the interpreter to stop due to gas+-- exhaustion. On the other hand, it probably still prevents the+-- interpreter from working for eternity.+dummyMaxSteps :: RemainingSteps+dummyMaxSteps = 100500++-- | Dummy 'ContractEnv' with some reasonable hardcoded values. You+-- can override values you are interested in using record update+-- syntax.+dummyContractEnv :: ContractEnv+dummyContractEnv = ContractEnv+  { ceNow = dummyNow+  , ceMaxSteps = dummyMaxSteps+  , ceBalance = unsafeMkMutez 100+  , ceContracts = mempty+  , ceSelf = genesisAddress+  , ceSource = genesisAddress+  , ceSender = genesisAddress+  , ceAmount = unsafeMkMutez 100+  }++-- | 'OriginationOperation' with most data hardcoded to some+-- reasonable values. Contract and initial values must be passed+-- explicitly, because otherwise it hardly makes sense.+dummyOrigination ::+     Value+  -> Contract+  -> OriginationOperation+dummyOrigination storage contract = OriginationOperation+  { ooManager = genesisKeyHash+  , ooDelegate = Nothing+  , ooSpendable = False+  , ooDelegatable = False+  , ooBalance = unsafeMkMutez 100+  , ooStorage = storage+  , ooContract = contract+  }
+ src/Michelson/Test/Gen.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Utilities for arbitrary data generation in property tests.++module Michelson.Test.Gen+  ( minTimestamp+  , maxTimestamp+  , midTimestamp+  ) where++import Data.Time.Calendar (Day, addDays, diffDays)+import Data.Time.Clock (UTCTime(..))+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import Test.QuickCheck (Arbitrary(..), choose)++import Michelson.Typed (CT(..), CValue(..), T(..), Value'(..))+import Tezos.Core+  (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds,+  unsafeMkMutez)++instance Arbitrary (CValue 'CKeyHash) where+  arbitrary = CvKeyHash <$> arbitrary+instance Arbitrary (CValue 'CMutez) where+  arbitrary = CvMutez <$> arbitrary+instance Arbitrary (CValue 'CInt) where+  arbitrary = CvInt <$> arbitrary+instance Arbitrary (CValue a) => Arbitrary (Value' instr ('Tc a)) where+  arbitrary = VC <$> arbitrary+instance Arbitrary (Value' instr a) => Arbitrary (Value' instr ('TList a)) where+  arbitrary = VList <$> arbitrary+instance Arbitrary (Value' instr 'TUnit) where+  arbitrary = pure VUnit+instance (Arbitrary (Value' instr a), Arbitrary (Value' instr b))+    => Arbitrary (Value' instr ('TPair a b)) where+  arbitrary = VPair ... (,) <$> arbitrary <*> arbitrary++minDay :: Day+minDay = fromMaybe (error "failed to parse day 2008-11-01") $+            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01"++maxDay :: Day+maxDay = fromMaybe (error "failed to parse day 2024-11-01") $+            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2024-11-01"++minSec :: Integer+minSec = 0++maxSec :: Integer+maxSec = 86399++-- | Minimal (earliest) timestamp used for @Arbitrary (CValue 'CTimestamp)@+minTimestamp :: Timestamp+minTimestamp = timestampFromUTCTime $ UTCTime minDay (fromInteger minSec)++-- | Maximal (latest) timestamp used for @Arbitrary (CValue 'CTimestamp)@+maxTimestamp :: Timestamp+maxTimestamp = timestampFromUTCTime $ UTCTime maxDay (fromInteger maxSec)++-- | Median of 'minTimestamp' and 'maxTimestamp'.+-- Useful for testing (exactly half of generated dates will be before and after+-- this date).+midTimestamp :: Timestamp+midTimestamp = timestampFromUTCTime $+  UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay)+          (fromInteger $ (maxSec - minSec) `div` 2)++instance Arbitrary (CValue 'CTimestamp) where+  arbitrary = CvTimestamp <$> arbitrary++instance Arbitrary Mutez where+  arbitrary = unsafeMkMutez <$> choose (unMutez minBound, unMutez maxBound)++instance Arbitrary Timestamp where+  arbitrary =+    timestampFromSeconds @Int <$>+    choose (timestampToSeconds minTimestamp, timestampToSeconds maxTimestamp)
+ src/Michelson/Test/Import.hs view
@@ -0,0 +1,120 @@+-- | Functions to import contracts to be used in tests.++module Michelson.Test.Import+  ( readContract+  , specWithContract+  , specWithContractL+  , specWithTypedContract+  , specWithUntypedContract+  , importContract+  , importUntypedContract+  , ImportContractError (..)+  ) where++import Control.Exception (IOException)+import Data.Singletons (SingI, demote)+import Data.Typeable ((:~:)(..), eqT)+import Fmt (Buildable(build), pretty, (+|), (|+))+import Test.Hspec (Spec, describe, expectationFailure, it, runIO)++import qualified Lorentz as L+import Michelson.Parser.Error (ParserException(..))+import Michelson.Runtime (parseExpandContract, prepareContract)+import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract)+import Michelson.Typed (Contract, ToT, toUType)+import qualified Michelson.Untyped as U+import Util.IO++-- | Import contract and use it in the spec. Both versions of contract are+-- passed to the callback function (untyped and typed).+--+-- If contract's import failed, a spec with single failing expectation+-- will be generated (so tests will run unexceptionally, but a failing+-- result will notify about problem).+specWithContract+  :: (Each [Typeable, SingI] [cp, st], HasCallStack)+  => FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec+specWithContract = specWithContractImpl importContract++-- | Like 'specWithContract', but for Lorentz types.+specWithContractL+  :: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack)+  => FilePath -> ((U.Contract, L.Contract cp st) -> Spec) -> Spec+specWithContractL file mkSpec = specWithContract file (mkSpec . second L.I)++-- | A version of 'specWithContract' which passes only the typed+-- representation of the contract.+specWithTypedContract+  :: (Each [Typeable, SingI] [cp, st], HasCallStack)+  => FilePath -> (Contract cp st -> Spec) -> Spec+specWithTypedContract = specWithContractImpl (fmap snd . importContract)++specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec+specWithUntypedContract = specWithContractImpl importUntypedContract++specWithContractImpl+  :: HasCallStack+  => (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec+specWithContractImpl doImport file execSpec =+  either errorSpec (describe ("Test contract " <> file) . execSpec)+    =<< runIO+          ( (Right <$> doImport file)+            `catch` (\(e :: ImportContractError) -> pure $ Left $ displayException e)+            `catch` \(e :: IOException) -> pure $ Left $ displayException e )+  where+    errorSpec = it ("Import contract " <> file) . expectationFailure++readContract+  :: forall cp st .+    Each [Typeable, SingI] [cp, st]+  => FilePath+  -> Text+  -> Either ImportContractError (U.Contract, Contract cp st)+readContract filePath txt = do+  contract <- first ICEParse $ parseExpandContract (Just filePath) txt+  SomeContract (instr :: Contract cp' st') _ _+    <- first ICETypeCheck $ typeCheckContract mempty contract+  case (eqT @cp @cp', eqT @st @st') of+    (Just Refl, Just Refl) -> pure (contract, instr)+    (Nothing, _) -> Left $+      ICEUnexpectedParamType (U.para contract) (toUType $ demote @cp)+    _ -> Left (ICEUnexpectedStorageType (U.stor contract) (toUType $ demote @st))++-- | Import contract from a given file path.+--+-- This function reads file, parses and type checks a contract.+-- Within the typechecking we assume that no contracts are originated,+-- otherwise a type checking error will be caused.+--+-- This function may throw 'IOException' and 'ImportContractError'.+importContract+  :: forall cp st .+     Each [Typeable, SingI] [cp, st]+  => FilePath -> IO (U.Contract, Contract cp st)+importContract file = either throwM pure =<< readContract file <$> readFileUtf8 file++importUntypedContract :: FilePath -> IO U.Contract+importUntypedContract = prepareContract . Just++-- | Error type for 'importContract' function.+data ImportContractError+  = ICEUnexpectedParamType !U.Type !U.Type+  | ICEUnexpectedStorageType !U.Type !U.Type+  | ICEParse !ParserException+  | ICETypeCheck !TCError+  deriving (Show, Eq)++instance Buildable ImportContractError where+  build =+    \case+      ICEUnexpectedParamType actual expected ->+        "Unexpected parameter type: " +| actual |++        ", expected: " +| expected |+ ""+      ICEUnexpectedStorageType actual expected ->+        "Unexpected storage type: " +| actual |++        ", expected: " +| expected |+ ""+      ICEParse e -> "Failed to parse the contract: " +| e |+ ""+      ICETypeCheck e -> "The contract is ill-typed: " +| e |+ ""++instance Exception ImportContractError where+  displayException = pretty
+ src/Michelson/Test/Integrational.hs view
@@ -0,0 +1,379 @@+-- | Utilities for integrational testing.+-- Example tests can be found in the 'morley-test' test suite.++module Michelson.Test.Integrational+  (+    -- * Re-exports+    TxData (..)+  -- * More genesis addresses which can be used in tests+  , genesisAddress+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6++  -- * Testing engine+  , IntegrationalValidator+  , SuccessValidator+  , IntegrationalScenarioM+  , IntegrationalScenario+  , ValidationError (..)+  , integrationalTestExpectation+  , integrationalTestProperty+  , originate+  , transfer+  , validate+  , setMaxSteps+  , setNow+  , withSender++  -- * Validators+  , composeValidators+  , composeValidatorsList+  , expectAnySuccess+  , expectStorageUpdate+  , expectStorageUpdateConst+  , expectBalance+  , expectStorageConst+  , expectGasExhaustion+  , expectMichelsonFailed+  ) where++import Control.Lens (assign, at, makeLenses, (%=), (.=), (<>=), (?=))+import Control.Monad.Except (Except, runExcept, throwError)+import qualified Data.List as List+import Data.Map as Map (empty, insert, lookup)+import Fmt (Buildable(..), blockListF, pretty, (+|), (|+))+import Test.Hspec (Expectation, expectationFailure)+import Test.QuickCheck (Property)++import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps)+import Michelson.Runtime+  (InterpreterError, InterpreterError'(..), InterpreterOp(..), InterpreterRes(..), interpreterPure)+import Michelson.Runtime.GState+import Michelson.Runtime.TxData+import Michelson.Test.Dummy+import Michelson.Test.Util (failedProp, succeededProp)+import Michelson.TypeCheck (TCError)+import Michelson.Untyped (Contract, OriginationOperation(..), Value, mkContractAddress)+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)++----------------------------------------------------------------------------+-- Some internals (they are here because TH makes our very existence much harder)+----------------------------------------------------------------------------++data InternalState = InternalState+  { _isMaxSteps :: !RemainingSteps+  , _isNow :: !Timestamp+  , _isGState :: !GState+  , _isOperations :: ![InterpreterOp]+  -- ^ Operations to be interpreted when 'TOValidate' is encountered.+  , _isContractsNames :: !(Map Address Text)+  -- ^ Map from contracts addresses to humanreadable names.+  , _isSender :: !(Maybe Address)+  -- ^ If set, all following transfers will be executed on behalf+  -- of the given contract.+  }++makeLenses ''InternalState++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- | Validator for integrational testing.+-- If an error is expected, it should be 'Left' with validator for errors.+-- Otherwise it should check final global state and its updates.+type IntegrationalValidator = Either (InterpreterError -> Bool) SuccessValidator++-- | Validator for integrational testing that expects successful execution.+type SuccessValidator = (InternalState -> GState -> [GStateUpdate] -> Either ValidationError ())++-- | A monad inside which integrational tests can be described using+-- do-notation.+type IntegrationalScenarioM = StateT InternalState (Except ValidationError)++-- | A dummy data type that ensures that `validate` is called in the+-- end of each scenario. It is intentionally not exported.+data Validated = Validated++type IntegrationalScenario = IntegrationalScenarioM Validated++newtype ExpectedStorage = ExpectedStorage Value deriving (Show)+newtype ExpectedBalance = ExpectedBalance Mutez deriving (Show)++data AddressName = AddressName (Maybe Text) Address deriving (Show)++addrToAddrName :: Address -> InternalState -> AddressName+addrToAddrName addr iState =+  AddressName (lookup addr (iState ^. isContractsNames)) addr++instance Buildable AddressName where+  build (AddressName mbName addr) =+    build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName++type IntegrationalInterpreterError = InterpreterError' AddressName++data ValidationError+  = UnexpectedInterpreterError IntegrationalInterpreterError+  | UnexpectedTypeCheckError TCError+  | ExpectingInterpreterToFail+  | IncorrectUpdates ValidationError [GStateUpdate]+  | IncorrectStorageUpdate AddressName Text+  | InvalidStorage AddressName ExpectedStorage Text+  | InvalidBalance AddressName ExpectedBalance Text+  | CustomError Text+  deriving (Show)++instance Buildable ValidationError where+  build (UnexpectedInterpreterError iErr) =+    "Unexpected interpreter error. Reason: " +| iErr |+ ""+  build (UnexpectedTypeCheckError tcErr) =+    "Unexpected type check error. Reason: " +| tcErr |+ ""+  build ExpectingInterpreterToFail =+    "Interpreter unexpectedly didn't fail"+  build (IncorrectUpdates vErr updates) =+    "Updates are incorrect: " +| vErr |+ " . Updates are:"+    +| blockListF updates |+ ""+  build (IncorrectStorageUpdate addr msg) =+    "Storage of " +| addr |+ " is updated incorrectly: " +| msg |+ ""+  build (InvalidStorage addr (ExpectedStorage expected) msg) =+    "Expected " +| addr |+ " to have storage " +| expected |+ ", but " +| msg |+ ""+  build (InvalidBalance addr (ExpectedBalance expected) msg) =+    "Expected " +| addr |+ " to have balance " +| expected |+ ", but " +| msg |+ ""+  build (CustomError msg) = pretty msg++instance Exception ValidationError where+  displayException = pretty++-- | Integrational test that executes given operations and validates+-- them using given validator. It can fail using 'Expectation'+-- capability.+-- It starts with 'initGState' and some reasonable dummy values for+-- gas limit and current timestamp. You can update blockchain state+-- by performing some operations.+integrationalTestExpectation :: IntegrationalScenario -> Expectation+integrationalTestExpectation =+  integrationalTest (maybe pass (expectationFailure . pretty))++-- | Integrational test similar to 'integrationalTestExpectation'.+-- It can fail using 'Property' capability.+-- It can be used with QuickCheck's @forAll@ to make a+-- property-based test with arbitrary data.+integrationalTestProperty :: IntegrationalScenario -> Property+integrationalTestProperty =+  integrationalTest (maybe succeededProp (failedProp . pretty))++-- | Originate a contract with given initial storage and balance. Its+-- address is returned.+originate :: Contract -> Text -> Value -> Mutez -> IntegrationalScenarioM Address+originate contract contractName value balance = do+  address <- mkContractAddress origination <$ putOperation originateOp+  isContractsNames %= (insert address contractName)+  pure address+  where+    origination = (dummyOrigination value contract) {ooBalance = balance}+    originateOp = OriginateOp origination++-- | Transfer tokens to given address.+transfer :: TxData -> Address -> IntegrationalScenarioM ()+transfer txData destination = do+  mSender <- use isSender+  let txData' = maybe id (set tdSenderAddressL) mSender txData+  putOperation (TransferOp destination txData')++-- | Execute all operations that were added to the scenarion since+-- last 'validate' call. If validator fails, the execution will be aborted.+validate :: IntegrationalValidator -> IntegrationalScenario+validate validator = Validated <$ do+  now <- use isNow+  maxSteps <- use isMaxSteps+  gState <- use isGState+  ops <- use isOperations+  iState <- get+  let interpret = interpreterPure now maxSteps gState ops+  mUpdatedGState <- lift $ validateResult validator interpret iState+  isOperations .= mempty+  whenJust mUpdatedGState $ \newGState -> isGState .= newGState++-- | Make all further interpreter calls (which are triggered by the+-- 'validate' function) use given timestamp as the current one.+setNow :: Timestamp -> IntegrationalScenarioM ()+setNow = assign isNow++-- | Make all further interpreter calls (which are triggered by the+-- 'validate' function) use given gas limit.+setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()+setMaxSteps = assign isMaxSteps++-- | Pretend that given address initiates all the transfers within the+-- code block (i.e. @SENDER@ instruction will return this address).+withSender :: Address -> IntegrationalScenarioM a -> IntegrationalScenarioM a+withSender addr scenario = do+  prevSender <- use isSender+  isSender ?= addr+  scenario <* (isSender .= prevSender)++putOperation :: InterpreterOp -> IntegrationalScenarioM ()+putOperation op = isOperations <>= one op++----------------------------------------------------------------------------+-- Validators to be used within 'IntegrationalValidator'+----------------------------------------------------------------------------++-- | 'SuccessValidator' that always passes.+expectAnySuccess :: SuccessValidator+expectAnySuccess _ _ _ = pass++-- | Check that storage value is updated for given address. Takes a+-- predicate that is used to check the value.+--+-- It works even if updates are not filtered (i. e. a value can be+-- updated more than once).+expectStorageUpdate ::+     Address+  -> (Value -> Either ValidationError ())+  -> SuccessValidator+expectStorageUpdate addr predicate is _ updates =+  case List.find checkAddr (reverse updates) of+    Nothing -> Left $+      IncorrectStorageUpdate (addrToAddrName addr is) "storage wasn't updated"+    Just (GSSetStorageValue _ val) ->+      first (IncorrectStorageUpdate (addrToAddrName addr is) . pretty) $+      predicate val+    -- 'checkAddr' ensures that only 'GSSetStorageValue' can be found+    Just _ -> error "expectStorageUpdate: internal error"+  where+    checkAddr (GSSetStorageValue addr' _) = addr' == addr+    checkAddr _ = False++-- | Like 'expectStorageUpdate', but expects a constant.+expectStorageUpdateConst ::+     Address+  -> Value+  -> SuccessValidator+expectStorageUpdateConst addr expected is =+  expectStorageUpdate addr predicate is+  where+    predicate val+      | val == expected = pass+      | otherwise = Left $+        IncorrectStorageUpdate (addrToAddrName addr is) $ pretty expected++-- | Check that eventually address has some particular storage value.+expectStorageConst :: Address -> Value -> SuccessValidator+expectStorageConst addr expected is gs _ =+  case gsAddresses gs ^. at addr of+    Just (ASContract cs)+      | csStorage cs == expected -> pass+      | otherwise ->+        Left $ intro $ "its actual storage is: " <> (pretty $ csStorage cs)+    Just (ASSimple {}) ->+      Left $ intro $ "it's a simple address"+    Nothing -> Left $ intro $ "it's unknown"+  where+    intro = InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected)++-- | Check that eventually address has some particular balance.+expectBalance :: Address -> Mutez -> SuccessValidator+expectBalance addr balance is gs _ =+  case gsAddresses gs ^. at addr of+    Nothing ->+      Left $+      InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance) "it's unknown"+    Just (asBalance -> realBalance)+      | realBalance == balance -> pass+      | otherwise ->+        Left $+        InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance) $+        "its actual balance is: " <> pretty realBalance+-- | Compose two success validators.+--+-- For example:+--+-- expectBalance bal addr `composeValidators`+-- expectStorageUpdateConst addr2 ValueUnit+composeValidators ::+     SuccessValidator+  -> SuccessValidator+  -> SuccessValidator+composeValidators val1 val2 gState updates =+  val1 gState updates >> val2 gState updates++-- | Compose a list of success validators.+composeValidatorsList :: [SuccessValidator] -> SuccessValidator+composeValidatorsList = foldl' composeValidators expectAnySuccess++-- | Check that interpreter failed due to gas exhaustion.+expectGasExhaustion :: InterpreterError -> Bool+expectGasExhaustion =+  \case+    IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True+    _ -> False++-- | Expect that interpretation of contract with given address ended+-- with [FAILED].+expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> InterpreterError -> Bool+expectMichelsonFailed predicate addr =+  \case+    IEInterpreterFailed failedAddr (RuntimeFailure (mf, _)) ->+      addr == failedAddr && predicate mf+    _ -> False++----------------------------------------------------------------------------+-- Implementation of the testing engine+----------------------------------------------------------------------------++initIS :: InternalState+initIS = InternalState+  { _isNow = dummyNow+  , _isMaxSteps = dummyMaxSteps+  , _isGState = initGState+  , _isOperations = mempty+  , _isContractsNames = Map.empty+  , _isSender = Nothing+  }++integrationalTest ::+     (Maybe ValidationError -> res)+  -> IntegrationalScenario+  -> res+integrationalTest howToFail scenario =+  howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)++validateResult ::+     IntegrationalValidator+  -> Either InterpreterError InterpreterRes+  -> InternalState+  -> Except ValidationError (Maybe GState)+validateResult validator result iState =+  case (validator, result) of+    (Left validateError, Left err)+      | validateError err -> pure Nothing+    (_, Left err) ->+      doFail $ UnexpectedInterpreterError $ mkError err iState+    (Left _, Right _) ->+      doFail $ ExpectingInterpreterToFail+    (Right validateUpdates, Right ir)+      | Left bad <- validateUpdates iState (_irGState ir) (_irUpdates ir) ->+        doFail $ IncorrectUpdates bad (_irUpdates ir)+      | otherwise -> pure $ Just $ _irGState ir+  where+    doFail = throwError+    mkError+      :: InterpreterError -> InternalState -> IntegrationalInterpreterError+    mkError iErr is = case iErr of+      IEUnknownContract addr -> IEUnknownContract $ addrToAddrName addr is+      IEInterpreterFailed addr err ->+        IEInterpreterFailed (addrToAddrName addr is) err+      IEAlreadyOriginated addr cs ->+        IEAlreadyOriginated (addrToAddrName addr is) cs+      IEUnknownSender addr -> IEUnknownSender $ addrToAddrName addr is+      IEUnknownManager addr -> IEUnknownManager $ addrToAddrName addr is+      IENotEnoughFunds addr amount ->+        IENotEnoughFunds (addrToAddrName addr is) amount+      IEFailedToApplyUpdates err -> IEFailedToApplyUpdates err+      IEIllTypedContract err -> IEIllTypedContract err
+ src/Michelson/Test/Unit.hs view
@@ -0,0 +1,75 @@+-- | Utility functions for unit testing.++module Michelson.Test.Unit+  ( ContractReturn+  , ContractPropValidator+  , contractProp+  , contractPropVal+  , contractRepeatedProp+  , contractRepeatedPropVal+  ) where++import Michelson.Interpret (ContractEnv, ContractReturn, interpret, interpretRepeated)+import Michelson.Typed (Contract, IsoValue(..), ToT)+import qualified Michelson.Typed as T++-- | Type for contract execution validation.+--+-- It's a function which is supplied with contract execution output+-- (failure or new storage with operation list).+--+-- Function returns a property which type is designated by type variable @prop@+-- and might be 'Test.QuickCheck.Property' or 'Test.Hspec.Expectation'+-- or anything else relevant.+type ContractPropValidator st prop = ContractReturn st -> prop++-- | Contract's property tester against given input.+-- Takes contract environment, initial storage and parameter,+-- interprets contract on this input and invokes validation function.+contractProp+  :: ( IsoValue param, IsoValue storage+     , ToT param ~ cp, ToT storage ~ st+     )+  => Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> param+  -> storage+  -> prop+contractProp instr check env param initSt =+  contractPropVal instr check env (toVal param) (toVal initSt)++-- | Version of 'contractProp' which takes 'Val' as arguments instead+-- of regular Haskell values.+contractPropVal+  :: Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> T.Value cp+  -> T.Value st+  -> prop+contractPropVal instr check env param initSt =+  check $ interpret instr param initSt env++contractRepeatedProp+  :: ( IsoValue param, IsoValue storage+     , ToT param ~ cp, ToT storage ~ st+     )+  => Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> [param]+  -> storage+  -> prop+contractRepeatedProp instr check env params initSt =+  contractRepeatedPropVal instr check env (map toVal params) (toVal initSt)++contractRepeatedPropVal+  :: Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> [T.Value cp]+  -> T.Value st+  -> prop+contractRepeatedPropVal instr check env params initSt =+  check $ interpretRepeated instr params initSt env
+ src/Michelson/Test/Util.hs view
@@ -0,0 +1,42 @@+-- | Testing utility functions used by testing framework itself or+-- intended to be used by test writers.++module Michelson.Test.Util+  ( leftToShowPanic+  , leftToPrettyPanic+  , failedProp+  , succeededProp+  , qcIsLeft+  , qcIsRight+  ) where++import Fmt (Buildable, pretty)+import Test.QuickCheck.Property (Property, Result(..), failed, property)++leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a+leftToShowPanic = either (error . show) id++leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a+leftToPrettyPanic = either (error . pretty) id++----------------------------------------------------------------------------+-- Property+----------------------------------------------------------------------------++-- | A 'Property' that always failes with given message.+failedProp :: Text -> Property+failedProp r = property $ failed { reason = toString r }++-- | A 'Property' that always succeeds.+succeededProp :: Property+succeededProp = property True++-- | The 'Property' holds on `Left a`.+qcIsLeft :: Show b => Either a b -> Property+qcIsLeft (Left _)  = property True+qcIsLeft (Right x) = failedProp $ "expected Left, got Right (" <> show x <> ")"++-- | The 'Property' holds on `Right b`.+qcIsRight :: Show a => Either a b -> Property+qcIsRight (Right _) = property True+qcIsRight (Left x)  = failedProp $ "expected Right, got Left (" <> show x <> ")"
+ src/Michelson/Text.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- deriving 'Container' automatically produces extra constraints.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Strings compliant with Michelson constraints.+--+-- When writting a Michelson contract, you can only mention characters with+-- codes from @[32 .. 126]@ range in string literals. Same restriction applies+-- to string literals passed to @alphanet.sh@.+--+-- However, Michelson allows some control sequences: @"\n"@. You have to write+-- it exactly in this form, and internally it will be transformed to line feed+-- character (this behaviour can be observed when looking at @Pack@ed data).+--+-- See tests for examples of good and bad strings.+module Michelson.Text+  ( MText (..)+  , mkMText+  , mkMTextUnsafe+  , mkMTextCut+  , writeMText+  , takeMText+  , dropMText+  , isMChar++    -- * Misc+  , qqMText+  , mt+  , DoNotUseTextError+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Data (Data)+import qualified Data.Text as T+import Fmt (Buildable)+import GHC.TypeLits (ErrorMessage(..), TypeError)+import qualified Language.Haskell.TH.Quote as TH+import Test.QuickCheck (Arbitrary(..), choose, listOf)++-- | Michelson string value.+--+-- This is basically a mere text with limits imposed by the language:+-- <http://tezos.gitlab.io/zeronet/whitedoc/michelson.html#constants>+-- Although, this document seems to be not fully correct, and thus we applied+-- constraints deduced empirically.+--+-- You construct an item of this type using one of the following ways:+--+-- * With QuasyQuotes when need to create a string literal.+--+-- >>> [mt|Some text|]+-- MTextUnsafe { unMText = "Some text" }+--+-- * With 'mkMText' when constructing from a runtime text value.+--+-- * With 'mkMTextUnsafe' or 'MTextUnsafe' when absolutelly sure that+-- given string does not violate invariants.+--+-- * With 'mkMTextCut' when not sure about text contents and want+-- to make it compliant with Michelson constraints.+newtype MText = MTextUnsafe { unMText :: Text }+  deriving stock (Show, Eq, Ord, Data)+  deriving newtype (Semigroup, Monoid, Container, Buildable)++-- | Constraint on literals appearing in Michelson contract code.+isMChar :: Char -> Bool+isMChar c = fromEnum c >= 32 && fromEnum c <= 126++-- | Error message indicating bad character in a string literal.+invalidMCharError :: Char -> Text+invalidMCharError c = "Invalid character in string literal: " <> toText [c]++-- | Wrap a Haskell text into 'MText', performing necessary checks.+--+-- You can use e.g. @'\n'@ character directly in supplied argument,+-- but attempt to use other bad characters like @'\r'@ will cause failure.+mkMText :: Text -> Either Text MText+mkMText txt = mapM checkMChar (toString txt) $> MTextUnsafe txt+  where+    checkMChar c+      | isMChar c || c == '\n' = pass+      | otherwise = Left $ invalidMCharError c++-- | Contruct 'MText' from a Haskell text, failing if provided Haskell text+-- is invalid Michelson string.+mkMTextUnsafe :: HasCallStack => Text -> MText+mkMTextUnsafe = either error id . mkMText++-- | Construct 'MText' from a Haskell text, eliminating all characters which+-- should not appear in Michelson strings.+-- Characters which can be displayed normally via escaping are preserved.+mkMTextCut :: Text -> MText+mkMTextCut txt =+  MTextUnsafe . toText . filter isAllowed $ toString txt+  where+    isAllowed c = isMChar c || c == '\n'++-- | Print 'MText' for Michelson code, with all unusual characters escaped.+writeMText :: MText -> Text+writeMText (MTextUnsafe t) = t+  & T.replace "\\" "\\\\"+  & T.replace "\n" "\\n"+  & T.replace "\"" "\\\""++takeMText :: Int -> MText -> MText+takeMText n (MTextUnsafe txt) = MTextUnsafe $ T.take n txt++dropMText :: Int -> MText -> MText+dropMText n (MTextUnsafe txt) = MTextUnsafe $ T.drop n txt++instance ToText MText where+  toText = unMText++instance Arbitrary MText where+  arbitrary =+    mkMTextUnsafe . toText <$>+    listOf (choose @Char (toEnum 32, toEnum 126))++instance ToJSON MText where+  toJSON = toJSON . unMText+instance FromJSON MText where+  parseJSON v =+    either (fail . toString) pure . mkMText =<< parseJSON @Text v++-- | QuasyQuoter for constructing Michelson strings.+--+-- Validity of result will be checked at compile time.+-- Note:+--+-- * slash must be escaped+-- * newline character must appear as '\n'+-- * use quotes as is+-- * other special characters are not allowed.++-- TODO: maybe enforce one space in the beginning and one in the end?+-- compare:+-- >>> [mt|mystuff|]+-- vs+-- >>> [mt| mystuff |]+mt :: TH.QuasiQuoter+mt = TH.QuasiQuoter+  { TH.quoteExp = \s ->+      case qqMText s of+        Left err -> fail $ toString err+        Right txt -> [e| MTextUnsafe (toText @String txt) |]+  , TH.quotePat = \_ ->+      fail "Cannot use this QuasyQuotation at pattern position"+  , TH.quoteType = \_ ->+      fail "Cannot use this QuasyQuotation at type position"+  , TH.quoteDec = \_ ->+      fail "Cannot use this QuasyQuotation at declaration position"+  }++{-# ANN module ("HLint: ignore Use list literal pattern" :: Text) #-}++-- | Parser used in 'mt' quasi quoter.+qqMText :: String -> Either Text String+qqMText txt = scan txt+  where+  scan = \case+    '\\' : [] -> Left "Unterminated '\' in string literal"+    '\\' : '\\' : s -> ('\\' :) <$> scan s+    '\\' : 'n'  : s -> ('\n' :) <$> scan s+    '\\' : c : _ -> Left $ "Unknown escape sequence: '\\" <> toText [c] <> "'"+    c : s+      | isMChar c -> (c :) <$> scan s+      | otherwise -> Left $ invalidMCharError c+    [] -> Right []++instance+    TypeError ('Text "There is no instance defined for (IsString MText)" ':$$:+               'Text "Consider using QuasiQuotes: `[mt|some text...|]`"+              ) =>+    IsString MText where+  fromString = error "impossible"++-- | A type error asking to use 'MText' instead of 'Text'.+type family DoNotUseTextError where+  DoNotUseTextError = TypeError+    ( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:+      'Text "consider using `MText` type instead"+    )
src/Michelson/TypeCheck.hs view
@@ -1,14 +1,22 @@ module Michelson.TypeCheck   ( typeCheckContract-  , typeCheckVal+  , typeCheckValue+  , typeVerifyValue   , typeCheckList-  , typeCheckCVal+  , typeCheckCValue+  , typeCheckExt+  , module E   , module M-  , eqT'+  , module T+  , eqType+  , compareTypes   ) where +import Michelson.TypeCheck.Error as E+import Michelson.TypeCheck.Ext import Michelson.TypeCheck.Instr+import Michelson.TypeCheck.TypeCheck as T import Michelson.TypeCheck.Types as M import Michelson.TypeCheck.Value -import Michelson.TypeCheck.Helpers (eqT')+import Michelson.TypeCheck.Helpers (compareTypes, eqType)
+ src/Michelson/TypeCheck/Error.hs view
@@ -0,0 +1,128 @@+module Michelson.TypeCheck.Error+  ( TCTypeError (..)+  , TCError (..)+  , ExtError (..)+  , StackSize (..)+  ) where+++import Fmt (Buildable(..), listF, pretty, (+|), (+||), (|+), (||+))+import qualified Text.Show (show)++import Michelson.ErrorPos (InstrCallStack)+import Michelson.TypeCheck.Types (SomeHST(..))+import qualified Michelson.Typed as T+import Michelson.Typed.Annotation (AnnConvergeError(..))+import Michelson.Typed.Extract (TypeConvergeError(..), toUType)+import Michelson.Typed.Print (buildStack)+import Michelson.Untyped (StackFn, Type, Var)+import qualified Michelson.Untyped as U++-- | Data type that represents various errors+-- which are related to type system.+-- These errors are used to specify info about type check errors+-- in @TCError@ data type.+data TCTypeError+  = AnnError AnnConvergeError+  -- ^ Annotation unify error+  | ExtractionTypeMismatch TypeConvergeError+  -- ^ Notes extraction error+  | TypeEqError T.T T.T+  -- ^ Type equality error+  | StackEqError [T.T] [T.T]+  -- ^ Stacks equality error+  | UnsupportedTypes [T.T]+  -- ^ Error that happens when some instruction doesn't+  -- have support for some types+  | UnknownType T.T+  -- ^ Error that happens when we meet unknown type+  deriving (Show, Eq)++instance Buildable TCTypeError where+  build (AnnError e) = build e+  build (ExtractionTypeMismatch e) = build e+  build (TypeEqError type1 type2) =+    "Types not equal: " +| type1 |+ " /= " +| type2 |+ ""+  build (StackEqError st1 st2) =+    "Stacks not equal: " +| buildStack st1 |+ " /= " +| buildStack st2 |+ ""+  build (UnsupportedTypes types) =+    "Unsupported types: " +| listF types |+ ""+  build (UnknownType t) =+    "Unknown type `" +| t |+ "`"++-- | Type check error+data TCError+  = TCFailedOnInstr U.ExpandedInstr SomeHST Text InstrCallStack (Maybe TCTypeError)+  | TCFailedOnValue U.Value T.T Text InstrCallStack (Maybe TCTypeError)+  | TCContractError Text (Maybe TCTypeError)+  | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp)+  | TCExtError SomeHST InstrCallStack ExtError+  deriving (Eq)++-- TODO pva701: an instruction position should be used in+-- Buildable instance within TM-151.+instance Buildable TCError where+  build = \case+    TCFailedOnInstr instr (SomeHST t) custom _ mbTCTypeError ->+      "Error checking expression "+      +| instr |+ " against input stack type "+      +| t ||+ bool (": " +| custom |+ " ") "" (null custom)+      +| (maybe "" (\e -> " " +| e |+ "") mbTCTypeError)+    TCFailedOnValue v t custom _ mbTCTypeError ->+      "Error checking value "+      +| v |+ " against type "+      +| toUType t |+ bool (": " +| custom |+ " ") "" (null custom)+      +| (maybe "" (\e -> " " +| e |+ "") mbTCTypeError)+    TCContractError msg typeError ->+      "Error occured during contract typecheck: "+      +|| msg ||+ (maybe "" (\e -> " " +| e |+ "") typeError)+    TCUnreachableCode _ instrs ->+      "Unreachable code: " +| take 3 (toList instrs) |+ " ..."+    TCExtError (SomeHST t) _ e ->+      "Error occured during Morley extension typecheck: "+      +| e |+ " on stack " +| t ||+ ""++instance Buildable U.ExpandedInstr => Show TCError where+  show = pretty++instance Buildable U.ExpandedInstr => Exception TCError++newtype StackSize = StackSize Natural+  deriving (Show, Eq)++-- | Various type errors possible when checking Morley extension commands+data ExtError =+    LengthMismatch U.StackTypePattern+  | VarError Text StackFn+  | TypeMismatch U.StackTypePattern Int TCTypeError+  | TyVarMismatch Var Type U.StackTypePattern Int TCTypeError+  | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError+  | TestAssertError Text+  | InvalidStackReference U.StackRef StackSize+  deriving (Eq)++instance Buildable ExtError where+  build = \case+    LengthMismatch stk ->+      "Unexpected length of stack: pattern "+      +| stk |+ " has length "+      +| (length . fst . U.stackTypePatternToList) stk |+ ""+    VarError t sf ->+      "In defenition of " +| t |+ ": VarError "+      +| sf |+ ""+    TypeMismatch stk i e ->+      "TypeMismatch: Pattern " +| stk |+ " at index "+      +| i |+ " with error: " +| e |+ ""+    TyVarMismatch v t stk i e ->+      "TyVarMismach: Variable " +| v |+ " is bound to type "+      +| t |+ " but pattern " +| stk |+ " failed at index "+      +| i |+ " with error: " +| e |+ ""+    StkRestMismatch stk (SomeHST r) (SomeHST r') e ->+      "StkRestMismatch in pattern " +| stk |++      " against stacks " +| r ||+ " and " +| r' ||++      " with error: " +| e |+ ""+    TestAssertError t ->+      "TestAssertError: " +| t |+ ""+    InvalidStackReference i lhs ->+      "InvalidStackReference: reference is out of the stack: "+      +| i ||+ " >= " +| lhs ||+ ""
+ src/Michelson/TypeCheck/Ext.hs view
@@ -0,0 +1,162 @@+-- | Type-checking of Morley extension.+module Michelson.TypeCheck.Ext+  ( typeCheckExt+  ) where++import Control.Lens ((%=))+import Control.Monad.Except (MonadError, liftEither, throwError)+import Data.Map.Lazy (Map, insert, lookup)+import Data.Singletons (Sing)+import Data.Typeable ((:~:)(..))++import Michelson.ErrorPos+import Michelson.TypeCheck.Error+import Michelson.TypeCheck.Helpers+import Michelson.TypeCheck.TypeCheck+import Michelson.TypeCheck.Types+import Michelson.Typed (converge, extractNotes, mkUType)+import qualified Michelson.Typed as T+import Michelson.Untyped+  (CT(..), ExpandedOp, StackFn, TyVar(..), Type, Var, VarAnn, inPattern, outPattern,+  quantifiedVars, varSet)+import qualified Michelson.Untyped as U+import Util.Peano (Sing(SS, SZ))++type TypeCheckListHandler inp =+     [U.ExpandedOp]+  -> HST inp+  -> TypeCheck (SomeInstr inp)++typeCheckExt+  :: forall s.+     (Typeable s)+  => TypeCheckListHandler s+  -> U.ExpandedExtInstr+  -> HST s+  -> TypeCheckInstr (SomeInstr s)+typeCheckExt typeCheckListH ext hst = do+  instrPos <- ask+  case ext of+    U.STACKTYPE s -> liftExtError hst $ nopSomeInstr <$ checkStackType noBoundVars s hst+    U.FN t sf op  -> checkFn typeCheckListH t sf op hst+    U.UPRINT pc   -> verifyPrint pc <&> \tpc -> toSomeInstr (T.PRINT tpc)+    U.UTEST_ASSERT U.TestAssert{..} -> do+      verifyPrint tassComment+      _ :/ si <- lift $ typeCheckListH tassInstrs hst+      case si of+        AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError+                         "TEST_ASSERT has to return Bool, but it always fails"+        instr ::: (((_ :: (Sing b, T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do+          Refl <- liftEither $+                    first (const $ TCExtError (SomeHST hst) instrPos $+                           TestAssertError "TEST_ASSERT has to return Bool, but returned something else") $+                      eqType @b @('T.Tc 'CBool)+          tcom <- verifyPrint tassComment+          pure . toSomeInstr $ T.TEST_ASSERT $ T.TestAssert tassName tcom instr+        _ ->+          throwError $ TCExtError (SomeHST hst) instrPos $+            TestAssertError "TEST_ASSERT has to return Bool, but the stack is empty"+  where+    verifyPrint :: U.PrintComment -> TypeCheckInstr (T.PrintComment s)+    verifyPrint (U.PrintComment pc) = do+      let checkStRef (Left txt)             = pure $ Left txt+          checkStRef (Right (U.StackRef i)) = Right <$> createStackRef i hst+      T.PrintComment <$> traverse checkStRef pc++    toSomeInstr ext' = hst :/ T.Ext ext' ::: hst+    nopSomeInstr = hst :/ T.Nop ::: hst++liftExtError :: Typeable s => HST s -> Either ExtError a -> TypeCheckInstr a+liftExtError hst ei = do+  instrPos <- ask+  liftEither $ first (TCExtError (SomeHST hst) instrPos) ei++-- | Check that the optional "forall" variables are consistent if present+checkVars :: Text -> StackFn -> Either ExtError ()+checkVars t sf = case quantifiedVars sf of+  Just qs+    | varSet (inPattern sf) /= qs -> Left $ VarError t sf+  _ -> pass++-- | Executes function body, pushing @ExtFrame@ onto the state and checks+-- the pattern in @FN@.+checkFn+  :: Typeable inp+  => TypeCheckListHandler inp+  -> Text+  -> StackFn+  -> [ExpandedOp]+  -> HST inp+  -> TypeCheckInstr (SomeInstr inp)+checkFn typeCheckListH t sf body inp = do+  vars <- checkStart inp+  res@(_ :/ instr) <- lift $ typeCheckListH body inp+  case instr of+    _ ::: out -> checkEnd vars out+    AnyOutInstr _ -> pass+  return res+  where+    checkStart hst = do+      liftExtError hst $ checkVars t sf+      vars <- liftExtError hst $ checkStackType noBoundVars (inPattern sf) hst+      tcExtFramesL %= (vars :)+      return vars++    checkEnd :: Typeable out => BoundVars -> HST out -> TypeCheckInstr ()+    checkEnd vars out = liftExtError out $+      void $ checkStackType vars (outPattern sf) out++-- | Check that a @StackTypePattern@ matches the type of the current stack+checkStackType+  :: Typeable xs+  => BoundVars+  -> U.StackTypePattern+  -> HST xs+  -> Either ExtError BoundVars+checkStackType (BoundVars vars boundStkRest) s hst = go vars 0 s hst+  where+    go :: Typeable xs => Map Var Type -> Int -> U.StackTypePattern -> HST xs+       -> Either ExtError BoundVars+    go m _ U.StkRest sr = case boundStkRest of+      Nothing -> pure $ BoundVars m (Just $ SomeHST sr)+      Just si@(SomeHST sr') ->+        bimap (StkRestMismatch s (SomeHST sr) si)+              (const $ BoundVars m (Just si))+              (eqHST sr sr')+    go m _ U.StkEmpty SNil = pure $ BoundVars m Nothing+    go _ _ U.StkEmpty _    = Left $ LengthMismatch s+    go _ _ _ SNil        = Left $ LengthMismatch s+    go m n (U.StkCons (TyCon t) ts) ((xt, xann, _) ::& xs) = do+      tann <- first (TypeMismatch s n . ExtractionTypeMismatch) (extractNotes t xt)+      void $ first (TypeMismatch s n . AnnError) (converge tann xann)+      go m (n + 1) ts xs+    go m n (U.StkCons (VarID v) ts) ((xt, xann, _) ::& xs) =+      case lookup v m of+        Nothing -> let t = mkUType xt xann in go (insert v t m) (n + 1) ts xs+        Just t -> do+          tann <- first (TyVarMismatch v t s n . ExtractionTypeMismatch) (extractNotes t xt)+          void $ first (TyVarMismatch v t s n . AnnError) (converge tann xann)+          go m (n + 1) ts xs++-- | Create stack reference accessing element with a given index.+--+-- Fails when index is too large for the given stack.+createStackRef+  :: (MonadError TCError m, MonadReader InstrCallStack m, Typeable s)+  => Natural -> HST s -> m (T.StackRef s)+createStackRef idx hst =+  case doCreate (hst, idx) of+    Just sr -> pure sr+    Nothing -> do+      instrPos <- ask+      throwError $+        TCExtError (SomeHST hst) instrPos $+          InvalidStackReference (U.StackRef idx) (StackSize $ lengthHST hst)+  where+    doCreate :: forall s. (HST s, Natural) -> Maybe (T.StackRef s)+    doCreate = \case+      (SNil, _) -> Nothing+      ((_ ::& _), 0) -> Just (T.StackRef SZ)+      ((_ ::& st), i) -> do+        T.StackRef ns <- doCreate (st, i - 1)+        return $ T.StackRef (SS ns)
src/Michelson/TypeCheck/Helpers.hs view
@@ -7,14 +7,21 @@     , deriveNsOption     , convergeHSTEl     , convergeHST+    , hstToTs+    , eqHST+    , eqHST1+    , lengthHST      , ensureDistinctAsc-    , eqT'-    , assertEqT+    , eqType     , checkEqT+    , checkEqHST+    , onTypeCheckInstrAnnErr+    , onTypeCheckInstrTypeErr+    , onTypeCheckInstrErr     , typeCheckInstrErr-    , typeCheckInstrErrM     , typeCheckImpl+    , compareTypes      , memImpl     , getImpl@@ -34,17 +41,23 @@  import Prelude hiding (EQ, GT, LT) -import Control.Monad.Except (liftEither, throwError)+import Control.Monad.Except (MonadError, liftEither, throwError) import Data.Default (def)-import Data.Singletons (SingI(sing))+import Data.Singletons (SingI(sing), demote) import qualified Data.Text as T-import Data.Typeable ((:~:)(..), eqT, typeRep)+import Data.Typeable ((:~:)(..), eqT) import Fmt ((+||), (||+)) +import Michelson.ErrorPos (InstrCallStack)+import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))+import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.Types import Michelson.Typed-  (CT(..), Instr(..), Notes(..), Notes'(..), Sing(..), T(..), converge, mkNotes, notesCase, orAnn)+  (CT(..), Instr(..), Notes(..), Notes'(..), Sing(..), T(..), converge, extractNotes, fromSingT,+  fromUType, mkNotes, notesCase, orAnn, withSomeSingT)+import Michelson.Typed.Annotation (AnnConvergeError) import Michelson.Typed.Arith (Add, ArithOp(..), Compare, Mul, Sub, UnaryArithOp(..))+import Michelson.Typed.Extract (TypeConvergeError) import Michelson.Typed.Polymorphic   (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..)) @@ -71,7 +84,7 @@   where     ps = T.splitOn "." pvn     qs = T.splitOn "." qvn-    fns = fst <$> takeWhile (\(a, b) -> a == b) (zip ps qs)+    fns = fst <$> takeWhile (uncurry (==)) (zip ps qs)     vn = Un.Annotation $ T.intercalate "." fns     pfn = Un.Annotation $ T.intercalate "." $ drop (length fns) ps     qfn = Un.Annotation $ T.intercalate "." $ drop (length fns) qs@@ -119,13 +132,13 @@ convergeHSTEl   :: (Sing t, Notes t, VarAnn)   -> (Sing t, Notes t, VarAnn)-  -> Either Text (Sing t, Notes t, VarAnn)+  -> Either AnnConvergeError (Sing t, Notes t, VarAnn) convergeHSTEl (at, an, avn) (_, bn, bvn) =   (,,) at <$> converge an bn           <*> pure (bool def avn $ avn == bvn)  -- | Combine annotations from two given stack types-convergeHST :: HST ts -> HST ts -> Either Text (HST ts)+convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts) convergeHST SNil SNil = pure SNil convergeHST (a ::& as) (b ::& bs) =     liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs)@@ -134,188 +147,307 @@ onLeft :: Either a c -> (a -> b) -> Either b c onLeft = flip first +-- | Extract singleton for each single type of the given stack.+hstToTs :: HST st -> [T]+hstToTs = \case+  SNil -> []+  (s, _, _) ::& hst -> fromSingT s : hstToTs hst++-- | Check whether the given stack types are equal.+eqHST+  :: forall as bs.+      (Typeable as, Typeable bs)+  => HST as -> HST bs -> Either TCTypeError (as :~: bs)+eqHST (hst :: HST xs) (hst' :: HST ys) = do+  case eqT @as @bs of+    Nothing -> Left $ StackEqError (hstToTs hst) (hstToTs hst')+    Just Refl -> do+      void $ convergeHST hst hst' `onLeft` AnnError+      return Refl++-- | Check whether the given stack has size 1 and its only element matches the+-- given type. This function is a specialized version of `eqHST`.+eqHST1+  :: forall t st.+      (Typeable st, Typeable t, SingI t)+  => HST st -> Either TCTypeError (st :~: '[t])+eqHST1 hst = do+  let hst' = sing @t -:& SNil+  case eqT @'[t] @st of+    Nothing -> Left $ StackEqError (hstToTs hst') (hstToTs hst)+    Just Refl -> Right Refl++lengthHST :: HST xs -> Natural+lengthHST (_ ::& xs) = 1 + lengthHST xs+lengthHST SNil = 0+ -------------------------------------------- -- Typechecker auxiliary --------------------------------------------  -- | Check whether elements go in strictly ascending order and -- return the original list (to keep only one pass on the original list).-ensureDistinctAsc :: (Ord a, Show a) => [a] -> Either Text [a]-ensureDistinctAsc = \case+ensureDistinctAsc :: (Ord b, Show a) => (a -> b) -> [a] -> Either Text [a]+ensureDistinctAsc toCmp = \case   (e1 : e2 : l) ->-    if e1 < e2-    then (e1 :) <$> ensureDistinctAsc (e2 : l)-    else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ""+    if toCmp e1 < toCmp e2+    then (e1 :) <$> ensureDistinctAsc toCmp (e2 : l)+    else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ")"   l -> Right l  checkEqT-  :: forall a b ts . (Typeable a, Typeable b, Typeable ts)+  :: forall (a :: T) (b :: T) ts m .+  ( Each [Typeable, SingI] [a, b], Typeable ts+  , MonadReader InstrCallStack m, MonadError TCError m+  )   => Un.ExpandedInstr   -> HST ts   -> Text-  -> Either TCError (a :~: b)-checkEqT instr i m =-  eqT' @a @b `onLeft` (TCFailedOnInstr instr (SomeHST i) . ((m <> ": ") <>))+  -> m (a :~: b)+checkEqT instr i m = do+  pos <- ask+  liftEither $ eqType @a @b `onLeft` (TCFailedOnInstr instr (SomeHST i) (m <> ": ") pos . Just) -assertEqT-  :: forall a b ts . (Typeable a, Typeable b, Typeable ts)-  => Un.ExpandedInstr+-- | Function @eqType@ is a simple wrapper around @Data.Typeable.eqT@ suited+-- for use within @Either TCTypeError a@ applicative.+eqType+  :: forall (a :: T) (b :: T).+      (Each [Typeable, SingI] [a, b])+  => Either TCTypeError (a :~: b)+eqType = maybe (Left $ TypeEqError (demote @a) (demote @b)) pure eqT++checkEqHST+  :: forall (a :: [T]) (b :: [T]) ts m .+  ( Typeable a, Typeable b, Typeable ts+  , MonadReader InstrCallStack m, MonadError TCError m+  )+  => HST a+  -> HST b+  -> Un.ExpandedInstr   -> HST ts-  -> Either TCError (a :~: b)-assertEqT instr i = checkEqT instr i "unexpected"+  -> Text+  -> m (a :~: b)+checkEqHST a b instr i m = do+  pos <- ask+  liftEither $ eqHST a b `onLeft` (TCFailedOnInstr instr (SomeHST i) (m <> ": ") pos . Just) --- | Function @eqT'@ is a simple wrapper around @Data.Typeable.eqT@ suited--- for use within @Either Text a@ applicative.-eqT' :: forall a b . (Typeable a, Typeable b) => Either Text (a :~: b)-eqT' = maybe (Left $-                "types not equal: "-                  <> show (typeRep (Proxy @a))-                  <> " /= "-                  <> show (typeRep (Proxy @b))-                  ) pure eqT+onTypeCheckInstrErr+  :: (MonadReader InstrCallStack m, MonadError TCError m)+  => Un.ExpandedInstr -> SomeHST -> Text -> Either TCTypeError a -> m a+onTypeCheckInstrErr instr hst msg ei = do+  pos <- ask+  liftEither $ ei `onLeft` (TCFailedOnInstr instr hst msg pos . Just) -typeCheckInstrErr :: Un.ExpandedInstr -> SomeHST -> Text -> Either TCError a-typeCheckInstrErr = Left ... TCFailedOnInstr+typeCheckInstrErr+  :: (MonadReader InstrCallStack m, MonadError TCError m)+  => Un.ExpandedInstr -> SomeHST -> Text -> m a+typeCheckInstrErr instr hst msg = do+  pos <- ask+  throwError $ TCFailedOnInstr instr hst msg pos Nothing -typeCheckInstrErrM :: Un.ExpandedInstr -> SomeHST -> Text -> TypeCheckT a-typeCheckInstrErrM = throwError ... TCFailedOnInstr+onTypeCheckInstrAnnErr+  :: (MonadReader InstrCallStack m, MonadError TCError m, Typeable ts)+  => Un.ExpandedInstr -> HST ts -> Text -> Either AnnConvergeError a -> m a+onTypeCheckInstrAnnErr instr i msg ei =+  onTypeCheckInstrErr instr (SomeHST i) msg (ei `onLeft` AnnError) +onTypeCheckInstrTypeErr+  :: (MonadReader InstrCallStack m, MonadError TCError m, Typeable ts)+  => Un.ExpandedInstr -> HST ts -> Text -> Either TypeConvergeError a -> m a+onTypeCheckInstrTypeErr instr i msg ei =+  onTypeCheckInstrErr instr (SomeHST i) msg (ei `onLeft` ExtractionTypeMismatch)+ typeCheckImpl-  :: TcInstrHandler+  :: forall inp . Typeable inp+  => TcInstrHandler   -> [Un.ExpandedOp]-  -> SomeHST-  -> TypeCheckT SomeInstr-typeCheckImpl tcInstr instrs t@(SomeHST (a :: HST a)) =+  -> HST inp+  -> TypeCheckInstr (SomeInstr inp)+typeCheckImpl tcInstr instrs t@(a :: HST a) =   case instrs of-    [Un.PrimEx i]       -> tcInstr i t-    (Un.SeqEx sq  : rs) -> typeCheckImplDo (typeCheckImpl tcInstr sq) Nested rs-    (Un.PrimEx p_ : rs) -> typeCheckImplDo (tcInstr p_) id rs-    []                   -> pure $ Nop ::: (a, a)+    Un.WithSrcEx _ (i@(Un.WithSrcEx _ _)) : rs -> typeCheckImpl tcInstr (i : rs) t+    Un.WithSrcEx cs (Un.PrimEx i) : rs -> typeCheckPrim (Just cs) i rs+    Un.WithSrcEx cs (Un.SeqEx sq) : rs -> typeCheckSeq (Just cs) sq rs+    Un.PrimEx i : rs                 -> typeCheckPrim Nothing i rs+    Un.SeqEx sq : rs                 -> typeCheckSeq Nothing sq rs+    []                               -> pure $ a :/ Nop ::: a   where+    typeCheckPrim (Just cs) i [] = local (const cs) $ tcInstr i t+    typeCheckPrim (Just cs) i rs = local (const cs) $ typeCheckImplDo (tcInstr i t) id rs+    typeCheckPrim Nothing i [] = tcInstr i t+    typeCheckPrim Nothing i rs = typeCheckImplDo (tcInstr i t) id rs++    typeCheckSeq (Just cs) sq = local (const cs) . typeCheckImplDo (typeCheckImpl tcInstr sq t) Nested+    typeCheckSeq Nothing sq = typeCheckImplDo (typeCheckImpl tcInstr sq t) Nested+     typeCheckImplDo-      :: (SomeHST -> TypeCheckT SomeInstr)-      -> (forall inp out . Instr inp out -> Instr inp out)+      :: TypeCheckInstr (SomeInstr inp)+      -> (forall inp' out . Instr inp' out -> Instr inp' out)       -> [Un.ExpandedOp]-      -> TypeCheckT SomeInstr-    typeCheckImplDo f wrap rs =-      f t >>= \case-        p ::: ((_ :: HST a'), (b :: HST b)) ->-          typeCheckImpl tcInstr rs (SomeHST b) >>= \case-            q ::: ((_ :: HST b'), c) -> do-              Refl <- liftEither $ eqT' @a @a' `onLeft` TCOtherError-              Refl <- liftEither $ eqT' @b @b' `onLeft` TCOtherError-              pure $ Seq (wrap p) q ::: (a, c)-            SiFail -> pure SiFail-        SiFail -> pure SiFail+      -> TypeCheckInstr (SomeInstr inp)+    typeCheckImplDo f wrap rs = do+      _ :/ pi' <- f+      case pi' of+        p ::: b -> do+          _ :/ qi <- typeCheckImpl tcInstr rs b+          case qi of+            q ::: c ->+              pure $ a :/ Seq (wrap p) q ::: c+            AnyOutInstr q ->+              pure $ a :/ AnyOutInstr (Seq (wrap p) q) +        AnyOutInstr instr ->+          case rs of+            [] ->+              pure $ a :/ AnyOutInstr instr+            r : rr ->+              throwError $ TCUnreachableCode (extractInstrPos r) (r :| rr)++    extractInstrPos :: Un.ExpandedOp -> InstrCallStack+    extractInstrPos (Un.WithSrcEx cs _) = cs+    extractInstrPos _ = def++-- | Check whether typed and untyped types converge+compareTypes+  :: forall t.+      (Typeable t, SingI t)+  => (Sing t, Notes t) -> Un.Type -> Either TCTypeError ()+compareTypes (_, n) tp = withSomeSingT (fromUType tp) $ \(t :: Sing ct) -> do+  Refl <- eqType @t @ct+  cnotes <- extractNotes tp t `onLeft` ExtractionTypeMismatch+  void $ converge n cnotes `onLeft` AnnError+ -------------------------------------------- -- Some generic instruction implementation --------------------------------------------  -- | Generic implementation for MEMeration memImpl-  :: forall (q :: CT) (c :: T) ts .-    (Typeable ts, Typeable q, Typeable (MemOpKey c), MemOp c)+  :: forall (q :: CT) (c :: T) ts inp m .+    ( MonadReader InstrCallStack m, MonadError TCError m, Typeable ts+    , Typeable (MemOpKey c), SingI (MemOpKey c), MemOp c+    , inp ~ ('Tc q : c : ts)+    )   => Un.ExpandedInstr-  -> HST ('Tc q ': c ': ts)+  -> HST inp   -> VarAnn-  -> TcResult-memImpl instr i@(_ ::& _ ::& rs) vn =-  case eqT' @q @(MemOpKey c) of-    Right Refl -> pure (MEM ::: (i, (STc SCBool, NStar, vn) ::& rs))-    Left m     -> typeCheckInstrErr instr (SomeHST i) $-                "query element type is not equal to set's element type: " <> m+  -> m (SomeInstr inp)+memImpl instr i@(_ ::& _ ::& rs) vn = do+  pos <- ask+  case eqType @('Tc q) @('Tc (MemOpKey c)) of+    Right Refl -> pure $ i :/ MEM ::: ((STc SCBool, NStar, vn) ::& rs)+    Left m     -> throwError $+      TCFailedOnInstr instr (SomeHST i) "query element type is not equal to set's element type" pos (Just m)  getImpl-  :: forall c getKey rs .+  :: forall c getKey rs inp m .     ( GetOp c, Typeable (GetOpKey c)     , Typeable (GetOpVal c)-    , SingI (GetOpVal c)+    , SingI (GetOpVal c), SingI (GetOpKey c)+    , inp ~ (getKey : c : rs)+    , MonadReader InstrCallStack m+    , MonadError TCError m     )   => Un.ExpandedInstr   -> HST (getKey ': c ': rs)   -> Sing (GetOpVal c)   -> Notes (GetOpVal c)   -> VarAnn-  -> TcResult+  -> m (SomeInstr inp) getImpl instr i@(_ ::& _ ::& rs) rt vns vn = do-  case eqT' @getKey @('Tc (GetOpKey c)) of+  pos <- ask+  case eqType @getKey @('Tc (GetOpKey c)) of     Right Refl -> do       let rn = mkNotes $ NTOption def def vns-      pure $ GET ::: (i, (STOption rt, rn, vn) ::& rs)-    Left m -> typeCheckInstrErr instr (SomeHST i) $-                    "wrong key stack type" <> m+      pure $ i :/ GET ::: ((STOption rt, rn, vn) ::& rs)+    Left m -> throwError $ TCFailedOnInstr instr (SomeHST i) "wrong key stack type" pos (Just m)  updImpl-  :: forall c updKey updParams rs .-    (UpdOp c, Typeable (UpdOpKey c), Typeable (UpdOpParams c))+  :: forall c updKey updParams rs inp m .+    ( UpdOp c+    , Typeable (UpdOpKey c), SingI (UpdOpKey c)+    , Typeable (UpdOpParams c), SingI (UpdOpParams c)+    , inp ~ (updKey : updParams : c : rs)+    , MonadReader InstrCallStack m+    , MonadError TCError m+    )   => Un.ExpandedInstr   -> HST (updKey ': updParams ': c ': rs)-  -> TcResult+  -> m (SomeInstr inp) updImpl instr i@(_ ::& _ ::& crs) = do-  case (eqT' @updKey @('Tc (UpdOpKey c)), eqT' @updParams @(UpdOpParams c)) of-    (Right Refl, Right Refl) -> pure $ UPDATE ::: (i, crs)-    (Left m, _) -> typeCheckInstrErr instr (SomeHST i) $-                      "wrong key stack type" <> m-    (_, Left m) -> typeCheckInstrErr instr (SomeHST i) $-                      "wrong update value stack type" <> m+  pos <- ask+  case (eqType @updKey @('Tc (UpdOpKey c)), eqType @updParams @(UpdOpParams c)) of+    (Right Refl, Right Refl) -> pure $ i :/ UPDATE ::: crs+    (Left m, _) -> throwError $ TCFailedOnInstr instr (SomeHST i)+                      "wrong key stack type" pos (Just m)+    (_, Left m) -> throwError $ TCFailedOnInstr instr (SomeHST i)+                      "wrong update value stack type" pos (Just m)  sizeImpl-  :: SizeOp c-  => HST (c ': rs)+  :: (SizeOp c, inp ~ (c ': rs), Monad m)+  => HST inp   -> VarAnn-  -> TcResult-sizeImpl i@(_ ::& rs) vn =-  pure $ SIZE ::: (i, (STc SCNat, NStar, vn) ::& rs)+  -> m (SomeInstr inp)+sizeImpl i@(_ ::& rs) vn = pure $ i :/ SIZE ::: ((STc SCNat, NStar, vn) ::& rs)  sliceImpl-  :: (SliceOp c, Typeable c)-  => HST ('Tc 'CNat : 'Tc 'CNat : c : rs)+  :: (SliceOp c, Typeable c, inp ~ ('Tc 'CNat ': 'Tc 'CNat ': c ': rs), Monad m)+  => HST inp   -> Un.VarAnn-  -> TcResult+  -> m (SomeInstr inp) sliceImpl i@(_ ::& _ ::& (c, cn, cvn) ::& rs) vn = do   let vn' = vn `orAnn` deriveVN "slice" cvn       rn = mkNotes $ NTOption def def cn-  pure $ SLICE ::: (i, (STOption c, rn, vn') ::& rs)+  pure $ i :/ SLICE ::: ((STOption c, rn, vn') ::& rs)  concatImpl'-  :: (ConcatOp c, Typeable c)-  => HST ('TList c : rs)+  :: (ConcatOp c, Typeable c, inp ~ ('TList c : rs), Monad m)+  => HST inp   -> Un.VarAnn-  -> TcResult+  -> m (SomeInstr inp) concatImpl' i@((STList c, ln, _) ::& rs) vn = do   let cn = notesCase NStar (\(NTList _ n) -> n) ln-  pure $ CONCAT' ::: (i, (c, cn, vn) ::& rs)+  pure $ i :/ CONCAT' ::: ((c, cn, vn) ::& rs)  concatImpl-  :: (ConcatOp c, Typeable c)-  => HST (c : c : rs)+  :: ( ConcatOp c, Typeable c, inp ~ (c ': c ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )+  => HST inp   -> Un.VarAnn-  -> TcResult+  -> m (SomeInstr inp) concatImpl i@((c, cn1, _) ::& (_, cn2, _) ::& rs) vn = do-  cn <- converge cn1 cn2 `onLeft` TCFailedOnInstr (Un.CONCAT vn) (SomeHST i)-  pure $ CONCAT ::: (i, (c, cn, vn) ::& rs)+  cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i "wrong operand types for concat operation" (converge cn1 cn2)+  pure $ i :/ CONCAT ::: ((c, cn, vn) ::& rs)  -- | Helper function to construct instructions for binary arithmetic---erations.+-- operations. arithImpl   :: ( Typeable (ArithRes aop n m)      , SingI (ArithRes aop n m)      , Typeable ('Tc (ArithRes aop n m) ': s)+     , inp ~ ('Tc n ': 'Tc m ': s)+     , Monad t      )-  => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes aop n m) ': s)-  -> HST ('Tc n ': 'Tc m ': s)+  => Instr inp ('Tc (ArithRes aop n m) ': s)+  -> HST inp   -> VarAnn-  -> TcResult-arithImpl mkInstr i@(_ ::& _ ::& rs) vn =-  pure $ mkInstr ::: (i, (sing, NStar, vn) ::& rs)+  -> t (SomeInstr inp)+arithImpl mkInstr i@(_ ::& _ ::& rs) vn = pure $ i :/ mkInstr ::: ((sing, NStar, vn) ::& rs)  addImpl-  :: (Typeable rs, Typeable a, Typeable b)+  :: forall a b inp rs m.+     ( Typeable rs+     , Each [Typeable, SingI] [a, b]+     , inp ~ ('Tc a ': 'Tc b ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )   => Sing a -> Sing b-  -> HST ('Tc a ': 'Tc b ': rs)+  -> HST inp   -> VarAnn-  -> TcResult+  -> m (SomeInstr inp) addImpl SCInt SCInt = arithImpl @Add ADD addImpl SCInt SCNat = arithImpl @Add ADD addImpl SCNat SCInt = arithImpl @Add ADD@@ -323,21 +455,31 @@ addImpl SCInt SCTimestamp = arithImpl @Add ADD addImpl SCTimestamp SCInt = arithImpl @Add ADD addImpl SCMutez SCMutez = arithImpl @Add ADD-addImpl _ _ = \i vn -> typeCheckInstrErr (Un.ADD vn) (SomeHST i) ""+addImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.ADD vn) (SomeHST i)+  "wrong operand types for add operation"+  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  edivImpl-  :: (Typeable rs, Typeable a, Typeable b)+  :: forall a b inp rs m.+     ( Typeable rs+     , Each [Typeable, SingI] [a, b]+     , inp ~ ('Tc a ': 'Tc b ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )   => Sing a -> Sing b-  -> HST ('Tc a ': 'Tc b ': rs)+  -> HST inp   -> VarAnn-  -> TcResult+  -> m (SomeInstr inp) edivImpl SCInt SCInt = edivImplDo edivImpl SCInt SCNat = edivImplDo edivImpl SCNat SCInt = edivImplDo edivImpl SCNat SCNat = edivImplDo edivImpl SCMutez SCMutez = edivImplDo edivImpl SCMutez SCNat = edivImplDo-edivImpl _ _ = \i vn -> typeCheckInstrErr (Un.EDIV vn) (SomeHST i) ""+edivImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.EDIV vn) (SomeHST i)+  "wrong operand types for ediv operation"+  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  edivImplDo   :: ( EDivOp n m@@ -345,19 +487,27 @@      , Typeable (EModOpRes n m)      , SingI (EDivOpRes n m)      , Typeable (EDivOpRes n m)+     , inp ~ ('Tc n ': 'Tc m ': s)+     , Monad t      )-  => HST ('Tc n ': 'Tc m ': s)+  => HST inp   -> VarAnn-  -> TcResult+  -> t (SomeInstr inp) edivImplDo i@(_ ::& _ ::& rs) vn =-  pure $ EDIV ::: (i, (sing, NStar, vn) ::& rs)+  pure $ i :/ EDIV ::: ((sing, NStar, vn) ::& rs)  subImpl-  :: (Typeable rs, Typeable a, Typeable b)+  :: forall a b inp rs m.+     ( Typeable rs+     , Each [Typeable, SingI] [a, b]+     , inp ~ ('Tc a ': 'Tc b ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )   => Sing a -> Sing b-  -> HST ('Tc a ': 'Tc b ': rs)+  -> HST inp   -> VarAnn-  -> TcResult+  -> m (SomeInstr inp) subImpl SCInt SCInt = arithImpl @Sub SUB subImpl SCInt SCNat = arithImpl @Sub SUB subImpl SCNat SCInt = arithImpl @Sub SUB@@ -365,28 +515,44 @@ subImpl SCTimestamp SCTimestamp = arithImpl @Sub SUB subImpl SCTimestamp SCInt = arithImpl @Sub SUB subImpl SCMutez SCMutez = arithImpl @Sub SUB-subImpl _ _ = \i vn -> typeCheckInstrErr (Un.SUB vn) (SomeHST i) ""+subImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.SUB vn) (SomeHST i)+  "wrong operand types for sub operation"+  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  mulImpl-  :: (Typeable rs, Typeable a, Typeable b)+  :: forall a b inp rs m.+     ( Typeable rs+     , Each [Typeable, SingI] [a, b]+     , inp ~ ('Tc a ': 'Tc b ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )   => Sing a -> Sing b-  -> HST ('Tc a ': 'Tc b ': rs)+  -> HST inp   -> VarAnn-  -> TcResult+  -> m (SomeInstr inp) mulImpl SCInt SCInt = arithImpl @Mul MUL mulImpl SCInt SCNat = arithImpl @Mul MUL mulImpl SCNat SCInt = arithImpl @Mul MUL mulImpl SCNat SCNat = arithImpl @Mul MUL mulImpl SCNat SCMutez = arithImpl @Mul MUL mulImpl SCMutez SCNat = arithImpl @Mul MUL-mulImpl _ _ = \i vn -> typeCheckInstrErr (Un.MUL vn) (SomeHST i) ""+mulImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.MUL vn) (SomeHST i)+  "wrong operand types for mul operation"+  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  compareImpl-  :: (Typeable rs, Typeable a, Typeable b)+  :: forall a b inp rs m.+     ( Typeable rs+     , Each [Typeable, SingI] [a, b]+     , inp ~ ('Tc a ': 'Tc b ': rs)+     , MonadReader InstrCallStack m+     , MonadError TCError m+     )   => Sing a -> Sing b-  -> HST ('Tc a ': 'Tc b ': rs)+  -> HST inp   -> VarAnn-  -> TcResult+  -> m (SomeInstr inp) compareImpl SCBool SCBool = arithImpl @Compare COMPARE compareImpl SCNat SCNat = arithImpl @Compare COMPARE compareImpl SCAddress SCAddress = arithImpl @Compare COMPARE@@ -396,18 +562,22 @@ compareImpl SCTimestamp SCTimestamp = arithImpl @Compare COMPARE compareImpl SCKeyHash SCKeyHash = arithImpl @Compare COMPARE compareImpl SCMutez SCMutez = arithImpl @Compare COMPARE-compareImpl _ _ = \i vn -> typeCheckInstrErr (Un.COMPARE vn) (SomeHST i) ""+compareImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.COMPARE vn) (SomeHST i)+  "wrong operand types for compare operation"+  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  -- | Helper function to construct instructions for binary arithmetic---erations.+-- operations. unaryArithImpl   :: ( Typeable (UnaryArithRes aop n)      , SingI (UnaryArithRes aop n)      , Typeable ('Tc (UnaryArithRes aop n) ': s)+     , inp ~ ('Tc n ': s)+     , Monad t      )-  => Instr ('Tc n ': s) ('Tc (UnaryArithRes aop n) ': s)-  -> HST ('Tc n ': s)+  => Instr inp ('Tc (UnaryArithRes aop n) ': s)+  -> HST inp   -> VarAnn-  -> TcResult+  -> t (SomeInstr inp) unaryArithImpl mkInstr i@(_ ::& rs) vn =-  pure $ mkInstr ::: (i, (sing, NStar, vn) ::& rs)+  pure $ i :/ mkInstr ::: ((sing, NStar, vn) ::& rs)
src/Michelson/TypeCheck/Instr.hs view
@@ -17,790 +17,767 @@ -- @Instr inp out@ along with @HST inp@ and @HST out@ all wrapped into -- @SomeInstr@ data type. This wrapping is done to satsify Haskell type -- system (which has no support for dependent types).--- Functions @typeCheckInstr@, @typeCheckVal@ behave similarly.------ When a recursive call is made within @typeCheck@, @typeCheckInstr@ or--- @typeCheckVal@, result of a call is unwrapped from @SomeInstr@ and type--- information from @HST inp@ and @HST out@ is being used to assert that--- recursive call returned instruction of expected type--- (error is thrown otherwise).-module Michelson.TypeCheck.Instr-    ( typeCheckContract-    , typeCheckVal-    , typeCheckList-    ) where--import Prelude hiding (EQ, GT, LT)--import Control.Monad.Except (liftEither, throwError, withExceptT)-import Data.Default (def)-import Data.Singletons (SingI(sing))-import Data.Typeable ((:~:)(..))--import Michelson.TypeCheck.Helpers-import Michelson.TypeCheck.Types-import Michelson.TypeCheck.Value-import Michelson.Typed-  (Abs, And, CT(..), Contract, ContractInp, ContractOut, Eq', Ge, Gt, Instr(..), IterOp(..), Le,-  Lsl, Lsr, Lt, MapOp(..), Neg, Neq, Not, Notes(..), Notes'(..), Or, Sing(..), T(..), Val(..), Xor,-  converge, convergeAnns, extractNotes, fromUType, mkNotes, notesCase, orAnn, withSomeSingCT,-  withSomeSingT, ( # ))-import qualified Michelson.Untyped as Un-import Michelson.Untyped.Annotation (VarAnn)--typeCheckContract-  :: ExtC-  => TcExtHandler-  -> Un.UntypedContract-  -> Either TCError SomeContract-typeCheckContract nh c = runTypeCheckT nh (Un.para c) $ typeCheckContractImpl c--typeCheckContractImpl-  :: ExtC-  => Un.UntypedContract-  -> TypeCheckT SomeContract-typeCheckContractImpl (Un.Contract mParam mStorage pCode) = do-  code <- maybe (throwError $ TCOtherError "no instructions in contract code")-                pure (nonEmpty pCode)-  withSomeSingT (fromUType mParam) $ \(paramS :: Sing param) ->-    withSomeSingT (fromUType mStorage) $ \(storageS :: Sing st) -> do-      storageNote <--        liftEither $ extractNotes mStorage storageS `onLeft` \m -> TCOtherError $-                        "failed to extract annotations for storage: " <> m-      paramNote <--        liftEither $ extractNotes mParam paramS `onLeft` \m -> TCOtherError $-                        "failed to extract annotations for parameter: " <> m-      let inpNote = mkNotes (NTPair def def def paramNote storageNote)-      let inp = (STPair paramS storageS, inpNote, def) ::& SNil-      typeCheckNE code (SomeHST inp) >>= \case-        SiFail -> do-          let outNote = mkNotes (NTPair def def def NStar storageNote)-              out = (STPair (STList STOperation) storageS, outNote, def)-                      ::& SNil-          pure $ SomeContract (FAILWITH :: Instr (ContractInp param st) (ContractOut st)) inp out-        instr ::: ((inp' :: HST inp), (out :: HST out)) -> do-          let mkIErr m = TCOtherError $-                          "contract input type violates convention: " <> m-          let mkOErr m = TCOtherError $-                          "contract output type violates convention: " <> m-          liftEither $ do-            Refl <- eqT' @out @(ContractOut st) `onLeft` mkOErr-            Refl <- eqT' @inp @(ContractInp param st) `onLeft` mkIErr-            let outN = outNotes out-            _ <- converge outN (N $ NTPair def def def NStar storageNote)-                    `onLeft` mkOErr-            pure $ SomeContract instr inp' out-  where-    outNotes :: HST '[o] -> Notes o-    outNotes ((_, n, _) ::& SNil) = n---- | Like 'typeCheck', but for non-empty lists.-typeCheckNE-  :: ExtC-  => NonEmpty Un.ExpandedOp-  -> SomeHST-  -> TypeCheckT SomeInstr-typeCheckNE (x :| xs) = typeCheckImpl typeCheckInstr (x : xs)---- | Function @typeCheckList@ converts list of Michelson instructions--- given in representation from @Michelson.Type@ module to representation--- in strictly typed GADT.------ Types are checked along the way which is neccessary to construct a--- strictly typed value.------ As a second argument, @typeCheckList@ accepts input stack type representation.-typeCheckList-  :: ExtC-  => [Un.ExpandedOp]-  -> SomeHST-  -> TypeCheckT SomeInstr-typeCheckList = typeCheckImpl typeCheckInstr---- | Function @typeCheckVal@ converts a single Michelson value--- given in representation from @Michelson.Type@ module to representation--- in strictly typed GADT.------ As a second argument, @typeCheckVal@ accepts expected type of value.------ Type checking algorithm pattern-matches on parse value representation,--- expected type @t@ and constructs @Val t@ value.------ If there was no match on a given pair of value and expected type,--- that is interpreted as input of wrong type and type check finishes with--- error.-typeCheckVal-  :: ExtC-  => Un.UntypedValue-  -> T-  -> TypeCheckT SomeVal-typeCheckVal = typeCheckValImpl typeCheckInstr---- | Function @typeCheckInstr@ converts a single Michelson instruction--- given in representation from @Michelson.Type@ module to representation--- in strictly typed GADT.------ As a second argument, @typeCheckInstr@ accepts input stack type representation.------ Type checking algorithm pattern-matches on given instruction, input stack--- type and constructs strictly typed GADT value, checking necessary type--- equalities when neccessary.------ 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-  :: ExtC-  => TcInstrHandler--typeCheckInstr (Un.EXT ext) si@(SomeHST it) = do-  nh <- gets tcExtHandler-  nfs <- gets tcExtFrames-  (nfs', res) <- nh ext nfs si-  modify $ \te -> te {tcExtFrames = nfs'}-  case res of-    Just tExt -> pure $ Ext tExt ::: (it, it)-    Nothing   -> pure $ Nop ::: (it, it)--typeCheckInstr Un.DROP (SomeHST i@(_ ::& rs)) = pure (DROP ::: (i, rs))--typeCheckInstr (Un.DUP _vn) (SomeHST i@(a ::& rs)) =-  pure (DUP ::: (i, (a ::& a::& rs)))--typeCheckInstr Un.SWAP (SomeHST i@(a ::& b ::& rs)) =-  pure (SWAP ::: (i, b ::& a ::& rs))--typeCheckInstr instr@(Un.PUSH vn mt mval) (SomeHST i) = do-  val :::: (t, n) <- typeCheckVal mval (fromUType mt)-  notes <- liftEither $ (extractNotes mt t >>= converge n)-              `onLeft` TCFailedOnInstr instr (SomeHST i)-  pure $ PUSH val ::: (i, (t, notes, vn) ::& i)--typeCheckInstr (Un.SOME tn vn fn) (SomeHST i@((at, an, _) ::& rs)) = do-  let n = mkNotes (NTOption tn fn an)-  pure (SOME ::: (i, (STOption at, n, vn) ::& rs))--typeCheckInstr instr@(Un.NONE tn vn fn elMt) (SomeHST i) = do-  withSomeSingT (fromUType elMt) $ \elT -> do-    let t = STOption elT-    notes <- liftEither $ extractNotes (Un.Type (Un.TOption fn elMt) tn) t-              `onLeft` TCFailedOnInstr instr (SomeHST i)-    pure $ NONE ::: (i, (t, notes, vn) ::& i)--typeCheckInstr (Un.UNIT tn vn) (SomeHST i) = do-  let ns = mkNotes $ NTUnit tn-  pure $ UNIT ::: (i, (STUnit, ns, vn) ::& i)--typeCheckInstr (Un.IF_NONE mp mq) (SomeHST i@((STOption a, ons, ovn) ::& rs) ) = do-  let (an, avn) = deriveNsOption ons ovn-  genericIf IF_NONE Un.IF_NONE mp mq rs ((a, an, avn) ::& rs) i--typeCheckInstr (Un.PAIR tn vn pfn qfn) (SomeHST i@((a, an, avn) ::&-                                             (b, bn, bvn) ::& rs)) = do-  let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn-      ns = mkNotes $ NTPair tn pfn' qfn' an bn-  pure (PAIR ::: (i, (STPair a b, ns, vn `orAnn` vn') ::& rs))--typeCheckInstr (Un.CAR vn _) (SomeHST i@((STPair a _, NStar, _) ::& rs)) =-  pure (CAR ::: (i, (a, NStar, vn) ::& rs))-typeCheckInstr instr@(Un.CAR vn fn)-            (SomeHST i@(( STPair a b-                       , N (NTPair pairTN pfn qfn pns qns)-                       , pairVN ) ::& rs)) = do-  pfn' <- liftEither $ convergeAnns fn pfn-              `onLeft` TCFailedOnInstr instr (SomeHST i)-  let vn' = deriveSpecialVN vn pfn' pairVN-      i' = ( STPair a b-            , N (NTPair pairTN pfn' qfn pns qns)-            , pairVN ) ::& rs-  pure $ CAR ::: (i', (a, pns, vn') ::& rs)--typeCheckInstr (Un.CDR vn _) (SomeHST i@((STPair _ b, NStar, _) ::& rs)) =-  pure (CDR ::: (i, (b, NStar, vn) ::& rs))-typeCheckInstr instr@(Un.CDR vn fn)-          (SomeHST i@(( STPair a b-                      , N (NTPair pairTN pfn qfn pns qns)-                      , pairVN ) ::& rs)) = do-  qfn' <- liftEither $ convergeAnns fn qfn-              `onLeft` TCFailedOnInstr instr (SomeHST i)-  let vn' = deriveSpecialVN vn qfn' pairVN-      i' = ( STPair a b-            , N (NTPair pairTN pfn qfn' pns qns)-            , pairVN ) ::& rs-  pure $ CDR ::: (i', (b, qns, vn') ::& rs)--typeCheckInstr instr@(Un.LEFT tn vn pfn qfn bMt) (SomeHST i@((a, an, _) ::& rs)) =-  withSomeSingT (fromUType bMt) $ \b -> do-    bn <- liftEither $ extractNotes bMt b-              `onLeft` TCFailedOnInstr instr (SomeHST i)-    let ns = mkNotes $ NTOr tn pfn qfn an bn-    pure (LEFT ::: (i, (STOr a b, ns, vn) ::& rs))--typeCheckInstr instr@(Un.RIGHT tn vn pfn qfn aMt) (SomeHST i@((b, bn, _) ::& rs)) =-  withSomeSingT (fromUType aMt) $ \a -> do-    an <- liftEither $ extractNotes aMt a-              `onLeft` TCFailedOnInstr instr (SomeHST i)-    let ns = mkNotes $ NTOr tn pfn qfn an bn-    pure (RIGHT ::: (i, (STOr a b, ns, vn) ::& rs))--typeCheckInstr (Un.IF_LEFT mp mq) (SomeHST i@((STOr a b, ons, ovn) ::& rs) ) = do-  let (an, bn, avn, bvn) = deriveNsOr ons ovn-      ait = (a, an, avn) ::& rs-      bit = (b, bn, bvn) ::& rs-  genericIf IF_LEFT Un.IF_LEFT mp mq ait bit i--typeCheckInstr (Un.IF_RIGHT mq mp) (SomeHST i@((STOr a b, ons, ovn) ::& rs) ) = do-  let (an, bn, avn, bvn) = deriveNsOr ons ovn-      ait = (a, an, avn) ::& rs-      bit = (b, bn, bvn) ::& rs-  genericIf IF_RIGHT Un.IF_RIGHT mq mp bit ait i--typeCheckInstr instr@(Un.NIL tn vn elMt) (SomeHST i) =-  withSomeSingT (fromUType elMt) $ \elT -> liftEither $ do-    let t = STList elT-    notes <- extractNotes (Un.Type (Un.TList elMt) tn) t-              `onLeft` TCFailedOnInstr instr (SomeHST i)-    pure $ NIL ::: (i, (t, notes, vn) ::& i)--typeCheckInstr instr@(Un.CONS vn) (SomeHST i@(((at :: Sing a), an, _)-                              ::& (STList (_ :: Sing a'), ln, _) ::& rs)) =-  case eqT' @a @a' of-    Right Refl -> liftEither $  do-      n <- converge ln (mkNotes $ NTList def an)-              `onLeft` TCFailedOnInstr instr (SomeHST i)-      pure $ CONS ::: (i, (STList at, n, vn) ::& rs)-    Left m -> typeCheckInstrErrM instr (SomeHST i) $-                "list element type is different from one "-                <> "that is being CONSed: " <> m---typeCheckInstr (Un.IF_CONS mp mq) (SomeHST i@((STList a, ns, vn) ::& rs) ) = do-  let an = notesCase NStar (\(NTList _ an_) -> an_) ns-      ait =-        (a, an, vn <> "hd") ::& (STList a, ns, vn <> "tl") ::& rs-  genericIf IF_CONS Un.IF_CONS mp mq ait rs i--typeCheckInstr (Un.SIZE vn) (SomeHST i@((STList _, _, _) ::& _) ) = liftEither $ sizeImpl i vn-typeCheckInstr (Un.SIZE vn) (SomeHST i@((STSet _, _, _) ::& _) ) = liftEither $ sizeImpl i vn-typeCheckInstr (Un.SIZE vn) (SomeHST i@((STMap _ _, _, _) ::& _) ) = liftEither $ sizeImpl i vn-typeCheckInstr (Un.SIZE vn) (SomeHST i@((STc SCString, _, _) ::& _) ) = liftEither $  sizeImpl i vn-typeCheckInstr (Un.SIZE vn) (SomeHST i@((STc SCBytes, _, _) ::& _) ) = liftEither $ sizeImpl i vn--typeCheckInstr (Un.EMPTY_SET tn vn (Un.Comparable mk ktn)) (SomeHST i) =-  withSomeSingCT mk $ \k ->-    pure $ EMPTY_SET ::: (i, (STSet k, mkNotes $ NTSet tn ktn, vn) ::& i)--typeCheckInstr instr@(Un.EMPTY_MAP tn vn (Un.Comparable mk ktn) mv) (SomeHST i) =-  withSomeSingT (fromUType mv) $ \v ->-  withSomeSingCT mk $ \k -> liftEither $ do-    vns <- extractNotes mv v-              `onLeft` TCFailedOnInstr instr (SomeHST i)-    let ns = mkNotes $ NTMap tn ktn vns-    pure $ EMPTY_MAP ::: (i, (STMap k v, ns, vn) ::& i)--typeCheckInstr instr@(Un.MAP vn mp) (SomeHST i@((STList v, ns, _vn) ::& rs) ) = do-  let vns = notesCase NStar (\(NTList _ v') -> v') ns-  typeCheckList mp-                      (SomeHST $ (v, vns, def) ::& rs) >>= \case-    SiFail -> pure SiFail-    someInstr@(_ ::: (_, (out :: HST out))) ->-      case out of-        (_ :: Sing b, _, _) ::& _ ->-          mapImpl @b instr someInstr i-                  (\rt rn -> (::&) (STList rt, mkNotes $ NTList def rn, vn))-        _ -> liftEither $ typeCheckInstrErr instr (SomeHST i) $-              "iteration expression has wrong output stack type (empty stack)"--typeCheckInstr instr@(Un.MAP vn mp) (SomeHST i@((STMap k v, ns, _vn) ::& rs) ) = do-  let (kns, vns) = notesCase (def, NStar) (\(NTMap _ k' v') -> (k', v')) ns-      pns = mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns-  typeCheckList mp (SomeHST $ ((STPair (STc k) v), pns, def) ::& rs) >>= \case-    SiFail -> pure SiFail-    someInstr@(_ ::: (_, (out :: HST out))) ->-      case out of-        (_ :: Sing b, _, _) ::& _ ->-          mapImpl @b instr someInstr i-                  (\rt rn -> (::&) (STMap k rt, mkNotes $ NTMap def kns rn, vn))-        _ -> liftEither $ typeCheckInstrErr instr (SomeHST i) $-              "iteration expression has wrong output stack type (empty stack)"---- case `Un.HSTER []` is wrongly typed by definition--- (as it is required to at least drop an element), so we don't consider it--typeCheckInstr instr@(Un.ITER (i1 : ir)) (SomeHST i@((STSet e, n, _) ::& _)) = do-  let en = notesCase NStar (\(NTSet _ en_) -> mkNotes $ NTc en_) n-  iterImpl (STc e) en instr (i1 :| ir) i-typeCheckInstr instr@(Un.ITER (i1 : ir)) (SomeHST i@((STList e, n, _) ::& _)) = do-  let en = notesCase NStar (\(NTList _ en_) -> en_) n-  iterImpl e en instr (i1 :| ir) i-typeCheckInstr instr@(Un.ITER (i1 : ir)) (SomeHST i@((STMap k v, n, _) ::& _)) = do-  let en = notesCase NStar (\(NTMap _ kns vns) ->-              mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns) n-  iterImpl (STPair (STc k) v) en instr (i1 :| ir) i--typeCheckInstr instr@(Un.MEM vn)-           (SomeHST i@((STc _, _, _) ::& (STSet _, _, _) ::& _)) =-  liftEither $ memImpl instr i vn-typeCheckInstr instr@(Un.MEM vn)-           (SomeHST i@((STc _, _, _) ::& (STMap _ _, _, _) ::& _)) =-  liftEither $ memImpl instr i vn-typeCheckInstr instr@(Un.MEM vn)-           (SomeHST i@((STc _, _, _) ::& (STBigMap _ _, _, _) ::& _)) =-  liftEither $ memImpl instr i vn--typeCheckInstr instr@(Un.GET vn) (SomeHST i@(_ ::& (STMap _ vt, cn, _) ::& _)) =-  liftEither $ getImpl instr i vt (notesCase NStar (\(NTMap _ _ v) -> v) cn) vn-typeCheckInstr instr@(Un.GET vn) (SomeHST i@(_ ::& (STBigMap _ vt, cn, _) ::& _)) =-  liftEither $ getImpl instr i vt (notesCase NStar (\(NTBigMap _ _ v) -> v) cn) vn--typeCheckInstr instr@Un.UPDATE (SomeHST i@(_ ::& _ ::& (STMap _ _, _, _) ::& _)) =-  liftEither $ updImpl instr i-typeCheckInstr instr@Un.UPDATE (SomeHST i@(_ ::& _ ::& (STBigMap _ _, _, _)-                                             ::& _)) =-  liftEither $ updImpl instr i-typeCheckInstr instr@Un.UPDATE (SomeHST i@(_ ::& _ ::& (STSet _, _, _) ::& _)) =-  liftEither $ updImpl instr i--typeCheckInstr (Un.IF mp mq) (SomeHST i@((STc SCBool, _, _) ::& rs) ) =-  genericIf IF Un.IF mp mq rs rs i--typeCheckInstr instr@(Un.LOOP is)-           (SomeHST i@((STc SCBool, _, _) ::& (rs :: HST rs)) ) = do-  typeCheckList is (SomeHST rs) >>= \case-    SiFail -> pure SiFail-    subI ::: ((_ :: HST rs'), (o :: HST o)) -> liftEither $ do-      Refl <- assertEqT @rs @rs' instr i-      case (eqT' @o @('Tc 'CBool ': rs), SomeHST o) of-        (Right Refl, SomeHST (_ ::& rs' :: HST o')) -> do-            Refl <- assertEqT @o @o' instr i-            pure $ LOOP subI ::: (i, rs')-        (Left m, _) ->-          typeCheckInstrErr instr (SomeHST i) $-                    "iteration expression has wrong output stack type: " <> m-        _ -> typeCheckInstrErr instr (SomeHST i) $-                        "iteration expression has wrong output stack type"--typeCheckInstr instr@(Un.LOOP_LEFT is)-           (SomeHST i@((STOr (at :: Sing a) (bt :: Sing b), ons, ovn)-                      ::& (rs :: HST rs)) ) = do-  let (an, bn, avn, bvn) = deriveNsOr ons ovn-      ait = (at, an, avn) ::& rs-  typeCheckList is (SomeHST ait) >>= \case-    SiFail -> pure SiFail-    subI ::: ((_ :: HST rs'), (o :: HST o)) -> liftEither $ do-      Refl <- assertEqT @(a ': rs) @rs' instr i-      case (eqT' @o @('TOr a b ': rs), SomeHST o) of-        (Right Refl, SomeHST ((STOr _ bt', ons', ovn') ::& rs' :: HST o')) -> do-            Refl <- assertEqT @o @o' instr i-            let (_, bn', _, bvn') = deriveNsOr ons' ovn'-            br <- convergeHSTEl (bt, bn, bvn) (bt', bn', bvn')-                    `onLeft` TCFailedOnInstr instr (SomeHST i)-            pure $ LOOP_LEFT subI ::: (i, br ::& rs')-        (Left m, _) -> typeCheckInstrErr instr (SomeHST i) $-                        "iteration expression has wrong output stack type: " <> m-        _ -> typeCheckInstrErr instr (SomeHST i) $-                        "iteration expression has wrong output stack type"--typeCheckInstr instr@(Un.LAMBDA vn imt omt is) (SomeHST i) = do-  withSomeSingT (fromUType imt) $ \(it :: Sing it) -> do-    withSomeSingT (fromUType omt) $ \(ot :: Sing ot) -> do-      ins <- liftEither $ extractNotes imt it-              `onLeft` TCFailedOnInstr instr (SomeHST i)-      ons <- liftEither $ extractNotes omt ot-              `onLeft` TCFailedOnInstr instr (SomeHST i)-      -- further processing is extracted into another function because-      -- otherwise I encountered some weird GHC error with that code-      -- located right here-      lamImpl instr is vn it ins ot ons i--typeCheckInstr instr@(Un.EXEC vn) (SomeHST i@(((_ :: Sing t1), _, _)-                              ::& (STLambda (_ :: Sing t1') t2, ln, _)-                              ::& rs)) = do-  let t2n = notesCase NStar (\(NTLambda _ _ n) -> n) ln-  case eqT' @t1 @t1' of-    Right Refl -> pure $ EXEC ::: (i, (t2, t2n, vn) ::& rs)-    Left m -> typeCheckInstrErrM instr (SomeHST i) $-                "lambda is given argument with wrong type: " <> m--typeCheckInstr instr@(Un.DIP is) (SomeHST i@(a ::& (s :: HST s))) =-  typeCheckList is (SomeHST s) >>= \case-    SiFail -> pure SiFail-    subI ::: ((_ :: HST s'), t) -> liftEither $ do-      Refl <- assertEqT @s @s' instr i-      pure $ DIP subI ::: (i, a ::& t)--typeCheckInstr Un.FAILWITH _ = pure SiFail--typeCheckInstr instr@(Un.CAST vn mt)-           (SomeHST i@(((e :: Sing e), (en :: Notes e), evn) ::& rs)) =-  withSomeSingT (fromUType mt) $ \(_ :: Sing e') ->-    case eqT' @e @e' of-      Right Refl ->-        case extractNotes mt e of-          Right en' ->-            case converge en en' of-              Right ns ->-                pure $ CAST ::: (i, (e, ns, vn `orAnn` evn) ::& rs)-              Left m -> err m-          Left m -> err m-      Left m -> err m-    where-      err = \m -> typeCheckInstrErrM instr (SomeHST i) $-                  "cast to incompatible type: " <> m--typeCheckInstr (Un.RENAME vn) (SomeHST i@((at, an, _) ::& rs)) =-  pure $ RENAME ::: (i, (at, an, vn) ::& rs)--typeCheckInstr instr@(Un.UNPACK vn mt) (SomeHST i@((STc SCBytes, _, _) ::& rs)) =-  withSomeSingT (fromUType mt) $ \t -> liftEither $ do-    tns <- extractNotes mt t-            `onLeft` TCFailedOnInstr instr (SomeHST i)-    let ns = mkNotes $ NTOption def def tns-    pure $ UNPACK ::: (i, (STOption t, ns, vn) ::& rs)--typeCheckInstr (Un.PACK vn) (SomeHST i@(_ ::& rs)) =-  pure $ PACK ::: (i, (STc SCBytes, NStar, vn) ::& rs)--typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STc SCBytes, _, _) ::&-                                    (STc SCBytes, _, _) ::& _)) =-  liftEither $ concatImpl i vn-typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STc SCString, _, _) ::&-                                    (STc SCString, _, _) ::& _)) =-  liftEither $ concatImpl i vn-typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STList (STc SCBytes), _, _) ::& _)) =-  liftEither $  concatImpl' i vn-typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STList (STc SCString), _, _) ::& _)) =-  liftEither $ concatImpl' i vn---typeCheckInstr (Un.SLICE vn) (SomeHST i@((STc SCNat, _, _) ::&-                                   (STc SCNat, _, _) ::&-                                   (STc SCString, _, _) ::& _)) =-  liftEither $ sliceImpl i vn-typeCheckInstr (Un.SLICE vn) (SomeHST i@((STc SCNat, _, _) ::&-                                   (STc SCNat, _, _) ::&-                                   (STc SCBytes, _, _) ::& _)) =-  liftEither $ sliceImpl i vn--typeCheckInstr (Un.ISNAT vn') (SomeHST i@((STc SCInt, _, oldVn) ::& rs)) = do-  let vn = vn' `orAnn` oldVn-  pure $ ISNAT ::: (i, (STOption (STc SCNat), NStar, vn) ::& rs)--typeCheckInstr (Un.ADD vn) (SomeHST i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _)) = liftEither $ addImpl a b i vn--typeCheckInstr (Un.SUB vn) (SomeHST i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _)) = liftEither $ subImpl a b i vn--typeCheckInstr (Un.MUL vn) (SomeHST i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _)) = liftEither $ mulImpl a b i vn--typeCheckInstr (Un.EDIV vn) (SomeHST i@((STc a, _, _) ::&-                                  (STc b, _, _) ::& _)) = liftEither $ edivImpl a b i vn--typeCheckInstr (Un.ABS vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Abs ABS i vn--typeCheckInstr Un.NEG (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Neg NEG i def--typeCheckInstr (Un.LSL vn) (SomeHST i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Lsl LSL i vn--typeCheckInstr (Un.LSR vn) (SomeHST i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Lsr LSR i vn--typeCheckInstr (Un.OR vn) (SomeHST i@((STc SCBool, _, _) ::&-                         (STc SCBool, _, _) ::& _)) = liftEither $ arithImpl @Or OR i vn-typeCheckInstr (Un.OR vn) (SomeHST i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Or OR i vn--typeCheckInstr (Un.AND vn) (SomeHST i@((STc SCInt, _, _) ::&-                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @And AND i vn-typeCheckInstr (Un.AND vn) (SomeHST i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @And AND i vn-typeCheckInstr (Un.AND vn) (SomeHST i@((STc SCBool, _, _) ::&-                         (STc SCBool, _, _) ::& _)) = liftEither $ arithImpl @And AND i vn--typeCheckInstr (Un.XOR vn) (SomeHST i@((STc SCBool, _, _) ::&-                         (STc SCBool, _, _) ::& _)) = liftEither $ arithImpl @Xor XOR i vn-typeCheckInstr (Un.XOR vn) (SomeHST i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Xor XOR i vn--typeCheckInstr (Un.NOT vn) (SomeHST i@((STc SCNat, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Not NOT i vn-typeCheckInstr (Un.NOT vn) (SomeHST i@((STc SCBool, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Not NOT i vn-typeCheckInstr (Un.NOT vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Not NOT i vn--typeCheckInstr (Un.COMPARE vn) (SomeHST i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _)) = liftEither $ compareImpl a b i vn--typeCheckInstr (Un.EQ vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Eq' EQ i vn--typeCheckInstr (Un.NEQ vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Neq NEQ i vn--typeCheckInstr (Un.LT vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Lt LT i vn--typeCheckInstr (Un.GT vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Gt GT i vn--typeCheckInstr (Un.LE vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Le LE i vn--typeCheckInstr (Un.GE vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =-  liftEither $ unaryArithImpl @Ge GE i vn--typeCheckInstr (Un.INT vn) (SomeHST i@((STc SCNat, _, _) ::& rs)) =-  pure $ INT ::: (i, (STc SCInt, NStar, vn) ::& rs)--typeCheckInstr instr@(Un.SELF vn) shst@(SomeHST i) = do-  cpType <- gets tcContractParam-  let t = fromUType cpType-  withSomeSingT t $ \(singcp :: Sing cp) -> do-    nt <- liftEither $ extractNotes cpType singcp `onLeft` TCFailedOnInstr instr shst-    pure $ SELF @cp ::: (i, (sing @('TContract cp), N (NTContract Un.noAnn nt), vn) ::& i)--typeCheckInstr instr@(Un.CONTRACT vn mt)-           (SomeHST i@((STc SCAddress, _, _) ::& rs)) =-  withSomeSingT (fromUType mt) $ \t -> liftEither $ do-    tns <- extractNotes mt t-            `onLeft` TCFailedOnInstr instr (SomeHST i)-    let ns = mkNotes $ NTOption def def $ mkNotes $ NTContract def tns-    pure $ CONTRACT ::: (i, (STOption $ STContract t, ns, vn) ::& rs)--typeCheckInstr instr@(Un.TRANSFER_TOKENS vn) (SomeHST i@(((_ :: Sing p'), _, _)-  ::& (STc SCMutez, _, _) ::& (STContract (_ :: Sing p), _, _) ::& rs)) = do-  case eqT' @p @p' of-    Right Refl ->-      pure $ TRANSFER_TOKENS ::: (i, (STOperation, NStar, vn) ::& rs)-    Left m ->-      typeCheckInstrErrM instr (SomeHST i) $ "mismatch of contract param type: " <> m--typeCheckInstr (Un.SET_DELEGATE vn)-           (SomeHST i@((STOption (STc SCKeyHash), _, _) ::& rs)) = do-  pure $ SET_DELEGATE ::: (i, (STOperation, NStar, vn) ::& rs)--typeCheckInstr (Un.CREATE_ACCOUNT ovn avn)-           (SomeHST i@((STc SCKeyHash, _, _)-             ::& (STOption (STc SCKeyHash), _, _) ::& (STc SCBool, _, _)-             ::& (STc SCMutez, _, _) ::& rs)) =-  pure $ CREATE_ACCOUNT ::: (i, (STOperation, NStar, ovn) ::&-                                 (STc SCAddress, NStar, avn) ::& rs)--typeCheckInstr instr@(Un.CREATE_CONTRACT ovn avn)-           (SomeHST i@((STc SCKeyHash, _, _)-             ::& (STOption (STc SCKeyHash), _, _)-             ::& (STc SCBool, _, _) ::& (STc SCBool, _, _)-             ::& (STc SCMutez, _, _)-             ::& (STLambda (STPair _ (_ :: Sing g1))-                   (STPair (STList STOperation) (_ :: Sing g2)), ln, _)-                        ::& ((_ :: Sing g3), gn3, _) ::& rs)) = do-  let (gn1, gn2) = notesCase (NStar, NStar)-                    (\(NTLambda _ l r) ->-                      (,) (notesCase NStar (\(NTPair _ _ _ _ n) -> n) l)-                          (notesCase NStar (\(NTPair _ _ _ _ n) -> n) r)) ln-  liftEither $ either (\m -> typeCheckInstrErr instr (SomeHST i) $-                  "mismatch of contract storage type: " <> m) pure $ do-    Refl <- eqT' @g1 @g2-    Refl <- eqT' @g2 @g3-    gn12 <- converge gn1 gn2-    _ <- converge gn12 gn3-    pure $ CREATE_CONTRACT ::: (i, (STOperation, NStar, ovn) ::&-                                     (STc SCAddress, NStar, avn) ::& rs)--typeCheckInstr instr@(Un.CREATE_CONTRACT2 ovn avn contract)-           (SomeHST i@((STc SCKeyHash, _, _)-             ::& (STOption (STc SCKeyHash), _, _)-             ::& (STc SCBool, _, _)-             ::& (STc SCBool, _, _)-             ::& (STc SCMutez, _, _)-             ::& ((_ :: Sing g), gn, _) ::& rs)) = do-  (SomeContract (contr :: Contract i' g') _ out) <--      flip withExceptT (typeCheckContractImpl contract)-                       (\err -> TCFailedOnInstr instr (SomeHST i)-                                    ("failed to type check contract: " <> show err))-  liftEither $ do-    Refl <- checkEqT @g @g' instr i "contract storage type mismatch"-    void $ converge gn (outNotes out) `onLeft` TCFailedOnInstr instr (SomeHST i)-    pure $ CREATE_CONTRACT2 contr ::: (i, (STOperation, NStar, ovn) ::&-                                          (STc SCAddress, NStar, avn) ::& rs)-  where-    outNotes :: HST '[ 'TPair ('TList 'TOperation) g' ] -> Notes g'-    outNotes ((_, n, _) ::& SNil) =-      notesCase NStar (\(NTPair _ _ _ _ n') -> n') n--typeCheckInstr (Un.IMPLICIT_ACCOUNT vn)-           (SomeHST i@((STc SCKeyHash, _, _) ::& rs)) =-  pure $ IMPLICIT_ACCOUNT ::: (i, (STContract STUnit, NStar, vn) ::& rs)--typeCheckInstr (Un.NOW vn) (SomeHST i) =-  pure $ NOW ::: (i, (STc SCTimestamp, NStar, vn) ::& i)--typeCheckInstr (Un.AMOUNT vn) (SomeHST i) =-  pure $ AMOUNT ::: (i, (STc SCMutez, NStar, vn) ::& i)--typeCheckInstr (Un.BALANCE vn) (SomeHST i) =-  pure $ BALANCE ::: (i, (STc SCMutez, NStar, vn) ::& i)--typeCheckInstr (Un.CHECK_SIGNATURE vn)-           (SomeHST i@((STKey, _, _)-             ::& (STSignature, _, _) ::& (STc SCBytes, _, _) ::& rs)) =-  pure $ CHECK_SIGNATURE ::: (i, (STc SCBool, NStar, vn) ::& rs)--typeCheckInstr (Un.SHA256 vn)-           (SomeHST i@((STc SCBytes, _, _) ::& rs)) =-  pure $ SHA256 ::: (i, (STc SCBytes, NStar, vn) ::& rs)--typeCheckInstr (Un.SHA512 vn)-           (SomeHST i@((STc SCBytes, _, _) ::& rs)) =-  pure $ SHA512 ::: (i, (STc SCBytes, NStar, vn) ::& rs)--typeCheckInstr (Un.BLAKE2B vn)-           (SomeHST i@((STc SCBytes, _, _) ::& rs)) =-  pure $ BLAKE2B ::: (i, (STc SCBytes, NStar, vn) ::& rs)--typeCheckInstr (Un.HASH_KEY vn)-           (SomeHST i@((STKey, _, _) ::& rs)) =-  pure $ HASH_KEY ::: (i, (STc SCKeyHash, NStar, vn) ::& rs)--typeCheckInstr (Un.STEPS_TO_QUOTA vn) (SomeHST i) =-  pure $ STEPS_TO_QUOTA ::: (i, (STc SCNat, NStar, vn) ::& i)--typeCheckInstr (Un.SOURCE vn) (SomeHST i) =-  pure $ SOURCE ::: (i, (STc SCAddress, NStar, vn) ::& i)--typeCheckInstr (Un.SENDER vn) (SomeHST i) =-  pure $ SENDER ::: (i, (STc SCAddress, NStar, vn) ::& i)--typeCheckInstr (Un.ADDRESS vn) (SomeHST i@((STContract _, _, _) ::& rs)) =-  pure $ ADDRESS ::: (i, (STc SCAddress, NStar, vn) ::& rs)--typeCheckInstr instr sit = typeCheckInstrErrM instr sit ""---- | Helper function for two-branch if where each branch is given a single--- value.-genericIf-  :: forall bti bfi cond rs .-    (Typeable bti, Typeable bfi, ExtC)-  => (forall s'.-        Instr bti s' ->-        Instr bfi s' ->-        Instr (cond ': rs) s'-     )-  -> ([Un.ExpandedOp] -> [Un.ExpandedOp] -> Un.ExpandedInstr)-  -> [Un.ExpandedOp]-  -> [Un.ExpandedOp]-  -> HST bti-  -> HST bfi-  -> HST (cond ': rs)-  -> TypeCheckT SomeInstr-genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) =-  liftA2 (,) (typeCheckList mbt (SomeHST bti))-             (typeCheckList mbf (SomeHST bfi)) >>= liftEither . \case-  (p ::: ((_ :: HST pi), (po :: HST po)), q ::: ((_ :: HST qi), (qo :: HST qo))) -> do-    Refl <- assertEqT @bti @pi instr i-    Refl <- assertEqT @bfi @qi instr i-    Refl <- checkEqT @qo @po instr i-                  "branches have different output stack types"-    o <- convergeHST po qo `onLeft` TCFailedOnInstr instr (SomeHST i)-    pure $ cons p q ::: (i, o)-  (SiFail, q ::: ((_ :: HST qi), (qo :: HST qo))) -> do-    Refl <- assertEqT @bfi @qi instr i-    -- TODO TM-27 There shall be no `PUSH VUnit`, rewrite this code-    pure $ cons (PUSH VUnit # FAILWITH) q ::: (i, qo)-  (p ::: ((_ :: HST pi), (po :: HST po)), SiFail) -> do-    Refl <- assertEqT @bti @pi instr i-    -- TODO TM-27 There shall be no `PUSH VUnit`, rewrite this code-    pure $ cons p (PUSH VUnit # FAILWITH) ::: (i, po)-  _ -> pure SiFail--  where-    instr = mCons mbt mbf--mapImpl-  :: forall b c rs .-  ( MapOp c b-  , Typeable b-  , Typeable (MapOpInp c)-  , Typeable (MapOpRes c b)-  )-  => Un.ExpandedInstr-  -> SomeInstr-  -> HST (c ': rs)-  -> (forall v' . (Typeable v', SingI v') =>-        Sing v' -> Notes v' -> HST rs -> HST (MapOpRes c v' ': rs))-  -> TypeCheckT SomeInstr-mapImpl instr someInstr i@(_ ::& _) mkRes =-  case someInstr of-    SiFail -> pure SiFail-    sub ::: ((_ :: HST subi), (subo :: HST subo)) -> liftEither $ do-      Refl <- assertEqT @subi @(MapOpInp c ': rs) instr i-      case SomeHST subo of-        SomeHST ((b :: Sing b', bn, _bvn) ::& (rs' :: HST rs') :: HST subo') -> do-          Refl <- assertEqT @b @b' instr i-          Refl <- assertEqT @subo @subo' instr i-          Refl <- checkEqT @rs @rs' instr i $-                      "iteration expression has wrong output stack type"-          pure $ MAP sub ::: (i, mkRes b bn rs')-        _ -> typeCheckInstrErr instr (SomeHST i) $-              "iteration expression has wrong output stack type (empty stack)"--iterImpl-  :: forall c rs .-    ( IterOp c-    , SingI (IterOpEl c)-    , Typeable (IterOpEl c)-    , ExtC-    )-  => Sing (IterOpEl c)-  -> Notes (IterOpEl c)-  -> Un.ExpandedInstr-  -> NonEmpty Un.ExpandedOp-  -> HST (c ': rs)-  -> TypeCheckT SomeInstr-iterImpl et en instr mp i@((_, _, lvn) ::& rs) = do-  let evn = deriveVN "elt" lvn-  typeCheckNE mp (SomeHST ((et, en, evn) ::& rs)) >>= \case-    SiFail -> pure SiFail-    subI ::: ((_ :: HST i), (o :: HST o)) -> liftEither $ do-      Refl <- assertEqT @i @(IterOpEl c ': rs) instr i-      Refl <- checkEqT @o @rs instr i-                "iteration expression has wrong output stack type"-      pure $ ITER subI ::: (i, o)--lamImpl-  :: forall it ot ts .-    ( Typeable it, Typeable ts, Typeable ot-    , ExtC-    , SingI it, SingI ot-    )-  => Un.ExpandedInstr-  -> [Un.ExpandedOp]-  -> VarAnn-  -> Sing it -> Notes it-  -> Sing ot -> Notes ot-  -> HST ts-  -> TypeCheckT SomeInstr-lamImpl instr is vn it ins ot ons i = do-  typeCheckList is (SomeHST $ (it, ins, def) ::& SNil) >>=-    \case-      SiFail -> pure SiFail-      lam ::: ((_ :: HST li), (lo :: HST lo)) -> liftEither $ do-        Refl <- assertEqT @'[ it ] @li instr i-        case (eqT' @'[ ot ] @lo, SomeHST lo) of-          (Right Refl, SomeHST ((_, ons', _) ::& SNil :: HST lo')) -> do-              Refl <- assertEqT @lo @lo' instr i-              onsr <- converge ons ons'-                        `onLeft` TCFailedOnInstr instr (SomeHST i)-              let ns = mkNotes $ NTLambda def ins onsr-              pure (LAMBDA (VLam lam) ::: (i, (STLambda it ot, ns, vn) ::& i))-          (Right Refl, _) ->-            typeCheckInstrErr instr (SomeHST i)-              "wrong output type of lambda's expression (wrong stack size)"-          (Left m, _) -> typeCheckInstrErr instr (SomeHST i) $-                          "wrong output type of lambda's expression: " <> m+-- Functions @typeCheckInstr@, @typeCheckValue@ behave similarly.+--+-- When a recursive call is made within @typeCheck@, @typeCheckInstr@ or+-- @typeCheckValue@, result of a call is unwrapped from @SomeInstr@ and type+-- information from @HST inp@ and @HST out@ is being used to assert that+-- recursive call returned instruction of expected type+-- (error is thrown otherwise).+module Michelson.TypeCheck.Instr+    ( typeCheckContract+    , typeCheckValue+    , typeVerifyValue+    , typeCheckList+    ) where++import Prelude hiding (EQ, GT, LT)++import Control.Monad.Except (MonadError, liftEither, throwError)+import Data.Constraint (Dict(..))+import Data.Default (def)+import Data.Generics (everything, mkQ)+import Data.Singletons (SingI(sing), demote)+import Data.Typeable ((:~:)(..), gcast)++import Michelson.ErrorPos+import Michelson.TypeCheck.Error+import Michelson.TypeCheck.Ext+import Michelson.TypeCheck.Helpers+import Michelson.TypeCheck.TypeCheck+import Michelson.TypeCheck.Types+import Michelson.TypeCheck.Value++import Michelson.Typed+  (Abs, And, CT(..), Contract, ContractOut1, Eq', Ge, Gt, Instr(..), IterOp(..), Le, Lsl, Lsr, Lt,+  MapOp(..), Neg, Neq, Not, Notes(..), Notes'(..), Or, Sing(..), T(..), Value, Value'(..), Xor,+  bigMapAbsense, bigMapConstrained, converge, convergeAnns, extractNotes, fromUType, mkNotes,+  notesCase, opAbsense, orAnn, withSomeSingCT, withSomeSingT)++import qualified Michelson.Untyped as U+import Michelson.Untyped.Annotation (VarAnn)++typeCheckContract+  :: TcOriginatedContracts+  -> U.Contract+  -> Either TCError SomeContract+typeCheckContract cs c = runTypeCheck (U.para c) cs $ typeCheckContractImpl c++typeCheckContractImpl+  :: U.Contract+  -> TypeCheck SomeContract+typeCheckContractImpl (U.Contract mParam mStorage pCode) = do+  code <- maybe (throwError $ TCContractError "no instructions in contract code" Nothing)+                pure (nonEmpty pCode)+  withSomeSingT (fromUType mParam) $ \(paramS :: Sing param) ->+    withSomeSingT (fromUType mStorage) $ \(storageS :: Sing st) -> do+      storageNote <-+        liftEither $ extractNotes mStorage storageS `onLeft`+        (TCContractError "failed to extract annotations for storage:" . Just . ExtractionTypeMismatch)+      paramNote <-+        liftEither $ extractNotes mParam paramS `onLeft`+        (TCContractError "failed to extract annotations for parameter:" . Just . ExtractionTypeMismatch)+      Dict <-+        note (hasTypeError "parameter" (Proxy @'TOperation)) $+        opAbsense paramS+      Dict <-+        note (hasTypeError "storage" (Proxy @'TOperation)) $+        opAbsense storageS+      Dict <-+        note (hasTypeError "parameter" (Proxy @param)) $+        bigMapAbsense paramS+      Dict <-+        note (hasTypeError "storage" (Proxy @st)) $+        bigMapConstrained storageS+      let inpNote = mkNotes (NTPair def def def paramNote storageNote)+      let inp = (STPair paramS storageS, inpNote, def) ::& SNil+      inp' :/ instrOut <- typeCheckNE code inp+      case instrOut of+        instr ::: out -> liftEither $ do+          case eqHST1 @(ContractOut1 st) out of+            Right Refl -> do+              let (_, outN, _) ::& SNil = out+              _ <- converge outN (N $ NTPair def def def NStar storageNote)+                      `onLeft`+                  ((TCContractError "contract output type violates convention:") . Just . AnnError)+              pure $ SomeContract instr inp' out+            Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err+        AnyOutInstr instr -> do+          let outNote = mkNotes (NTPair def def def NStar storageNote)+          let out = (STPair (STList STOperation) storageS, outNote, def)+                      ::& SNil+          pure $ SomeContract instr inp' out+  where+    hasTypeError name (_ :: Proxy t) =+      TCContractError ("contract " <> name <> " type error") $+      Just $ UnsupportedTypes [demote @t]++-- | Like 'typeCheck', but for non-empty lists.+typeCheckNE+  :: (Typeable inp)+  => NonEmpty U.ExpandedOp+  -> HST inp+  -> TypeCheck (SomeInstr inp)+typeCheckNE (x :| xs) = usingReaderT def . typeCheckImpl typeCheckInstr (x : xs)++-- | Function @typeCheckList@ converts list of Michelson instructions+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- Types are checked along the way which is neccessary to construct a+-- strictly typed value.+--+-- As a second argument, @typeCheckList@ accepts input stack type representation.+typeCheckList+  :: (Typeable inp)+  => [U.ExpandedOp]+  -> HST inp+  -> TypeCheck (SomeInstr inp)+typeCheckList = usingReaderT def ... typeCheckImpl typeCheckInstr++-- | Function @typeCheckValue@ converts a single Michelson value+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- As a second argument, @typeCheckValue@ accepts expected type of value.+--+-- Type checking algorithm pattern-matches on parse value representation,+-- expected type @t@ and constructs @Val t@ value.+--+-- If there was no match on a given pair of value and expected type,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+typeCheckValue+  :: U.Value+  -> (Sing t, Notes t)+  -> TypeCheckInstr SomeValue+typeCheckValue = typeCheckValImpl typeCheckInstr++-- | Like 'typeCheckValue', but returns value of a desired type.+typeVerifyValue+  :: forall t.+      (Typeable t, SingI t)+  => U.Value -> TypeCheckInstr (Value t)+typeVerifyValue uval =+  typeCheckValue uval (sing @t, NStar) <&> \case+    val :::: _ -> gcast val ?: error "Typechecker produced value of wrong type"++-- | Function @typeCheckInstr@ converts a single Michelson instruction+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- As a second argument, @typeCheckInstr@ accepts input stack type representation.+--+-- Type checking algorithm pattern-matches on given instruction, input stack+-- type and constructs strictly typed GADT value, checking necessary type+-- equalities when neccessary.+--+-- 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 :: TcInstrHandler+typeCheckInstr (U.EXT ext) si =+  typeCheckExt typeCheckList ext si++typeCheckInstr U.DROP i@(_ ::& rs) = pure (i :/ DROP ::: rs)++typeCheckInstr (U.DUP _vn) i@(a ::& rs) =+  pure (i :/ DUP ::: (a ::& a::& rs))++typeCheckInstr U.SWAP (i@(a ::& b ::& rs)) =+  pure (i :/ SWAP ::: (b ::& a ::& rs))++typeCheckInstr instr@(U.PUSH vn mt mval) i =+  withSomeSingT (fromUType mt) $ \t' -> do+    nt' <- onTypeCheckInstrTypeErr instr i "wrong push type:" (extractNotes mt t')+    val :::: (t :: Sing t, nt) <- typeCheckValue mval (t', nt')+    proofOp <-+      maybe (onTypeCheckInstrErr instr (SomeHST i)+             "Operations in constant are not allowed"+             $ Left $ UnsupportedTypes [demote @t])+      pure (opAbsense t)+    proofBigMap <-+      maybe (onTypeCheckInstrErr instr (SomeHST i)+             "BigMaps in constant are not allowed"+             $ Left $ UnsupportedTypes [demote @t])+      pure (bigMapAbsense t)+    case (proofOp, proofBigMap) of+      (Dict, Dict) -> pure $ i :/ PUSH val ::: ((t, nt, vn) ::& i)++typeCheckInstr (U.SOME tn vn fn) i@((at, an, _) ::& rs) = do+  let n = mkNotes (NTOption tn fn an)+  pure (i :/ SOME ::: ((STOption at, n, vn) ::& rs))++typeCheckInstr instr@(U.NONE tn vn fn elMt) i =+  withSomeSingT (fromUType elMt) $ \elT -> do+    let t = STOption elT+    notes <- onTypeCheckInstrTypeErr instr i "wrong none type:"+                (extractNotes (U.Type (U.TOption fn elMt) tn) t)+    pure $ i :/ NONE ::: ((t, notes, vn) ::& i)++typeCheckInstr (U.UNIT tn vn) i = do+  let ns = mkNotes $ NTUnit tn+  pure $ i :/ UNIT ::: ((STUnit, ns, vn) ::& i)++typeCheckInstr (U.IF_NONE mp mq) i@((STOption a, ons, ovn) ::& rs) = do+  let (an, avn) = deriveNsOption ons ovn+  genericIf IF_NONE U.IF_NONE mp mq rs ((a, an, avn) ::& rs) i++typeCheckInstr (U.PAIR tn vn pfn qfn) i@((a, an, avn) ::&+                                             (b, bn, bvn) ::& rs) = do+  let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn+      ns = mkNotes $ NTPair tn pfn' qfn' an bn+  pure (i :/ PAIR ::: ((STPair a b, ns, vn `orAnn` vn') ::& rs))++typeCheckInstr (U.CAR vn _) i@((STPair a _, NStar, _) ::& rs) =+  pure (i :/ CAR ::: ((a, NStar, vn) ::& rs))+typeCheckInstr instr@(U.CAR vn fn)+            (i@(( STPair a b+                       , N (NTPair pairTN pfn qfn pns qns)+                       , pairVN ) ::& rs)) = do+  pfn' <- onTypeCheckInstrAnnErr instr i "wrong car type:" (convergeAnns fn pfn)+  let vn' = deriveSpecialVN vn pfn' pairVN+      i' = ( STPair a b+            , N (NTPair pairTN pfn' qfn pns qns)+            , pairVN ) ::& rs+  pure $ i' :/ CAR ::: ((a, pns, vn') ::& rs)++typeCheckInstr (U.CDR vn _) i@((STPair _ b, NStar, _) ::& rs) =+  pure (i :/ CDR ::: ((b, NStar, vn) ::& rs))+typeCheckInstr instr@(U.CDR vn fn)+          (i@(( STPair a b+                      , N (NTPair pairTN pfn qfn pns qns)+                      , pairVN ) ::& rs)) = do+  qfn' <- onTypeCheckInstrAnnErr instr i "wrong cdr type:" (convergeAnns fn qfn)++  let vn' = deriveSpecialVN vn qfn' pairVN+      i' = ( STPair a b+            , N (NTPair pairTN pfn qfn' pns qns)+            , pairVN ) ::& rs+  pure $ i' :/ CDR ::: ((b, qns, vn') ::& rs)++typeCheckInstr instr@(U.LEFT tn vn pfn qfn bMt) i@((a, an, _) ::& rs) =+  withSomeSingT (fromUType bMt) $ \b -> do+    bn <- onTypeCheckInstrTypeErr instr i "wrong left type:" (extractNotes bMt b)+    let ns = mkNotes $ NTOr tn pfn qfn an bn+    pure (i :/ LEFT ::: ((STOr a b, ns, vn) ::& rs))++typeCheckInstr instr@(U.RIGHT tn vn pfn qfn aMt) i@((b, bn, _) ::& rs) =+  withSomeSingT (fromUType aMt) $ \a -> do+    an <- onTypeCheckInstrTypeErr instr i "wrong right type:" (extractNotes aMt a)+    let ns = mkNotes $ NTOr tn pfn qfn an bn+    pure (i :/ RIGHT ::: ((STOr a b, ns, vn) ::& rs))++typeCheckInstr (U.IF_LEFT mp mq) i@((STOr a b, ons, ovn) ::& rs) = do+  let (an, bn, avn, bvn) = deriveNsOr ons ovn+      ait = (a, an, avn) ::& rs+      bit = (b, bn, bvn) ::& rs+  genericIf IF_LEFT U.IF_LEFT mp mq ait bit i++typeCheckInstr instr@(U.NIL tn vn elMt) i =+  withSomeSingT (fromUType elMt) $ \elT -> do+    let t = STList elT+    notes <- onTypeCheckInstrTypeErr instr i "wrong nil type:" (extractNotes (U.Type (U.TList elMt) tn) t)+    pure $ i :/ NIL ::: ((t, notes, vn) ::& i)++typeCheckInstr instr@(U.CONS vn) i@((((at :: Sing a), an, _)+                              ::& (STList (_ :: Sing a'), ln, _) ::& rs)) =+  case eqType @a @a' of+    Right Refl -> do+      n <- onTypeCheckInstrAnnErr instr i "wrong cons type:" (converge ln (mkNotes $ NTList def an))+      pure $ i :/ CONS ::: ((STList at, n, vn) ::& rs)+    Left m -> onTypeCheckInstrErr instr (SomeHST i)+                ("list element type is different from one "+                <> "that is being CONSed:") (Left m)+++typeCheckInstr (U.IF_CONS mp mq) i@((STList a, ns, vn) ::& rs)  = do+  let an = notesCase NStar (\(NTList _ an_) -> an_) ns+      ait =+        (a, an, vn <> "hd") ::& (STList a, ns, vn <> "tl") ::& rs+  genericIf IF_CONS U.IF_CONS mp mq ait rs i++typeCheckInstr (U.SIZE vn) i@((STList _, _, _) ::& _)  = sizeImpl i vn+typeCheckInstr (U.SIZE vn) i@((STSet _, _, _) ::& _)  = sizeImpl i vn+typeCheckInstr (U.SIZE vn) i@((STMap _ _, _, _) ::& _)  = sizeImpl i vn+typeCheckInstr (U.SIZE vn) i@((STc SCString, _, _) ::& _)  = sizeImpl i vn+typeCheckInstr (U.SIZE vn) i@((STc SCBytes, _, _) ::& _)  = sizeImpl i vn++typeCheckInstr (U.EMPTY_SET tn vn (U.Comparable mk ktn)) i =+  withSomeSingCT mk $ \k ->+    pure $ i :/ EMPTY_SET ::: ((STSet k, mkNotes $ NTSet tn ktn, vn) ::& i)++typeCheckInstr instr@(U.EMPTY_MAP tn vn (U.Comparable mk ktn) mv) i =+  withSomeSingT (fromUType mv) $ \v ->+  withSomeSingCT mk $ \k -> do+    vns <- onTypeCheckInstrTypeErr instr i "wrong empty_map type:" (extractNotes mv v)+    let ns = mkNotes $ NTMap tn ktn vns+    pure $ i :/ EMPTY_MAP ::: ((STMap k v, ns, vn) ::& i)++typeCheckInstr instr@(U.MAP vn mp) i@((STList _, ns, _vn) ::& _) = do+  let vns = notesCase NStar (\(NTList _ v') -> v') ns+  mapImpl vns instr mp i+    (\rt rn -> (::&) (STList rt, mkNotes $ NTList def rn, vn))++typeCheckInstr instr@(U.MAP vn mp) i@((STMap k _, ns, _vn) ::& _)  = do+  let (kns, vns) = notesCase (def, NStar) (\(NTMap _ k' v') -> (k', v')) ns+      pns = mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns+  mapImpl pns instr mp i+    (\rt rn -> (::&) (STMap k rt, mkNotes $ NTMap def kns rn, vn))++-- case `U.HSTER []` is wrongly typed by definition+-- (as it is required to at least drop an element), so we don't consider it++typeCheckInstr instr@(U.ITER (i1 : ir)) i@((STSet _, n, _) ::& _) = do+  let en = notesCase NStar (\(NTSet _ en_) -> mkNotes $ NTc en_) n+  iterImpl en instr (i1 :| ir) i+typeCheckInstr instr@(U.ITER (i1 : ir)) (i@((STList _, n, _) ::& _)) = do+  let en = notesCase NStar (\(NTList _ en_) -> en_) n+  iterImpl en instr (i1 :| ir) i+typeCheckInstr instr@(U.ITER (i1 : ir)) (i@((STMap _ _, n, _) ::& _)) = do+  let en = notesCase NStar (\(NTMap _ kns vns) ->+              mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns) n+  iterImpl en instr (i1 :| ir) i++typeCheckInstr instr@(U.MEM vn)+           i@((STc _, _, _) ::& (STSet _, _, _) ::& _) = memImpl instr i vn+typeCheckInstr instr@(U.MEM vn)+           i@((STc _, _, _) ::& (STMap _ _, _, _) ::& _) = memImpl instr i vn+typeCheckInstr instr@(U.MEM vn)+           i@((STc _, _, _) ::& (STBigMap _ _, _, _) ::& _) = memImpl instr i vn++typeCheckInstr instr@(U.GET vn) i@(_ ::& (STMap _ vt, cn, _) ::& _) =+  getImpl instr i vt (notesCase NStar (\(NTMap _ _ v) -> v) cn) vn+typeCheckInstr instr@(U.GET vn) i@(_ ::& (STBigMap _ vt, cn, _) ::& _) =+  getImpl instr i vt (notesCase NStar (\(NTBigMap _ _ v) -> v) cn) vn++typeCheckInstr instr@U.UPDATE i@(_ ::& _ ::& (STMap _ _, _, _) ::& _) =+  updImpl instr i+typeCheckInstr instr@U.UPDATE i@(_ ::& _ ::& (STBigMap _ _, _, _)+                                             ::& _) = updImpl instr i+typeCheckInstr instr@U.UPDATE i@(_ ::& _ ::& (STSet _, _, _) ::& _) = updImpl instr i++typeCheckInstr (U.IF mp mq) i@((STc SCBool, _, _) ::& rs)  =+  genericIf IF U.IF mp mq rs rs i++typeCheckInstr instr@(U.LOOP is)+           i@((STc SCBool, _, _) ::& (rs :: HST rs)) = do+  _ :/ tp <- lift $ typeCheckList is rs+  case tp of+    subI ::: (o :: HST o) -> do+      case eqHST o (sing @('Tc 'CBool) -:& rs) of+        Right Refl -> do+          let _ ::& rs' = o+          pure $ i :/ LOOP subI ::: rs'+        Left m -> onTypeCheckInstrErr instr (SomeHST i)+                    "iteration expression has wrong output stack type:" (Left m)+    AnyOutInstr subI ->+      pure $ i :/ LOOP subI ::: rs++typeCheckInstr instr@(U.LOOP_LEFT is)+           i@((STOr (at :: Sing a) (bt :: Sing b), ons, ovn)+                      ::& (rs :: HST rs)) = do+  let (an, bn, avn, bvn) = deriveNsOr ons ovn+      ait = (at, an, avn) ::& rs+  _ :/ tp <- lift $ typeCheckList is ait+  case tp of+    subI ::: o -> do+      case (eqHST o (sing @('TOr a b) -:& rs), o) of+        (Right Refl, ((STOr _ bt', ons', ovn') ::& rs')) -> do+            let (_, bn', _, bvn') = deriveNsOr ons' ovn'+            br <- onTypeCheckInstrAnnErr instr i "wrong LOOP_LEFT input type:" $+                    convergeHSTEl (bt, bn, bvn) (bt', bn', bvn')+            pure $ i :/ LOOP_LEFT subI ::: (br ::& rs')+        (Left m, _) -> onTypeCheckInstrErr instr (SomeHST i)+                         "iteration expression has wrong output stack type:" (Left m)+    AnyOutInstr subI -> do+      let br = (bt, bn, bvn)+      pure $ i :/ LOOP_LEFT subI ::: (br ::& rs)++typeCheckInstr instr@(U.LAMBDA vn imt omt is) i = do+  withSomeSingT (fromUType imt) $ \(it :: Sing it) -> do+    withSomeSingT (fromUType omt) $ \(ot :: Sing ot) -> do+      ins <- onTypeCheckInstrTypeErr instr i "wrong lambda input type:" (extractNotes imt it)+      ons <- onTypeCheckInstrTypeErr instr i "wrong lambda output type:" (extractNotes omt ot)+      -- further processing is extracted into another function because+      -- otherwise I encountered some weird GHC error with that code+      -- located right here+      lamImpl instr is vn it ins ot ons i++typeCheckInstr instr@(U.EXEC vn) i@(((_ :: Sing t1), _, _)+                              ::& (STLambda (_ :: Sing t1') t2, ln, _)+                              ::& rs) = do+  let t2n = notesCase NStar (\(NTLambda _ _ n) -> n) ln+  Refl <- onTypeCheckInstrErr instr (SomeHST i)+                "lambda is given argument with wrong type:" (eqType @t1 @t1')+  pure $ i :/ EXEC ::: ((t2, t2n, vn) ::& rs)++typeCheckInstr instr@(U.DIP is) i@(a ::& (s :: HST s)) = do+  _ :/ tp <- lift (typeCheckList is s)+  case tp of+    subI ::: t ->+      pure $ i :/ DIP subI ::: (a ::& t)+    AnyOutInstr _ -> do+      -- This may seem like we throw error because of despair, but in fact,+      -- the reference implementation seems to behave exactly in this way -+      -- if output stack of code block within @DIP@ occurs to be any, an+      -- error "FAILWITH must be at tail position" is raised.+      typeCheckInstrErr instr (SomeHST i)+          "Code within DIP instruction always fails, which is not allowed"++typeCheckInstr U.FAILWITH i@(_ ::& _) =+  pure $ i :/ AnyOutInstr FAILWITH++typeCheckInstr instr@(U.CAST vn mt)+           i@(((e :: Sing e), (en :: Notes e), evn) ::& rs) =+  withSomeSingT (fromUType mt) $ \(_ :: Sing e') -> do+    Refl <- errM (eqType @e @e')+    en' <- errM (extractNotes mt e `onLeft` ExtractionTypeMismatch)+    ns <- errM (converge en en' `onLeft` AnnError)+    pure $ i :/ CAST ::: ((e, ns, vn `orAnn` evn) ::& rs)+  where+    errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a+    errM = onTypeCheckInstrErr instr (SomeHST i) "cast to incompatible type:"++typeCheckInstr (U.RENAME vn) i@((at, an, _) ::& rs) =+  pure $ i :/ RENAME ::: ((at, an, vn) ::& rs)++typeCheckInstr instr@(U.UNPACK vn mt) i@((STc SCBytes, _, _) ::& rs) =+  withSomeSingT (fromUType mt) $ \t -> do+    tns <- onTypeCheckInstrTypeErr instr i "wrong unpack type" (extractNotes mt t)+    let ns = mkNotes $ NTOption def def tns+    proofOp <-+      maybe (typeCheckInstrErr instr (SomeHST i)+             "Operation cannot appear in serialized data")+      pure (opAbsense t)+    proofBigMap <-+      maybe (typeCheckInstrErr instr (SomeHST i)+             "BigMap cannot appear in serialized data")+      pure (bigMapAbsense t)+    case (proofOp, proofBigMap) of+      (Dict, Dict) -> pure $ i :/ UNPACK ::: ((STOption t, ns, vn) ::& rs)++typeCheckInstr instr@(U.PACK vn) i@(((a :: Sing a), _, _) ::& rs) = do+  proofOp <-+    maybe (onTypeCheckInstrErr instr (SomeHST i)+           "Operations cannot appear in serialized data"+           $ Left $ UnsupportedTypes [demote @a])+    pure (opAbsense a)+  proofBigMap <-+    maybe (onTypeCheckInstrErr instr (SomeHST i)+           "BigMap cannot appear in serialized data"+           $ Left $ UnsupportedTypes [demote @a])+    pure (bigMapAbsense a)+  case (proofOp, proofBigMap) of+    (Dict, Dict) -> pure $ i :/ PACK ::: ((STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (U.CONCAT vn) i@((STc SCBytes, _, _) ::&+                                    (STc SCBytes, _, _) ::& _) = concatImpl i vn+typeCheckInstr (U.CONCAT vn) i@((STc SCString, _, _) ::&+                                    (STc SCString, _, _) ::& _) = concatImpl i vn+typeCheckInstr (U.CONCAT vn) i@((STList (STc SCBytes), _, _) ::& _) = concatImpl' i vn+typeCheckInstr (U.CONCAT vn) i@((STList (STc SCString), _, _) ::& _) = concatImpl' i vn+typeCheckInstr (U.SLICE vn) i@((STc SCNat, _, _) ::&+                                   (STc SCNat, _, _) ::&+                                   (STc SCString, _, _) ::& _) = sliceImpl i vn+typeCheckInstr (U.SLICE vn) i@((STc SCNat, _, _) ::&+                                   (STc SCNat, _, _) ::&+                                   (STc SCBytes, _, _) ::& _) = sliceImpl i vn++typeCheckInstr (U.ISNAT vn') i@((STc SCInt, _, oldVn) ::& rs) = do+  let vn = vn' `orAnn` oldVn+  pure $ i :/ ISNAT ::: ((STOption (STc SCNat), NStar, vn) ::& rs)++typeCheckInstr (U.ADD vn) i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _) = addImpl a b i vn++typeCheckInstr (U.SUB vn) i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _) = subImpl a b i vn++typeCheckInstr (U.MUL vn) i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _) = mulImpl a b i vn++typeCheckInstr (U.EDIV vn) i@((STc a, _, _) ::&+                                  (STc b, _, _) ::& _) = edivImpl a b i vn++typeCheckInstr (U.ABS vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Abs ABS i vn++typeCheckInstr U.NEG (i@((STc SCInt, _, _) ::& _)) = unaryArithImpl @Neg NEG i def++typeCheckInstr U.NEG (i@((STc SCNat, _, _) ::& _)) = unaryArithImpl @Neg NEG i def++typeCheckInstr (U.LSL vn) i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _) = arithImpl @Lsl LSL i vn++typeCheckInstr (U.LSR vn) i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _) = arithImpl @Lsr LSR i vn++typeCheckInstr (U.OR vn) i@((STc SCBool, _, _) ::&+                         (STc SCBool, _, _) ::& _) = arithImpl @Or OR i vn+typeCheckInstr (U.OR vn) i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _) = arithImpl @Or OR i vn++typeCheckInstr (U.AND vn) i@((STc SCInt, _, _) ::&+                         (STc SCNat, _, _) ::& _) = arithImpl @And AND i vn+typeCheckInstr (U.AND vn) i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _) = arithImpl @And AND i vn+typeCheckInstr (U.AND vn) i@((STc SCBool, _, _) ::&+                         (STc SCBool, _, _) ::& _) = arithImpl @And AND i vn++typeCheckInstr (U.XOR vn) i@((STc SCBool, _, _) ::&+                         (STc SCBool, _, _) ::& _) = arithImpl @Xor XOR i vn+typeCheckInstr (U.XOR vn) i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _) = arithImpl @Xor XOR i vn++typeCheckInstr (U.NOT vn) i@((STc SCNat, _, _) ::& _) = unaryArithImpl @Not NOT i vn+typeCheckInstr (U.NOT vn) i@((STc SCBool, _, _) ::& _) = unaryArithImpl @Not NOT i vn+typeCheckInstr (U.NOT vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Not NOT i vn++typeCheckInstr (U.COMPARE vn) i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _) = compareImpl a b i vn++typeCheckInstr (U.EQ vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Eq' EQ i vn++typeCheckInstr (U.NEQ vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Neq NEQ i vn++typeCheckInstr (U.LT vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Lt LT i vn++typeCheckInstr (U.GT vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Gt GT i vn++typeCheckInstr (U.LE vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Le LE i vn++typeCheckInstr (U.GE vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Ge GE i vn++typeCheckInstr (U.INT vn) i@((STc SCNat, _, _) ::& rs) =+  pure $ i :/ INT ::: ((STc SCInt, NStar, vn) ::& rs)++typeCheckInstr instr@(U.SELF vn) shst@i = do+  cpType <- gets tcContractParam+  let t = fromUType cpType+  withSomeSingT t $ \(singcp :: Sing cp) -> do+    nt <- onTypeCheckInstrTypeErr instr shst "wrong self type" (extractNotes cpType singcp )+    pure $ i :/ SELF @cp ::: ((sing @('TContract cp), N (NTContract U.noAnn nt), vn) ::& i)++typeCheckInstr instr@(U.CONTRACT vn mt)+           i@((STc SCAddress, _, _) ::& rs) =+  withSomeSingT (fromUType mt) $ \t -> do+    tns <- onTypeCheckInstrTypeErr instr i "wrong contract command type" (extractNotes mt t)+    let ns = mkNotes $ NTOption def def $ mkNotes $ NTContract def tns+    pure $ i :/ CONTRACT tns ::: ((STOption $ STContract t, ns, vn) ::& rs)++typeCheckInstr instr@(U.TRANSFER_TOKENS vn) i@(((_ :: Sing p'), _, _)+  ::& (STc SCMutez, _, _) ::& (STContract (p :: Sing p), _, _) ::& rs) = do+  proofOp <-+    maybe (onTypeCheckInstrErr instr (SomeHST i)+            "contract param type cannot contain operation"+            $ Left $ UnsupportedTypes [demote @p])+    pure (opAbsense p)+  proofBigMap <-+    maybe (onTypeCheckInstrErr instr (SomeHST i)+            "contract param type cannot contain big_map"+            $ Left $ UnsupportedTypes [demote @p])+    pure (bigMapAbsense p)+  case (eqType @p @p', proofOp, proofBigMap) of+    (Right Refl, Dict, Dict) ->+      pure $ i :/ TRANSFER_TOKENS ::: ((STOperation, NStar, vn) ::& rs)+    (Left m, _, _) ->+      onTypeCheckInstrErr instr (SomeHST i)+        "mismatch of contract param type:" (Left m)++typeCheckInstr (U.SET_DELEGATE vn)+           i@((STOption (STc SCKeyHash), _, _) ::& rs) = do+  pure $ i :/ SET_DELEGATE ::: ((STOperation, NStar, vn) ::& rs)++typeCheckInstr (U.CREATE_ACCOUNT ovn avn)+           i@((STc SCKeyHash, _, _)+             ::& (STOption (STc SCKeyHash), _, _) ::& (STc SCBool, _, _)+             ::& (STc SCMutez, _, _) ::& rs) =+  pure $ i :/ CREATE_ACCOUNT ::: ((STOperation, NStar, ovn) ::&+                                   (STc SCAddress, NStar, avn) ::& rs)++typeCheckInstr instr@(U.CREATE_CONTRACT ovn avn contract)+           i@((STc SCKeyHash, _, _)+             ::& (STOption (STc SCKeyHash), _, _)+             ::& (STc SCBool, _, _)+             ::& (STc SCBool, _, _)+             ::& (STc SCMutez, _, _)+             ::& ((_ :: Sing g), gn, _) ::& rs) = do+  (SomeContract (contr :: Contract p' g') _ out) <- lift $ typeCheckContractImpl contract+  Refl <- checkEqT @g @g' instr i "contract storage type mismatch"+  void $ onTypeCheckInstrAnnErr instr i "contract storage type mismatch" (converge gn (outNotes out) )+  pure $ i :/ CREATE_CONTRACT contr ::: ((STOperation, NStar, ovn) ::&+                                           (STc SCAddress, NStar, avn) ::& rs)+  where+    outNotes :: HST '[ 'TPair ('TList 'TOperation) g' ] -> Notes g'+    outNotes ((_, n, _) ::& SNil) =+      notesCase NStar (\(NTPair _ _ _ _ n') -> n') n++typeCheckInstr (U.IMPLICIT_ACCOUNT vn)+           i@((STc SCKeyHash, _, _) ::& rs) =+  pure $ i :/ IMPLICIT_ACCOUNT ::: ((STContract STUnit, NStar, vn) ::& rs)++typeCheckInstr (U.NOW vn) i =+  pure $ i :/ NOW ::: ((STc SCTimestamp, NStar, vn) ::& i)++typeCheckInstr (U.AMOUNT vn) i =+  pure $ i :/ AMOUNT ::: ((STc SCMutez, NStar, vn) ::& i)++typeCheckInstr (U.BALANCE vn) i =+  pure $ i :/ BALANCE ::: ((STc SCMutez, NStar, vn) ::& i)++typeCheckInstr (U.CHECK_SIGNATURE vn)+           i@((STKey, _, _)+             ::& (STSignature, _, _) ::& (STc SCBytes, _, _) ::& rs) =+  pure $ i :/ CHECK_SIGNATURE ::: ((STc SCBool, NStar, vn) ::& rs)++typeCheckInstr (U.SHA256 vn)+           i@((STc SCBytes, _, _) ::& rs) =+  pure $ i :/ SHA256 ::: ((STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (U.SHA512 vn)+           i@((STc SCBytes, _, _) ::& rs) =+  pure $ i :/ SHA512 ::: ((STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (U.BLAKE2B vn)+           i@((STc SCBytes, _, _) ::& rs) =+  pure $ i :/ BLAKE2B ::: ((STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (U.HASH_KEY vn)+           i@((STKey, _, _) ::& rs) =+  pure $ i :/ HASH_KEY ::: ((STc SCKeyHash, NStar, vn) ::& rs)++typeCheckInstr (U.STEPS_TO_QUOTA vn) i =+  pure $ i :/ STEPS_TO_QUOTA ::: ((STc SCNat, NStar, vn) ::& i)++typeCheckInstr (U.SOURCE vn) i =+  pure $ i :/ SOURCE ::: ((STc SCAddress, NStar, vn) ::& i)++typeCheckInstr (U.SENDER vn) i =+  pure $ i :/ SENDER ::: ((STc SCAddress, NStar, vn) ::& i)++typeCheckInstr (U.ADDRESS vn) i@((STContract _, _, _) ::& rs) =+  pure $ i :/ ADDRESS ::: ((STc SCAddress, NStar, vn) ::& rs)++typeCheckInstr instr sit = typeCheckInstrErr instr (SomeHST sit) "unknown expression"++-- | Helper function for two-branch if where each branch is given a single+-- value.+genericIf+  :: forall bti bfi cond rs .+    (Typeable bti, Typeable bfi)+  => (forall s'.+        Instr bti s' ->+        Instr bfi s' ->+        Instr (cond ': rs) s'+     )+  -> ([U.ExpandedOp] -> [U.ExpandedOp] -> U.ExpandedInstr)+  -> [U.ExpandedOp]+  -> [U.ExpandedOp]+  -> HST bti+  -> HST bfi+  -> HST (cond ': rs)+  -> TypeCheckInstr (SomeInstr (cond ': rs))+genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) = do+  _ :/ pinstr <- lift $ typeCheckList mbt bti+  _ :/ qinstr <- lift $ typeCheckList mbf bfi+  fmap (i :/) $ case (pinstr, qinstr) of+    (p ::: po, q ::: qo) -> do+      let instr = mCons mbt mbf+      Refl <- checkEqHST qo po instr i+                    "branches have different output stack types:"+      o <- onTypeCheckInstrAnnErr instr i "branches have different output stack types:" (convergeHST po qo)+      pure $ cons p q ::: o+    (AnyOutInstr p, q ::: qo) -> do+      pure $ cons p q ::: qo+    (p ::: po, AnyOutInstr q) -> do+      pure $ cons p q ::: po+    (AnyOutInstr p, AnyOutInstr q) ->+      pure $ AnyOutInstr (cons p q)++mapImpl+  :: forall c rs .+    ( MapOp c+    , SingI (MapOpInp c)+    , Typeable (MapOpInp c)+    , Typeable (MapOpRes c)+    )+  => Notes (MapOpInp c)+  -> U.ExpandedInstr+  -> [U.ExpandedOp]+  -> HST (c ': rs)+  -> (forall v' . (Typeable v', SingI v') =>+        Sing v' -> Notes v' -> HST rs -> HST (MapOpRes c v' ': rs))+  -> TypeCheckInstr (SomeInstr (c ': rs))+mapImpl vn instr mp i@(_ ::& rs) mkRes = do+  _ :/ subp <- lift $ typeCheckList mp ((sing, vn, def) ::& rs)+  case subp of+    sub ::: subo ->+      case subo of+        (b, bn, _bvn) ::& rs' -> do+          Refl <- checkEqHST rs rs' instr i $+                      "map expression has changed not only top of the stack"+          pure $ i :/ MAP sub ::: mkRes b bn rs'+        _ -> typeCheckInstrErr instr (SomeHST i) "map expression has wrong output stack type (empty stack)"+    AnyOutInstr _ ->+      typeCheckInstrErr instr (SomeHST i) "MAP code block always fails, which is not allowed"++iterImpl+  :: forall c rs .+    ( IterOp c+    , SingI (IterOpEl c)+    , Typeable (IterOpEl c)+    )+  => Notes (IterOpEl c)+  -> U.ExpandedInstr+  -> NonEmpty U.ExpandedOp+  -> HST (c ': rs)+  -> TypeCheckInstr (SomeInstr (c ': rs))+iterImpl en instr mp i@((_, _, lvn) ::& rs) = do+  let evn = deriveVN "elt" lvn+  _ :/ subp <- lift $ typeCheckNE mp ((sing, en, evn) ::& rs)+  case subp of+    subI ::: o -> do+      Refl <- checkEqHST o rs instr i+                "iteration expression has wrong output stack type"+      pure $ i :/ ITER subI ::: o+    AnyOutInstr _ ->+      typeCheckInstrErr instr (SomeHST i) "ITER code block always fails, which is not allowed"++lamImpl+  :: forall it ot ts .+    ( Typeable it, Typeable ts, Typeable ot+    , SingI it, SingI ot+    )+  => U.ExpandedInstr+  -> [U.ExpandedOp]+  -> VarAnn+  -> Sing it -> Notes it+  -> Sing ot -> Notes ot+  -> HST ts+  -> TypeCheckInstr (SomeInstr ts)+lamImpl instr is vn it ins ot ons i = do+  when (any hasSelf is) $+    typeCheckInstrErr instr (SomeHST i) "The SELF instruction cannot appear in a lambda"+  _ :/ lamI <- lift $ typeCheckList is ((it, ins, def) ::& SNil)+  let lamNotes onsr = mkNotes $ NTLambda def ins onsr+  let lamSt onsr = (STLambda it ot, lamNotes onsr, vn) ::& i+  fmap (i :/) $ case lamI of+    lam ::: lo -> do+      case eqHST1 @ot lo of+        Right Refl -> do+            let (_, ons', _) ::& SNil = lo+            onsr <- onTypeCheckInstrAnnErr instr i "wrong output type of lambda's expression:" (converge ons ons')+            pure (LAMBDA (VLam lam) ::: lamSt onsr)+        Left m -> onTypeCheckInstrErr instr (SomeHST i)+                    "wrong output type of lambda's expression:" (Left m)+    AnyOutInstr lam ->+      pure (LAMBDA (VLam lam) ::: lamSt ons)+  where+    hasSelf :: U.ExpandedOp -> Bool+    hasSelf = everything (||)+      (mkQ False+       (\case+           (U.SELF _ :: U.InstrAbstract U.ExpandedOp) -> True+           _ -> False+       )+      )
+ src/Michelson/TypeCheck/TypeCheck.hs view
@@ -0,0 +1,72 @@+module Michelson.TypeCheck.TypeCheck+  ( TcInstrHandler+  , TcOriginatedContracts+  , TcResult+  , TypeCheckEnv (..)+  , TypeCheck+  , runTypeCheck+  , TypeCheckInstr+  , runTypeCheckTest++  , tcContractParamL+  , tcContractsL+  , tcExtFramesL+  ) where++import Control.Lens (makeLensesWith)++import Michelson.ErrorPos (InstrCallStack)+import Michelson.TypeCheck.Error (TCError)+import Michelson.TypeCheck.Types+import qualified Michelson.Untyped as U+import Tezos.Address (Address)+import Util.Lens++type TypeCheck a =+  ExceptT TCError+    (State TypeCheckEnv) a++type TcOriginatedContracts = Map Address U.Type++-- | The typechecking state+data TypeCheckEnv = TypeCheckEnv+  { tcExtFrames     :: TcExtFrames+  , tcContractParam :: U.Type+  , tcContracts     :: TcOriginatedContracts+  }++makeLensesWith postfixLFields ''TypeCheckEnv++runTypeCheck :: U.Type -> TcOriginatedContracts -> TypeCheck a -> Either TCError a+runTypeCheck param contracts act =+  evaluatingState (TypeCheckEnv [] param contracts) $ runExceptT act++-- | Run type checker as if it worked isolated from other world -+-- no access to environment of the current contract is allowed.+--+-- Use this function for test purposes only.+runTypeCheckTest :: TypeCheck a -> Either TCError a+runTypeCheckTest = evaluatingState initSt . runExceptT+  where+  initSt =+    TypeCheckEnv+    { tcExtFrames = []+    , tcContractParam = error "Contract param touched"+    , tcContracts = mempty+    }++type TcResult inp = Either TCError (SomeInstr inp)++type TypeCheckInstr a =+       ReaderT InstrCallStack (ExceptT TCError (State TypeCheckEnv)) a++-- pva701: it's really painful to add arguments to TcInstrHandler+-- due to necessity to refactor @typeCheckInstr@.+-- Also functions which are being called from @typeCheckInstr@ would+-- have to be refactored too.+-- Therefore, I am using ReaderT over TypeCheck.+type TcInstrHandler+   = forall inp. Typeable inp+      => U.ExpandedInstr+      -> HST inp+      -> TypeCheckInstr (SomeInstr inp)
src/Michelson/TypeCheck/Types.hs view
@@ -1,32 +1,30 @@ module Michelson.TypeCheck.Types     ( HST (..)+    , (-:&)     , SomeHST (..)+    , SomeInstrOut (..)     , SomeInstr (..)-    , SomeVal (..)+    , SomeValue (..)     , SomeContract (..)-    , SomeValC (..)-    , TCError (..)-    , ExtC-    , TcInstrHandler-    , TcExtHandler+    , SomeCValue (..)+    , BoundVars (..)     , TcExtFrames-    , TcResult-    , TypeCheckEnv (..)-    , TypeCheckT-    , runTypeCheckT+    , noBoundVars     ) where  import Data.Singletons (SingI)-import Fmt (Buildable(..), pretty, (+|), (|+), (||+)) import Prelude hiding (EQ, GT, LT) import qualified Text.Show+import qualified Data.Map.Lazy as Map -import Michelson.Typed (ConversibleExt, Notes(..), Sing(..), T(..), fromSingT)-import Michelson.Typed.Extract (toUType)+import Michelson.EqParam (eqParam1)+import Michelson.Untyped (Var, Type, noAnn)+import Michelson.Typed+  (HasNoBigMap, HasNoOp, Notes(..), Sing(..), BigMapConstraint, T(..), fromSingT)+import qualified Michelson.Typed as T import Michelson.Typed.Instr import Michelson.Typed.Value -import qualified Michelson.Untyped as U import Michelson.Untyped.Annotation (VarAnn)  -- | Data type holding type information for stack (Heterogeneous Stack Type).@@ -72,115 +70,98 @@  infixr 7 ::& +instance Eq (HST ts) where+  SNil == SNil = True+  (_, n1, a1) ::& h1 == (_, n2, a2) ::& h2 =+    n1 == n2 && a1 == a2 && h1 == h2++-- | Append a type to 'HST', assuming that notes and annotations+-- for this type are unknown.+(-:&)+  :: (Typeable xs, Typeable x, SingI x)+  => Sing x+  -> HST xs+  -> HST (x ': xs)+s -:& hst = (s, NStar, noAnn) ::& hst+infixr 7 -:&+ -- | No-argument type wrapper for @HST@ data type. data SomeHST where   SomeHST :: Typeable ts => HST ts -> SomeHST  deriving instance Show SomeHST --- | Data type holding both instruction and--- type representations of instruction's input and output.------ Intput and output stack types are wrapped inside the type and @Typeable@--- constraints are provided to allow convenient unwrapping.-data SomeInstr where-  (:::) :: (Typeable inp, Typeable out)-        => Instr inp out-        -> (HST inp, HST out)-        -> SomeInstr-  SiFail :: SomeInstr+instance Eq SomeHST where+  SomeHST hst1 == SomeHST hst2 = hst1 `eqParam1` hst2 -  -- TODO use this constructor (to have closer reflection of expression)-  -- SiFail :: Typeable inp => Instr cp inp out -> HST inp -> SomeInstr cp+-- | This data type keeps part of type check result - instruction and+-- corresponding output stack.+data SomeInstrOut inp where+  -- | Type-check result with concrete output stack, most common case.+  --+  -- Output stack type is wrapped inside the type and @Typeable@+  -- constraint is provided to allow convenient unwrapping.+  (:::)+    :: (Typeable out)+    => Instr inp out+    -> HST out+    -> SomeInstrOut inp -instance Show InstrExtT => Show SomeInstr where-  show (i ::: (inp, out)) = show i <> " :: " <> show inp <> " -> " <> show out-  show SiFail = "failed"+  -- | Type-check result which matches against arbitrary output stack.+  -- Information about annotations in the output stack is absent.+  --+  -- This case is only possible when the corresponding code terminates+  -- with @FAILWITH@ instruction in all possible executions.+  -- The opposite may be not true though (example: you push always-failing+  -- lambda and immediatelly execute it - stack type is known).+  AnyOutInstr+    :: (forall out. Instr inp out)+    -> SomeInstrOut inp+infix 9 ::: +instance Show (ExtInstr inp) => Show (SomeInstrOut inp) where+  show (i ::: out) = show i <> " :: " <> show out+  show (AnyOutInstr i) = show i <> " :: *"++-- | Data type keeping the whole type check result: instruction and+-- type representations of instruction's input and output.+data SomeInstr inp where+  (:/) :: HST inp -> SomeInstrOut inp -> SomeInstr inp+infix 8 :/++instance Show (ExtInstr inp) => Show (SomeInstr inp) where+  show (inp :/ out) = show inp <> " -> " <> show out+ -- | Data type, holding strictly-typed Michelson value along with its -- type singleton.-data SomeVal where+data SomeValue where     (::::) :: (SingI t, Typeable t)-           => Val Instr t+           => T.Value t            -> (Sing t, Notes t)-           -> SomeVal+           -> SomeValue  -- | Data type, holding strictly-typed Michelson value along with its -- type singleton.-data SomeValC where+data SomeCValue where     (:--:) :: (SingI t, Typeable t)-           => CVal t -> Sing t -> SomeValC+           => CValue t -> Sing t -> SomeCValue  data SomeContract where   SomeContract-    :: (Typeable st, SingI st, SingI cp, Typeable cp)+    :: (Each [Typeable, SingI, HasNoOp] [st, cp]+       , HasNoBigMap cp, BigMapConstraint st)     => Contract cp st     -> HST (ContractInp cp st)     -> HST (ContractOut st)     -> SomeContract -deriving instance Show InstrExtT => Show SomeContract---- | Type check error-data TCError =-    TCFailedOnInstr U.ExpandedInstr SomeHST Text-  | TCFailedOnValue U.UntypedValue T Text-  | TCOtherError Text--instance Buildable TCError where-  build = \case-    TCFailedOnInstr instr (SomeHST t) custom ->-      "Error checking expression " +| instr-          |+ " against input stack type " +| t-          ||+ bool (": " +| custom |+ "") "" (null custom)-    TCFailedOnValue v t custom ->-      "Error checking value " +| v-          |+ " against type " +| toUType t-          |+ bool (": " +| custom |+ "") "" (null custom)-    TCOtherError e ->-      "Error occurred during type check: " +| e |+ ""+deriving instance Show SomeContract -instance Buildable U.ExpandedInstr => Show TCError where-  show = pretty+-- | Set of variables defined in a let-block.+data BoundVars = BoundVars (Map Var Type) (Maybe SomeHST) -instance Buildable U.ExpandedInstr => Exception TCError+noBoundVars :: BoundVars+noBoundVars = BoundVars Map.empty Nothing  -- | State for type checking @nop@-type TcExtFrames = [(U.ExpandedInstrExtU, SomeHST)]---- | Constraints on InstrExtT and untyped Instr--- which are required for type checking-type ExtC-   = ( Show InstrExtT-     , Eq U.ExpandedInstrExtU-     , Typeable InstrExtT-     , Buildable U.ExpandedInstr-     , ConversibleExt-     )--type TypeCheckT a =-  ExceptT TCError-    (State TypeCheckEnv) a---- | Function for typeChecking a @nop@ and updating state--- TypeCheckT is used because inside--- inside of TEST_ASSERT could be PRINT/STACKTYPE/etc extended instructions.-type TcExtHandler-  = U.ExpandedInstrExtU -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe InstrExtT)---- | The typechecking state-data TypeCheckEnv = TypeCheckEnv-  { tcExtHandler    :: TcExtHandler-  , tcExtFrames     :: TcExtFrames-  , tcContractParam :: U.Type-  }--runTypeCheckT :: TcExtHandler -> U.Type -> TypeCheckT a -> Either TCError a-runTypeCheckT nh param act = evaluatingState (TypeCheckEnv nh [] param) $ runExceptT act--type TcResult = Either TCError SomeInstr--type TcInstrHandler-   = U.ExpandedInstr-    -> SomeHST-      -> TypeCheckT SomeInstr+type TcExtFrames = [BoundVars]
src/Michelson/TypeCheck/Value.hs view
@@ -1,61 +1,72 @@ module Michelson.TypeCheck.Value     ( typeCheckValImpl-    , typeCheckCVal+    , typeCheckCValue     ) where  import Control.Monad.Except (liftEither, throwError) import Data.Default (def) import qualified Data.Map as M import qualified Data.Set as S+import Data.Singletons (SingI) import Data.Typeable ((:~:)(..))+import Fmt (pretty) import Prelude hiding (EQ, GT, LT) +import Michelson.Text+import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..)) import Michelson.TypeCheck.Helpers+import Michelson.TypeCheck.TypeCheck (TcInstrHandler, TypeCheckEnv(..), TypeCheckInstr) import Michelson.TypeCheck.Types import Michelson.Typed-  (CT(..), ConversibleExt, Instr(..), InstrExtT, Notes(..), Notes'(..), Sing(..), T(..), converge,-  mkNotes, withSomeSingCT, withSomeSingT)-import Michelson.Typed.Value (CVal(..), Val(..))-import qualified Michelson.Untyped as Un-import Tezos.Address (parseAddress)+  (CT(..), CValue(..), Notes(..), Notes'(..), Sing(..), Value'(..), converge, fromSingCT,+  fromSingT, mkNotes, notesCase)+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U+import Tezos.Address (Address(..), parseAddress) import Tezos.Core (mkMutez, parseTimestamp, timestampFromSeconds) import Tezos.Crypto (parseKeyHash, parsePublicKey, parseSignature) -typeCheckCVal :: Un.Value op -> CT -> Maybe SomeValC-typeCheckCVal (Un.ValueInt i) CInt = pure $ CvInt i :--: SCInt-typeCheckCVal (Un.ValueInt i) CNat+typeCheckCValue+  :: U.Value' op -> CT -> Either (U.Value' op, TCTypeError) SomeCValue+typeCheckCValue (U.ValueInt i) CInt = pure $ CvInt i :--: SCInt+typeCheckCValue (U.ValueInt i) CNat   | i >= 0 = pure $ CvNat (fromInteger i) :--: SCNat-typeCheckCVal (Un.ValueInt (mkMutez . fromInteger -> Just mtz)) CMutez =+typeCheckCValue (U.ValueInt (mkMutez . fromInteger -> Just mtz)) CMutez =   pure $ CvMutez mtz :--: SCMutez-typeCheckCVal (Un.ValueString s) CString =+typeCheckCValue (U.ValueString s) CString =   pure $ CvString s :--: SCString-typeCheckCVal (Un.ValueString (parseAddress -> Right s)) CAddress =+typeCheckCValue (U.ValueString (parseAddress . unMText -> Right s)) CAddress =   pure $ CvAddress s :--: SCAddress-typeCheckCVal (Un.ValueString (parseKeyHash -> Right s)) CKeyHash =+typeCheckCValue (U.ValueString (parseKeyHash . unMText -> Right s)) CKeyHash =   pure $ CvKeyHash s :--: SCKeyHash-typeCheckCVal (Un.ValueString (parseTimestamp -> Just t)) CTimestamp =+typeCheckCValue (U.ValueString (parseTimestamp . unMText -> Just t)) CTimestamp =   pure $ CvTimestamp t :--: SCTimestamp-typeCheckCVal (Un.ValueInt i) CTimestamp =+typeCheckCValue (U.ValueInt i) CTimestamp =   pure $ CvTimestamp (timestampFromSeconds i) :--: SCTimestamp-typeCheckCVal (Un.ValueBytes (Un.InternalByteString s)) CBytes =+typeCheckCValue (U.ValueBytes (U.InternalByteString s)) CBytes =   pure $ CvBytes s :--: SCBytes-typeCheckCVal Un.ValueTrue CBool = pure $ CvBool True :--: SCBool-typeCheckCVal Un.ValueFalse CBool = pure $ CvBool False :--: SCBool-typeCheckCVal _ _ = Nothing+typeCheckCValue U.ValueTrue CBool = pure $ CvBool True :--: SCBool+typeCheckCValue U.ValueFalse CBool = pure $ CvBool False :--: SCBool+typeCheckCValue v t =+  Left $ (v, UnknownType (T.Tc t))  typeCheckCVals-  :: forall t op . Typeable t-  => [Un.Value op]+  :: forall t op . (Typeable t, SingI t)+  => [U.Value' op]   -> CT-  -> Either (Un.Value op, Text) [CVal t]+  -> Either (U.Value' op, TCTypeError) [CValue t] typeCheckCVals mvs t = traverse check mvs   where     check mv = do-      v :--: (_ :: Sing t') <--        maybe (Left (mv, "failed to typecheck cval")) pure $ typeCheckCVal mv t-      Refl <- eqT' @t @t' `onLeft` (,) mv+      v :--: (_ :: Sing t') <- typeCheckCValue mv t+      Refl <- eqType @('T.Tc t) @('T.Tc t') `onLeft` (,) mv       pure v +tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a+tcFailedOnValue v t msg err = do+  loc <- ask+  throwError $ TCFailedOnValue v t msg loc err+ -- | Function @typeCheckValImpl@ converts a single Michelson value -- given in representation from @Michelson.Type@ module to representation -- in strictly typed GADT.@@ -69,131 +80,162 @@ -- that is interpreted as input of wrong type and type check finishes with -- error. typeCheckValImpl-  :: (Show InstrExtT, ConversibleExt, Eq Un.ExpandedInstrExtU)-  => TcInstrHandler-  -> Un.UntypedValue-  -> T-  -> TypeCheckT SomeVal-typeCheckValImpl _ mv t@(Tc ct) =-  maybe (throwError $ TCFailedOnValue mv t "")-        (\(v :--: cst) -> pure $ VC v :::: (STc cst, NStar))-        (typeCheckCVal mv ct)-typeCheckValImpl _ (Un.ValueString (parsePublicKey -> Right s)) TKey =-  pure $ VKey s :::: (STKey, NStar)+  :: TcInstrHandler+  -> U.Value+  -> (Sing t, Notes t)+  -> TypeCheckInstr SomeValue+typeCheckValImpl _ mv (t@(STc ct), ann) = do+  let nt = notesCase U.noAnn (\(NTc x) -> x) ann+  case typeCheckCValue mv (fromSingCT ct) of+    Left (uval, err) -> tcFailedOnValue uval (fromSingT $ t) "" (Just err)+    Right (v :--: cst) -> pure $ VC v :::: (STc cst, mkNotes $ NTc nt)+typeCheckValImpl _ (U.ValueString (parsePublicKey . unMText -> Right s)) t@(STKey, _) =+  pure $ T.VKey s :::: t -typeCheckValImpl _ (Un.ValueString (parseSignature -> Right s)) TSignature =-  pure $ VSignature s :::: (STSignature, NStar)+typeCheckValImpl _ (U.ValueString (parseSignature . unMText -> Right s)) t@(STSignature, _) =+  pure $ VSignature s :::: t -typeCheckValImpl _ (Un.ValueString (parseAddress -> Right s)) (TContract pt) =-  withSomeSingT pt $ \p ->-    pure $ VContract s :::: (STContract p, NStar)-typeCheckValImpl _ Un.ValueUnit TUnit = pure $ VUnit :::: (STUnit, NStar)-typeCheckValImpl tcDo (Un.ValuePair ml mr) (TPair lt rt) = do-  l :::: (lst, ln) <- typeCheckValImpl tcDo ml lt-  r :::: (rst, rn) <- typeCheckValImpl tcDo mr rt-  let ns = mkNotes $ NTPair def def def ln rn+typeCheckValImpl _ (U.ValueString (parseAddress . unMText -> Right s@(KeyAddress _)))+                   t@(STContract STUnit, _) =+    pure $ T.VContract s :::: t++typeCheckValImpl _ cv@(U.ValueString (parseAddress . unMText -> Right s))+                   t@(STContract pc, cn) = do+  instrPos <- ask+  let tcFail = \msg -> TCFailedOnValue cv (fromSingT $ fst t) msg instrPos Nothing+  let pn = notesCase NStar (\(NTContract _ x) -> x) cn+  contracts <- gets tcContracts+  case M.lookup s contracts of+    Just contractParam -> do+      liftEither $ first (TCFailedOnValue cv (fromSingT $ fst t) "invalid contract parameter" instrPos . Just) $+        compareTypes (pc, pn) contractParam+      pure $ VContract s :::: t+    _ -> throwError $ tcFail $ "Contract literal " <> pretty s <> " doesn't exist"++typeCheckValImpl _ U.ValueUnit t@(STUnit, _) = pure $ VUnit :::: t+typeCheckValImpl tcDo (U.ValuePair ml mr) (STPair lt rt, pn) = do+  let (n1, n2, n3, nl, nr) =+        notesCase (U.noAnn, U.noAnn, U.noAnn, NStar, NStar) (\(NTPair x1 x2 x3 xl xr) -> (x1, x2, x3, xl, xr)) pn+  l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl)+  r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr)+  let ns = mkNotes $ NTPair n1 n2 n3 ln rn   pure $ VPair (l, r) :::: (STPair lst rst, ns)-typeCheckValImpl tcDo (Un.ValueLeft ml) (TOr lt rt) = do-  l :::: (lst, ln) <- typeCheckValImpl tcDo ml lt-  withSomeSingT rt $ \rst ->-    pure $ VOr (Left l) :::: ( STOr lst rst-                             , mkNotes $ NTOr def def def ln NStar )-typeCheckValImpl tcDo (Un.ValueRight mr) (TOr lt rt) = do-  r :::: (rst, rn) <- typeCheckValImpl tcDo mr rt-  withSomeSingT lt $ \lst ->-    pure $ VOr (Right r) :::: ( STOr lst rst-                              , mkNotes $ NTOr def def def NStar rn )-typeCheckValImpl tcDo (Un.ValueSome mv) (TOption vt) = do-  v :::: (vst, vns) <- typeCheckValImpl tcDo mv vt-  let ns = mkNotes $ NTOption def def vns+typeCheckValImpl tcDo (U.ValueLeft ml) (STOr lt rt, ann) = do+  let (n1, n2, n3, nl, nr) =+        notesCase (U.noAnn, U.noAnn, U.noAnn, NStar, NStar) (\(NTOr x1 x2 x3 xl xr) -> (x1, x2, x3, xl, xr)) ann+  l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl)+  pure $ VOr (Left l) :::: ( STOr lst rt+                            , mkNotes $ NTOr n1 n2 n3 ln nr )+typeCheckValImpl tcDo (U.ValueRight mr) (STOr lt rt, ann) = do+  let (n1, n2, n3, nl, nr) =+        notesCase (U.noAnn, U.noAnn, U.noAnn, NStar, NStar) (\(NTOr x1 x2 x3 xl xr) -> (x1, x2, x3, xl, xr)) ann+  r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr)+  pure $ VOr (Right r) :::: ( STOr lt rst+                            , mkNotes $ NTOr n1 n2 n3 nl rn )+typeCheckValImpl tcDo (U.ValueSome mv) (STOption vt, ann) = do+  let (n1, n2, nt) = notesCase (U.noAnn, U.noAnn, NStar) (\(NTOption x1 x2 xt) -> (x1, x2, xt)) ann+  v :::: (vst, vns) <- typeCheckValImpl tcDo mv (vt, nt)+  let ns = mkNotes $ NTOption n1 n2 vns   pure $ VOption (Just v) :::: (STOption vst, ns)-typeCheckValImpl _ Un.ValueNone (TOption vt) =-  withSomeSingT vt $ \vst ->-    pure $ VOption Nothing :::: (STOption vst, NStar)+typeCheckValImpl _ U.ValueNone t@(STOption _, _) =+  pure $ VOption Nothing :::: t -typeCheckValImpl _ Un.ValueNil (TList vt) =-  withSomeSingT vt $ \vst ->-    pure $ VList [] :::: (STList vst, mkNotes $ NTList def NStar)+typeCheckValImpl _ U.ValueNil t@(STList _, _) =+  pure $ T.VList [] :::: t -typeCheckValImpl tcDo (Un.ValueSeq (toList -> mels)) (TList vt) =-  withSomeSingT vt $ \vst -> do-    (els, ns) <- typeCheckValsImpl tcDo mels vt-    pure $ VList els :::: (STList vst, mkNotes $ NTList def ns)+typeCheckValImpl tcDo (U.ValueSeq (toList -> mels)) t@(STList vt, ann) = do+  let nt = notesCase NStar (\(NTList _ x) -> x) ann+  (els, _) <- typeCheckValsImpl tcDo mels (vt, nt)+  pure $ VList els :::: t -typeCheckValImpl _ Un.ValueNil (TSet vt) =-  withSomeSingCT vt $ \vst ->-    pure $ VSet S.empty :::: (STSet vst, NStar)+typeCheckValImpl _ U.ValueNil t@(STSet _, _) = pure $ T.VSet S.empty :::: t -typeCheckValImpl _ sq@(Un.ValueSeq (toList -> mels)) (TSet vt) =-  withSomeSingCT vt $ \vst -> do-    els <- liftEither $ typeCheckCVals mels vt-            `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc vt) $-                                      "wrong type of set element: " <> err-    elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc els-            `onLeft` TCFailedOnValue sq (Tc vt)-    pure $ VSet elsS :::: (STSet vst, NStar)+typeCheckValImpl _ sq@(U.ValueSeq (toList -> mels)) t@(STSet vt, _) = do+  instrPos <- ask+  els <- liftEither $ typeCheckCVals mels (fromSingCT vt)+          `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc vt)+                                      "wrong type of set element:" instrPos (Just err)+  elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els+            `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc vt) msg instrPos Nothing+  pure $ VSet elsS :::: t -typeCheckValImpl _ Un.ValueNil (TMap kt vt) =-  withSomeSingT vt $ \vst ->-  withSomeSingCT kt $ \kst -> do-    let ns = mkNotes $ NTMap def def NStar-    pure $ VMap M.empty :::: (STMap kst vst, ns)+typeCheckValImpl _ U.ValueNil t@(STMap _ _, _) = pure $ T.VMap M.empty :::: t -typeCheckValImpl tcDo sq@(Un.ValueMap (toList -> mels)) (TMap kt vt) =-  withSomeSingT vt $ \vst ->-  withSomeSingCT kt $ \kst -> do-    ks <- liftEither $  typeCheckCVals (map (\(Un.Elt k _) -> k) mels) kt-            `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc kt) $-                                      "wrong type of map key: " <> err-    (vals, vns) <- typeCheckValsImpl tcDo (map (\(Un.Elt _ v) -> v) mels) vt-    let ns = mkNotes $ NTMap def def vns-    ksS <- liftEither $ ensureDistinctAsc ks-            `onLeft` TCFailedOnValue sq (Tc kt)-    pure $ VMap (M.fromDistinctAscList $ zip ksS vals) :::: (STMap kst vst, ns)+typeCheckValImpl tcDo sq@(U.ValueMap (toList -> mels)) t@(STMap kt vt, ann) = do+  let vn = notesCase NStar (\(NTMap _ _ nt) -> nt) ann+  keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt+  pure $ VMap (M.fromDistinctAscList keyOrderedElts) :::: t -typeCheckValImpl tcDo v t@(TLambda mi mo) = do+typeCheckValImpl _ U.ValueNil t@(STBigMap _ _ , _) = pure $ T.VBigMap M.empty :::: t++typeCheckValImpl tcDo sq@(U.ValueMap (toList -> mels)) t@(STBigMap kt vt, ann) = do+  let vn = notesCase NStar (\(NTBigMap _ _ nt) -> nt) ann+  keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt+  pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) :::: t++typeCheckValImpl tcDo v (t@(STLambda (it :: Sing it) (ot :: Sing ot)), ann) = do   mp <- case v of-    Un.ValueNil -> pure []-    Un.ValueLambda mp -> pure $ toList mp-    _ -> throwError $ TCFailedOnValue v t ""+    U.ValueNil       -> pure []+    U.ValueLambda mp -> pure $ toList mp+    _ -> tcFailedOnValue v (fromSingT t) "unexpected value" Nothing+  let vn = notesCase U.noAnn (\(NTLambda n1 _ _) -> n1) ann+  li :/ instr <- typeCheckImpl tcDo mp ((it, NStar, def) ::& SNil)+  let (_, ins, _) ::& SNil = li+  let lamS = STLambda it ot+  let lamN ons = mkNotes $ NTLambda def ins ons+  case instr of+    lam ::: (lo :: HST lo) -> do+      case eqHST1 @ot lo of+        Right Refl -> do+          let (_, ons, _) ::& SNil = lo+          let ns = mkNotes $ NTLambda vn ins ons+          pure $ VLam lam :::: (STLambda it ot, ns)+        Left m ->+          tcFailedOnValue v (fromSingT t)+                  "wrong output type of lambda's value:" (Just m)+    AnyOutInstr lam ->+      pure $ VLam lam :::: (lamS, lamN NStar) -  withSomeSingT mi $ \(it :: Sing it) ->-    withSomeSingT mo $ \(ot :: Sing ot) ->-      typeCheckImpl tcDo mp (SomeHST $ (it, NStar, def) ::& SNil) >>= \case-        SiFail -> pure $ VLam FAILWITH :::: (STLambda it ot, NStar)-        lam ::: ((li :: HST li), (lo :: HST lo)) -> do-          Refl <- liftEither $ eqT' @li @'[ it ] `onLeft` unexpectedErr-          case (eqT' @'[ ot ] @lo, SomeHST lo, SomeHST li) of-            (Right Refl,-             SomeHST ((_, ons, _) ::& SNil :: HST lo'),-             SomeHST ((_, ins, _) ::& SNil :: HST li')) -> do-              Refl <- liftEither $ eqT' @lo @lo' `onLeft` unexpectedErr-              Refl <- liftEither $ eqT' @li @li' `onLeft` unexpectedErr-              let ns = mkNotes $ NTLambda def ins ons-              pure $ VLam lam :::: (STLambda it ot, ns)-            (Right _, _, _) ->-              throwError $ TCFailedOnValue v t-                      "wrong output type of lambda's value (wrong stack size)"-            (Left m, _, _) ->-              throwError $ TCFailedOnValue v t $-                      "wrong output type of lambda's value: " <> m-  where-    unexpectedErr m = TCFailedOnValue v t ("unexpected " <> m)+typeCheckValImpl _ v (t, _) = tcFailedOnValue v (fromSingT t) "unknown value" Nothing -typeCheckValImpl _ v t = throwError $ TCFailedOnValue v t ""+-- | Function @typeCheckMapVal@ typechecks given list of @Elt@s and+-- ensures, that its keys are in ascending order.+--+-- It return list of pairs (key, value) with keys in ascending order+-- so it is safe to call @fromDistinctAscList@ on returned list+typeCheckMapVal+  :: (SingI kt, Typeable kt, SingI vt, Typeable vt)+  => TcInstrHandler+  -> [U.Elt U.ExpandedOp]+  -> U.Value+  -> Notes vt+  -> Sing kt+  -> Sing vt+  -> TypeCheckInstr [(CValue kt, T.Value vt)]+typeCheckMapVal tcDo mels sq vn kt vt = do+  instrPos <- ask+  ks <- liftEither $ typeCheckCVals (map (\(U.Elt k _) -> k) mels) (fromSingCT kt)+          `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc kt)+                                      "wrong type of map key:" instrPos (Just err)+  (vals, _) <- typeCheckValsImpl tcDo (map (\(U.Elt _ v) -> v) mels) (vt, vn)+  ksS <- liftEither $ ensureDistinctAsc id ks+        `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc kt) msg instrPos Nothing+  pure $ zip ksS vals  typeCheckValsImpl-  :: forall t . (Typeable t, Show InstrExtT, ConversibleExt, Eq Un.ExpandedInstrExtU)+  :: forall t . (Typeable t, SingI t)   => TcInstrHandler-  -> [Un.UntypedValue]-  -> T-  -> TypeCheckT ([Val Instr t], Notes t)-typeCheckValsImpl tcDo mvs t =-  fmap (first reverse) $ foldM check ([], NStar) mvs+  -> [U.Value]+  -> (Sing t, Notes t)+  -> TypeCheckInstr ([T.Value t], Notes t)+typeCheckValsImpl tcDo mvs (t, nt) =+  fmap (first reverse) $ foldM check ([], nt) mvs   where     check (res, ns) mv = do-      v :::: ((_ :: Sing t'), vns) <- typeCheckValImpl tcDo mv t-      Refl <- liftEither $ eqT' @t @t'-                `onLeft` (TCFailedOnValue mv t . ("wrong element type " <>))-      ns' <- liftEither $ converge ns vns `onLeft` TCFailedOnValue mv t+      instrPos <- ask+      v :::: ((_ :: Sing t'), vns) <- typeCheckValImpl tcDo mv (t, nt)+      Refl <- liftEither $ eqType @t @t' `onLeft`+        (TCFailedOnValue mv (fromSingT t) "wrong element type" instrPos . Just)+      ns' <- liftEither $ converge ns vns `onLeft`+        ((TCFailedOnValue mv (fromSingT t) "wrong element type") instrPos . Just . AnnError)       pure (v : res, ns')
src/Michelson/Typed.hs view
@@ -2,13 +2,17 @@   ( module Exports   ) where +import Michelson.Typed.Aliases as Exports import Michelson.Typed.Annotation as Exports import Michelson.Typed.Arith as Exports import Michelson.Typed.Convert as Exports import Michelson.Typed.CValue as Exports import Michelson.Typed.Extract as Exports+import Michelson.Typed.Haskell as Exports import Michelson.Typed.Instr as Exports import Michelson.Typed.Polymorphic as Exports+import Michelson.Typed.Print as Exports+import Michelson.Typed.Scope as Exports import Michelson.Typed.Sing as Exports import Michelson.Typed.T as Exports import Michelson.Typed.Value as Exports
+ src/Michelson/Typed/Aliases.hs view
@@ -0,0 +1,10 @@+module Michelson.Typed.Aliases+  ( Value+  , Operation+  ) where++import Michelson.Typed.Instr+import Michelson.Typed.Value++type Value = Value' Instr+type Operation = Operation' Instr
src/Michelson/Typed/Annotation.hs view
@@ -17,6 +17,7 @@ module Michelson.Typed.Annotation   ( Notes (..)   , Notes' (..)+  , AnnConvergeError(..)   , converge   , convergeAnns   , notesCase@@ -26,7 +27,10 @@   ) where  import Data.Default (Default(..))+import qualified Data.Kind as Kind+import Fmt (Buildable(..), (+|), (|+)) +import Michelson.EqParam import Michelson.Typed.T (T(..)) import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, unifyAnn) @@ -42,7 +46,10 @@ -- no-annotation case completely for free (see 'converge' and 'mkNotes' -- functions). data Notes t = N (Notes' t) | NStar+  deriving (Eq) +deriving instance Show (Notes p)+ -- | Helper function for work with 'Notes' data type. -- -- @@@ -84,6 +91,9 @@   NTMap       :: TypeAnn -> TypeAnn -> Notes v -> Notes' ('TMap k v)   NTBigMap   :: TypeAnn -> TypeAnn -> Notes v -> Notes' ('TBigMap k v) +deriving instance Show (Notes' t)+deriving instance Eq (Notes' t)+ -- | Check whether given annotations object is @*@. isStar :: Notes t -> Bool isStar NStar = True@@ -123,7 +133,7 @@ -- | Combines two annotations trees `a` and `b` into a new one `c` -- in such a way that `c` can be obtained from both `a` and `b` by replacing -- some @*@ leafs with type or/and field annotations.-converge' :: Notes' t -> Notes' t -> Either Text (Notes' t)+converge' :: Notes' t -> Notes' t -> Either AnnConvergeError (Notes' t) converge' (NTc a) (NTc b) = NTc <$> convergeAnns a b converge' (NTKey a) (NTKey b) = NTKey <$> convergeAnns a b converge' (NTUnit a) (NTUnit b) = NTUnit <$> convergeAnns a b@@ -153,15 +163,31 @@   NTBigMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM  -- | Same as 'converge'' but works with 'Notes' data type.-converge :: Notes t -> Notes t -> Either Text (Notes t)+converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t) converge NStar a = pure a converge a NStar = pure a converge (N a) (N b) = N <$> converge' a b +data AnnConvergeError where+  AnnConvergeError+    :: forall (tag :: Kind.Type).+       (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)+    => Annotation tag -> Annotation tag -> AnnConvergeError++deriving instance Show AnnConvergeError++instance Eq AnnConvergeError where+  AnnConvergeError ann1 ann2 == AnnConvergeError ann1' ann2' =+    (ann1 `eqParam1` ann1') && (ann2 `eqParam1` ann2')++instance Buildable AnnConvergeError where+  build (AnnConvergeError ann1 ann2) =+    "Annotations do not converge: " +| ann1 |+ " /= " +| ann2 |+ ""+ -- | Converge two type or field notes (which may be wildcards). convergeAnns-  :: Show (Annotation tag)-  => Annotation tag -> Annotation tag -> Either Text (Annotation tag)-convergeAnns a b = maybe (Left $ "Annotations do not converge: "-                            <> show a <> " /= " <> show b)+  :: forall (tag :: Kind.Type).+     (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)+  => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)+convergeAnns a b = maybe (Left $ AnnConvergeError a b)                           pure $ unifyAnn a b
src/Michelson/Typed/Arith.hs view
@@ -31,7 +31,7 @@ import Data.Bits (complement, shift, xor, (.&.), (.|.)) import Fmt (Buildable(build)) -import Michelson.Typed.CValue (CVal(..))+import Michelson.Typed.CValue (CValue(..)) import Michelson.Typed.T (CT(..)) import Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds) @@ -50,24 +50,27 @@   type ArithRes aop n m :: CT    -- | Evaluate arithmetic operation on given operands.-  evalOp :: proxy aop -> CVal n -> CVal m -> Either (ArithError (CVal n) (CVal m)) (CVal (ArithRes aop n m))+  evalOp :: proxy aop -> CValue n -> CValue m -> Either (ArithError (CValue n) (CValue m)) (CValue (ArithRes aop n m))  -- | Denotes the error type occured in the arithmetic operation. data ArithErrorType   = AddOverflow   | MulOverflow   | SubUnderflow+  | LslOverflow+  | LsrUnderflow   deriving (Show, Eq, Ord)  -- | Represents an arithmetic error of the operation. data ArithError n m   = MutezArithError ArithErrorType n m+  | ShiftArithError ArithErrorType n m   deriving (Show, Eq, Ord)  -- | Marker data type for add operation. class UnaryArithOp aop (n :: CT) where   type UnaryArithRes aop n :: CT-  evalUnaryArithOp :: proxy aop -> CVal n -> CVal (UnaryArithRes aop n)+  evalUnaryArithOp :: proxy aop -> CValue n -> CValue (UnaryArithRes aop n)  data Add data Sub@@ -172,6 +175,9 @@ instance UnaryArithOp Neg 'CInt where   type UnaryArithRes Neg 'CInt = 'CInt   evalUnaryArithOp _ (CvInt i) = CvInt (-i)+instance UnaryArithOp Neg 'CNat where+  type UnaryArithRes Neg 'CNat = 'CInt+  evalUnaryArithOp _ (CvNat i) = CvInt (- fromIntegral i)  instance ArithOp Or 'CNat 'CNat where   type ArithRes Or 'CNat 'CNat = 'CNat@@ -197,16 +203,19 @@   type ArithRes Xor 'CBool 'CBool = 'CBool   evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i `xor` j) --- Todo add condition when shift >= 256 instance ArithOp Lsl 'CNat 'CNat where   type ArithRes Lsl 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) =-    Right $ CvNat (fromInteger $ shift (toInteger i) (fromIntegral j))+  evalOp _ n@(CvNat i) m@(CvNat j) =+    if j > 256+    then Left $ ShiftArithError LslOverflow n m+    else Right $ CvNat (fromInteger $ shift (toInteger i) (fromIntegral j))  instance ArithOp Lsr 'CNat 'CNat where   type ArithRes Lsr 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) =-    Right $ CvNat (fromInteger $ shift (toInteger i) (-(fromIntegral j)))+  evalOp _ n@(CvNat i) m@(CvNat j) =+    if j > 256+    then Left $ ShiftArithError LsrUnderflow n m+    else Right $ CvNat (fromInteger $ shift (toInteger i) (-(fromIntegral j)))  instance UnaryArithOp Not 'CInt where   type UnaryArithRes Not 'CInt = 'CInt@@ -285,7 +294,11 @@   build AddOverflow = "add overflow"   build MulOverflow = "mul overflow"   build SubUnderflow = "sub overflow"+  build LslOverflow = "lsl overflow"+  build LsrUnderflow = "lsr underflow"  instance (Show n, Show m) => Buildable (ArithError n m) where   build (MutezArithError errType n m) = "Mutez "     <> build errType <> " with " <> show n <> ", " <> show m+  build (ShiftArithError errType n m) =+    build errType <> " with " <> show n <> ", " <> show m
src/Michelson/Typed/CValue.hs view
@@ -1,15 +1,12 @@--- | Module, containing CVal data type+-- | Module, containing CValue data type -- which represents Michelson comparable values.  module Michelson.Typed.CValue-  ( CVal (..)-  , ToCVal-  , FromCVal-  , toCVal-  , fromCVal+  ( CValue (..)   ) where -import Michelson.Typed.T (CT(..), ToCT)+import Michelson.Text+import Michelson.Typed.T (CT(..)) import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp) import Tezos.Crypto (KeyHash)@@ -23,87 +20,17 @@ -- -- Only these values can be used as map keys -- or set elements.-data CVal t where-  CvInt       :: Integer -> CVal 'CInt-  CvNat       :: Natural -> CVal 'CNat-  CvString    :: Text -> CVal 'CString-  CvBytes     :: ByteString -> CVal 'CBytes-  CvMutez     :: Mutez -> CVal 'CMutez-  CvBool      :: Bool -> CVal 'CBool-  CvKeyHash   :: KeyHash -> CVal 'CKeyHash-  CvTimestamp :: Timestamp -> CVal 'CTimestamp-  CvAddress   :: Address -> CVal 'CAddress--deriving instance Show (CVal t)-deriving instance Eq (CVal t)-deriving instance Ord (CVal t)---- | Converts a single Haskell value into @CVal@ representation.-class ToCVal a where-  toCVal :: a -> CVal (ToCT a)---- | Converts a @CVal@ value into a single Haskell value.-class FromCVal t where-  fromCVal :: CVal (ToCT t) -> t---- ToCVal, FromCVal instances--instance FromCVal Integer where-  fromCVal (CvInt i) = i--instance FromCVal Natural where-  fromCVal (CvNat i) = i--instance FromCVal Text where-  fromCVal (CvString s) = s--instance FromCVal Bool where-  fromCVal (CvBool b) = b--instance FromCVal ByteString where-  fromCVal (CvBytes b) = b--instance FromCVal Mutez where-  fromCVal (CvMutez m) = m--instance FromCVal KeyHash where-  fromCVal (CvKeyHash k) = k--instance FromCVal Timestamp where-  fromCVal (CvTimestamp t) = t--instance FromCVal Address where-  fromCVal (CvAddress a) = a--instance ToCVal Integer where-  toCVal = CvInt--instance ToCVal Int where-  toCVal = CvInt . fromIntegral--instance ToCVal Word64 where-  toCVal = CvNat . fromIntegral--instance ToCVal Natural where-  toCVal = CvNat--instance ToCVal Text where-  toCVal = CvString--instance ToCVal ByteString where-  toCVal = CvBytes--instance ToCVal Bool where-  toCVal = CvBool--instance ToCVal Mutez where-  toCVal = CvMutez--instance ToCVal KeyHash where-  toCVal = CvKeyHash--instance ToCVal Timestamp where-  toCVal = CvTimestamp+data CValue t where+  CvInt       :: Integer -> CValue 'CInt+  CvNat       :: Natural -> CValue 'CNat+  CvString    :: MText -> CValue 'CString+  CvBytes     :: ByteString -> CValue 'CBytes+  CvMutez     :: Mutez -> CValue 'CMutez+  CvBool      :: Bool -> CValue 'CBool+  CvKeyHash   :: KeyHash -> CValue 'CKeyHash+  CvTimestamp :: Timestamp -> CValue 'CTimestamp+  CvAddress   :: Address -> CValue 'CAddress -instance ToCVal Address where-  toCVal = CvAddress+deriving instance Show (CValue t)+deriving instance Eq (CValue t)+deriving instance Ord (CValue t)
src/Michelson/Typed/Convert.hs view
@@ -3,270 +3,259 @@ module Michelson.Typed.Convert   ( convertContract   , instrToOps-  , unsafeValToValue-  , valToOpOrValue-  , Conversible (..)-  , ConversibleExt+  , untypeValue   ) where  import qualified Data.Map as Map import Data.Singletons (SingI(sing))+import Fmt (pretty) +import Michelson.EqParam (eqParam1, eqParam2)+import Michelson.Text import Michelson.Typed.CValue-import Michelson.Typed.Extract (toUType)+import Michelson.Typed.Extract (mkUType, toUType) import Michelson.Typed.Instr as Instr-import Michelson.Typed.Sing (fromSingCT, fromSingT)+import Michelson.Typed.Scope+import Michelson.Typed.Sing (Sing(..), fromSingCT, fromSingT) import Michelson.Typed.T (CT(..), T(..)) import Michelson.Typed.Value-import qualified Michelson.Untyped as Un-import Tezos.Address (formatAddress)+import qualified Michelson.Untyped as U+import Tezos.Address (mformatAddress) import Tezos.Core (unMutez)-import Tezos.Crypto (formatKeyHash, formatPublicKey, formatSignature)--class Conversible ext1 ext2 where-  convert :: ext1 -> ext2--type ConversibleExt = Conversible (ExtT Instr) (Un.ExtU Un.InstrAbstract Un.ExpandedOp)+import Tezos.Crypto (mformatKeyHash, mformatPublicKey, mformatSignature)+import Util.Peano  convertContract-  :: forall param store . (SingI param, SingI store, ConversibleExt)-  => Contract param store -> Un.UntypedContract+  :: forall param store . (SingI param, SingI store)+  => Contract param store -> U.Contract convertContract contract =-  Un.Contract+  U.Contract     { para = toUType $ fromSingT (sing @param)     , stor = toUType $ fromSingT (sing @store)     , code = instrToOps contract     } --- | Function @unsafeValToValue@ converts typed @Val@ to untyped @Value@--- from @Michelson.Untyped.Value@ module+-- | Convert a typed 'Val' to an untyped 'Value'. ----- VOp cannot be represented in @Value@ from untyped types, so calling this function--- on it will cause an error-unsafeValToValue :: (ConversibleExt, HasCallStack) => Val Instr t -> Un.UntypedValue-unsafeValToValue = fromMaybe (error err) . valToOpOrValue-  where-    err =-      "unexpected unsafeValToValue call trying to convert VOp to untyped Value"+-- For full isomorphism type of the given 'Val' should not contain+-- 'TOperation' - a compile error will be raised otherwise.+-- You can analyse its presence with 'checkOpPresence' function.+untypeValue ::+     forall t . (SingI t, HasNoOp t)+  => Value' Instr t+  -> U.Value+untypeValue val = case (val, sing @t) of+  (VC cVal, _) ->+    untypeCValue cVal+  (VKey b, _) ->+    U.ValueString $ mformatPublicKey b+  (VUnit, _) ->+    U.ValueUnit+  (VSignature b, _) ->+    U.ValueString $ mformatSignature b+  (VOption (Just x), STOption _) ->+    U.ValueSome (untypeValue x)+  (VOption Nothing, STOption _) ->+    U.ValueNone+  (VList l, STList _) ->+    vList U.ValueSeq $ map untypeValue l+  (VSet s, _) ->+    vList U.ValueSeq $ map untypeCValue $ toList s+  (VContract b, _) ->+    U.ValueString $ mformatAddress b --- | Convert a typed 'Val' to an untyped 'Value', or fail if it contains operations--- which are unrepresentable there.-valToOpOrValue ::-     forall t . ConversibleExt-  => Val Instr t-  -> Maybe Un.UntypedValue-valToOpOrValue = \case-  VC cVal -> Just $ cValToValue cVal-  VKey b -> Just $ Un.ValueString $ formatPublicKey b-  VUnit -> Just $ Un.ValueUnit-  VSignature b -> Just $ Un.ValueString $ formatSignature b-  VOption (Just x) -> Un.ValueSome <$> valToOpOrValue x-  VOption Nothing -> Just $ Un.ValueNone-  VList l -> valueList Un.ValueSeq <$> mapM valToOpOrValue l-  VSet s -> Just $ valueList Un.ValueSeq $ map cValToValue $ toList s-  VOp _op -> Nothing-  VContract b -> Just $ Un.ValueString $ formatAddress b-  VPair (l, r) -> Un.ValuePair <$> valToOpOrValue l <*> valToOpOrValue r-  VOr (Left x) -> Un.ValueLeft <$> valToOpOrValue x-  VOr (Right x) -> Un.ValueRight <$> valToOpOrValue x-  VLam ops ->-    Just $ maybe Un.ValueNil Un.ValueLambda $-    nonEmpty (instrToOps ops)-  VMap m ->-    fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) ->-      Un.Elt (cValToValue k) <$> valToOpOrValue v-  VBigMap m ->-    fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) ->-      Un.Elt (cValToValue k) <$> valToOpOrValue v-  where-    valueList ctor = maybe Un.ValueNil ctor . nonEmpty+  (VPair (l, r), STPair lt _) ->+    case checkOpPresence lt of+      OpAbsent -> U.ValuePair (untypeValue l) (untypeValue r) -cValToValue :: CVal t -> Un.UntypedValue-cValToValue cVal = case cVal of-  CvInt i -> Un.ValueInt i-  CvNat i -> Un.ValueInt $ toInteger i-  CvString s -> Un.ValueString s-  CvBytes b -> Un.ValueBytes $ Un.InternalByteString b-  CvMutez m -> Un.ValueInt $ toInteger $ unMutez m-  CvBool True -> Un.ValueTrue-  CvBool False -> Un.ValueFalse-  CvKeyHash h -> Un.ValueString $ formatKeyHash h-  CvTimestamp t -> Un.ValueString $ show t-  CvAddress a -> Un.ValueString $ formatAddress a+  (VOr (Left x), STOr lt _) ->+    case checkOpPresence lt of+      OpAbsent -> U.ValueLeft (untypeValue x) -instrToOps :: ConversibleExt => Instr inp out -> [Un.ExpandedOp]+  (VOr (Right x), STOr lt _) ->+    case checkOpPresence lt of+      OpAbsent -> U.ValueRight (untypeValue x)++  (VLam (ops :: Instr '[inp] '[out]), _) ->+    vList U.ValueLambda $ instrToOps ops++  (VMap m, STMap _ vt) ->+    case checkOpPresence vt of+      OpAbsent ->+        vList U.ValueMap $ Map.toList m <&> \(k, v) ->+        U.Elt (untypeCValue k) (untypeValue v)++  (VBigMap m, STBigMap _ vt) ->+    case checkOpPresence vt of+      OpAbsent ->+        vList U.ValueMap $ Map.toList m <&> \(k, v) ->+        U.Elt (untypeCValue k) (untypeValue v)+  where+    vList ctor = maybe U.ValueNil ctor . nonEmpty+untypeCValue :: CValue t -> U.Value+untypeCValue cVal = case cVal of+  CvInt i -> U.ValueInt i+  CvNat i -> U.ValueInt $ toInteger i+  CvString s -> U.ValueString s+  CvBytes b -> U.ValueBytes $ U.InternalByteString b+  CvMutez m -> U.ValueInt $ toInteger $ unMutez m+  CvBool True -> U.ValueTrue+  CvBool False -> U.ValueFalse+  CvKeyHash h -> U.ValueString $ mformatKeyHash h+  CvTimestamp t -> U.ValueString $ mkMTextUnsafe $ pretty t+  CvAddress a -> U.ValueString $ mformatAddress a++instrToOps :: Instr inp out -> [U.ExpandedOp] instrToOps instr = case instr of-  Nested sq -> one $ Un.SeqEx $ instrToOps sq-  i -> Un.PrimEx <$> handleInstr i+  Seq i1 i2 -> instrToOps i1 <> instrToOps i2+  Nested sq -> one $ U.SeqEx $ instrToOps sq+  i -> U.PrimEx <$> handleInstr i+  -- TODO pva701: perphaps, typed instr has to hold a position too+  -- to make it possible to report a precise location of a runtime error   where-    handleInstr :: Instr inp out -> [Un.ExpandedInstr]-    handleInstr (Seq i1 i2) = handleInstr i1 <> handleInstr i2+    handleInstr :: Instr inp out -> [U.ExpandedInstr]+    handleInstr (Seq _ _) = error "impossible"     handleInstr Nop = []-    handleInstr (Ext nop) = [Un.EXT $ convert nop]+    handleInstr (Ext (nop :: ExtInstr inp)) = [U.EXT $ extInstrToOps nop]     handleInstr (Nested _) = error "impossible"-    handleInstr DROP = [Un.DROP]-    handleInstr DUP = [Un.DUP Un.noAnn]-    handleInstr SWAP = [Un.SWAP]-    handleInstr i@(PUSH val) = handle i-      where-        handle :: Instr inp1 (t ': s) -> [Un.ExpandedInstr]-        handle (PUSH _ :: Instr inp1 (t ': s)) =-          let value = unsafeValToValue val-              --- ^ safe because PUSH cannot have operation as argument-          in [Un.PUSH Un.noAnn (toUType $ fromSingT (sing @t)) value]-        handle _ = error "unexcepted call"-    handleInstr i@NONE = handle i-      where-        handle :: Instr inp1 ('TOption a ': inp1) -> [Un.ExpandedInstr]-        handle (NONE :: Instr inp1 ('TOption a ': inp1)) =-          [Un.NONE Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))]-        handle _ = error "unexcepted call"-    handleInstr SOME = [Un.SOME Un.noAnn Un.noAnn Un.noAnn]-    handleInstr UNIT = [Un.UNIT Un.noAnn Un.noAnn]-    handleInstr (IF_NONE i1 i2) = [Un.IF_NONE (instrToOps i1) (instrToOps i2)]-    handleInstr PAIR = [Un.PAIR Un.noAnn Un.noAnn Un.noAnn Un.noAnn]-    handleInstr CAR = [Un.CAR Un.noAnn Un.noAnn]-    handleInstr CDR = [Un.CDR Un.noAnn Un.noAnn]-    handleInstr i@LEFT = handle i-      where-        handle :: Instr (a ': s) ('TOr a b ': s) -> [Un.ExpandedInstr]-        handle (LEFT :: Instr (a ': s) ('TOr a b ': s)) =-          [Un.LEFT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @b))]-        handle _ = error "unexcepted call"-    handleInstr i@(RIGHT) = handle i-      where-        handle :: Instr (b ': s) ('TOr a b ': s) -> [Un.ExpandedInstr]-        handle (RIGHT :: Instr (b ': s) ('TOr a b ': s)) =-          [Un.RIGHT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))]-        handle _ = error "unexcepted call"-    handleInstr (IF_LEFT i1 i2) = [Un.IF_LEFT (instrToOps i1) (instrToOps i2)]-    handleInstr (IF_RIGHT i1 i2) = [Un.IF_RIGHT (instrToOps i1) (instrToOps i2)]-    handleInstr i@(NIL) = handle i-      where-        handle :: Instr s ('TList p ': s) -> [Un.ExpandedInstr]-        handle (NIL :: Instr s ('TList p ': s)) =-          [Un.NIL Un.noAnn Un.noAnn (toUType $ fromSingT (sing @p))]-        handle _ = error "unexcepted call"-    handleInstr CONS = [Un.CONS Un.noAnn]-    handleInstr (IF_CONS i1 i2) = [Un.IF_CONS (instrToOps i1) (instrToOps i2)]-    handleInstr SIZE = [Un.SIZE Un.noAnn]-    handleInstr i@EMPTY_SET = handle i-      where-        handle :: Instr s ('TSet e ': s) -> [Un.ExpandedInstr]-        handle (EMPTY_SET :: Instr s ('TSet e ': s)) =-          [Un.EMPTY_SET Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @e)) Un.noAnn)]-        handle _ = error "unexcepted call"-    handleInstr i@EMPTY_MAP = handle i-      where-        handle :: Instr s ('TMap a b ': s) -> [Un.ExpandedInstr]-        handle (EMPTY_MAP :: Instr s ('TMap a b ': s)) =-          [Un.EMPTY_MAP Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @a)) Un.noAnn)-           (toUType $ fromSingT (sing @b))-          ]-        handle _ = error "unexcepted call"-    handleInstr (MAP op) = [Un.MAP Un.noAnn $ instrToOps op]-    handleInstr (ITER op) = [Un.ITER $ instrToOps op]-    handleInstr MEM = [Un.MEM Un.noAnn]-    handleInstr GET = [Un.GET Un.noAnn]-    handleInstr UPDATE = [Un.UPDATE]-    handleInstr (IF op1 op2) = [Un.IF (instrToOps op1) (instrToOps op2)]-    handleInstr (LOOP op) = [Un.LOOP (instrToOps op)]-    handleInstr (LOOP_LEFT op) = [Un.LOOP_LEFT (instrToOps op)]-    handleInstr i@(LAMBDA l) = handle i-      where-        handle :: Instr s ('TLambda i o ': s) -> [Un.ExpandedInstr]-        handle (LAMBDA _ :: Instr s ('TLambda i o ': s)) =-          [Un.LAMBDA Un.noAnn (toUType $ fromSingT (sing @i))-            (toUType $ fromSingT (sing @i)) (convertLambdaBody l)-          ]-        handle _ = error "unexcepted call"-        convertLambdaBody :: Val Instr ('TLambda i o) -> [Un.ExpandedOp]-        convertLambdaBody (VLam ops) = instrToOps ops-    handleInstr EXEC = [Un.EXEC Un.noAnn]-    handleInstr (DIP op) = [Un.DIP (instrToOps op)]-    handleInstr FAILWITH = [Un.FAILWITH]-    handleInstr i@(CAST) = handle i-      where-        handle :: Instr (a ': s) (a ': s) -> [Un.ExpandedInstr]-        handle (CAST :: Instr (a ': s) (a ': s)) =-          [Un.CAST Un.noAnn (toUType $ fromSingT (sing @a))]-        handle _ = error "unexcepted call"-    handleInstr RENAME = [Un.RENAME Un.noAnn]-    handleInstr PACK = [Un.PACK Un.noAnn]-    handleInstr i@(UNPACK) = handle i-      where-        handle :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) -> [Un.ExpandedInstr]-        handle (UNPACK :: Instr ('Tc 'CBytes ': s) ('TOption a ': s)) =-          [Un.UNPACK Un.noAnn (toUType $ fromSingT (sing @a))]-        handle _ = error "unexcepted call"-    handleInstr CONCAT = [Un.CONCAT Un.noAnn]-    handleInstr CONCAT' = [Un.CONCAT Un.noAnn]-    handleInstr SLICE = [Un.SLICE Un.noAnn]-    handleInstr ISNAT = [Un.ISNAT Un.noAnn]-    handleInstr ADD = [Un.ADD Un.noAnn]-    handleInstr SUB = [Un.SUB Un.noAnn]-    handleInstr MUL = [Un.MUL Un.noAnn]-    handleInstr EDIV = [Un.EDIV Un.noAnn]-    handleInstr ABS = [Un.ABS Un.noAnn]-    handleInstr NEG = [Un.NEG]-    handleInstr LSL = [Un.LSL Un.noAnn]-    handleInstr LSR = [Un.LSR Un.noAnn]-    handleInstr OR = [Un.OR Un.noAnn]-    handleInstr AND = [Un.AND Un.noAnn]-    handleInstr XOR = [Un.XOR Un.noAnn]-    handleInstr NOT = [Un.NOT Un.noAnn]-    handleInstr COMPARE = [Un.COMPARE Un.noAnn]-    handleInstr Instr.EQ = [Un.EQ Un.noAnn]-    handleInstr NEQ = [Un.NEQ Un.noAnn]-    handleInstr Instr.LT = [Un.LT Un.noAnn]-    handleInstr Instr.GT = [Un.GT Un.noAnn]-    handleInstr LE = [Un.LE Un.noAnn]-    handleInstr GE = [Un.GE Un.noAnn]-    handleInstr INT = [Un.INT Un.noAnn]-    handleInstr SELF = [Un.SELF Un.noAnn]-    handleInstr i@CONTRACT = handle i-      where-        handle :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)-               -> [Un.ExpandedInstr]-        handle (CONTRACT :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)) =-          [Un.CONTRACT Un.noAnn (toUType $ fromSingT (sing @p))]-        handle _ = error "unexcepted call"-    handleInstr TRANSFER_TOKENS = [Un.TRANSFER_TOKENS Un.noAnn]-    handleInstr SET_DELEGATE = [Un.SET_DELEGATE Un.noAnn]-    handleInstr CREATE_ACCOUNT = [Un.CREATE_ACCOUNT Un.noAnn Un.noAnn]-    handleInstr CREATE_CONTRACT = [Un.CREATE_CONTRACT Un.noAnn Un.noAnn]-    handleInstr i@(CREATE_CONTRACT2 _) = handle i-      where-        handle :: Instr ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash)-                    ': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s)-                   ('TOperation ': 'Tc 'CAddress ': s) -> [Un.ExpandedInstr]-        handle (CREATE_CONTRACT2 ops :: Instr ('Tc 'CKeyHash-                    ': 'TOption ('Tc 'CKeyHash)-                    ': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s)-                   ('TOperation ': 'Tc 'CAddress ': s)) =-          case ops of-            (code :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ]) ->-              let contract = Un.Contract (toUType $ fromSingT (sing @p))-                    (toUType $ fromSingT (sing @g)) (instrToOps code) in-              [Un.CREATE_CONTRACT2 Un.noAnn Un.noAnn contract]-        handle _ = error "unexcepted call"-    handleInstr IMPLICIT_ACCOUNT = [Un.IMPLICIT_ACCOUNT Un.noAnn]-    handleInstr NOW = [Un.NOW Un.noAnn]-    handleInstr AMOUNT = [Un.AMOUNT Un.noAnn]-    handleInstr BALANCE = [Un.BALANCE Un.noAnn]-    handleInstr CHECK_SIGNATURE = [Un.CHECK_SIGNATURE Un.noAnn]-    handleInstr SHA256 = [Un.SHA256 Un.noAnn]-    handleInstr SHA512 = [Un.SHA512 Un.noAnn]-    handleInstr BLAKE2B = [Un.BLAKE2B Un.noAnn]-    handleInstr HASH_KEY = [Un.HASH_KEY Un.noAnn]-    handleInstr STEPS_TO_QUOTA = [Un.STEPS_TO_QUOTA Un.noAnn]-    handleInstr SOURCE = [Un.SOURCE Un.noAnn]-    handleInstr SENDER = [Un.SENDER Un.noAnn]-    handleInstr ADDRESS = [Un.ADDRESS Un.noAnn]+    handleInstr DROP = [U.DROP]+    handleInstr DUP = [U.DUP U.noAnn]+    handleInstr SWAP = [U.SWAP]+    handleInstr i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i =+      let value = untypeValue val+      in [U.PUSH U.noAnn (toUType $ fromSingT (sing @t)) value]+    handleInstr i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i =+      [U.NONE U.noAnn U.noAnn U.noAnn (toUType $ fromSingT (sing @a))]+    handleInstr SOME = [U.SOME U.noAnn U.noAnn U.noAnn]+    handleInstr UNIT = [U.UNIT U.noAnn U.noAnn]+    handleInstr (IF_NONE i1 i2) = [U.IF_NONE (instrToOps i1) (instrToOps i2)]+    handleInstr PAIR = [U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn]+    handleInstr CAR = [U.CAR U.noAnn U.noAnn]+    handleInstr CDR = [U.CDR U.noAnn U.noAnn]+    handleInstr i@LEFT | _ :: Instr (a ': s) ('TOr a b ': s) <- i =+      [U.LEFT U.noAnn U.noAnn U.noAnn U.noAnn (toUType $ fromSingT (sing @b))]+    handleInstr i@RIGHT | _ :: Instr (b ': s) ('TOr a b ': s) <- i =+      [U.RIGHT U.noAnn U.noAnn U.noAnn U.noAnn (toUType $ fromSingT (sing @a))]+    handleInstr (IF_LEFT i1 i2) = [U.IF_LEFT (instrToOps i1) (instrToOps i2)]+    handleInstr i@NIL | _ :: Instr s ('TList p ': s) <- i =+      [U.NIL U.noAnn U.noAnn (toUType $ fromSingT (sing @p))]+    handleInstr CONS = [U.CONS U.noAnn]+    handleInstr (IF_CONS i1 i2) = [U.IF_CONS (instrToOps i1) (instrToOps i2)]+    handleInstr SIZE = [U.SIZE U.noAnn]+    handleInstr i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i =+      [U.EMPTY_SET U.noAnn U.noAnn (U.Comparable (fromSingCT (sing @e)) U.noAnn)]+    handleInstr i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i =+      [U.EMPTY_MAP U.noAnn U.noAnn (U.Comparable (fromSingCT (sing @a)) U.noAnn)+       (toUType $ fromSingT (sing @b))+      ]+    handleInstr (MAP op) = [U.MAP U.noAnn $ instrToOps op]+    handleInstr (ITER op) = [U.ITER $ instrToOps op]+    handleInstr MEM = [U.MEM U.noAnn]+    handleInstr GET = [U.GET U.noAnn]+    handleInstr UPDATE = [U.UPDATE]+    handleInstr (IF op1 op2) = [U.IF (instrToOps op1) (instrToOps op2)]+    handleInstr (LOOP op) = [U.LOOP (instrToOps op)]+    handleInstr (LOOP_LEFT op) = [U.LOOP_LEFT (instrToOps op)]+    handleInstr i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i =+      [U.LAMBDA U.noAnn (toUType $ fromSingT (sing @i))+       (toUType $ fromSingT (sing @i)) (instrToOps l)+      ]+    handleInstr EXEC = [U.EXEC U.noAnn]+    handleInstr (DIP op) = [U.DIP (instrToOps op)]+    handleInstr FAILWITH = [U.FAILWITH]+    handleInstr i@CAST | _ :: Instr (a ': s) (a ': s) <- i =+      [U.CAST U.noAnn (toUType $ fromSingT (sing @a))]+    handleInstr RENAME = [U.RENAME U.noAnn]+    handleInstr PACK = [U.PACK U.noAnn]+    handleInstr i@UNPACK+      | _ :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) <- i =+          [U.UNPACK U.noAnn (toUType $ fromSingT (sing @a))]+    handleInstr CONCAT = [U.CONCAT U.noAnn]+    handleInstr CONCAT' = [U.CONCAT U.noAnn]+    handleInstr SLICE = [U.SLICE U.noAnn]+    handleInstr ISNAT = [U.ISNAT U.noAnn]+    handleInstr ADD = [U.ADD U.noAnn]+    handleInstr SUB = [U.SUB U.noAnn]+    handleInstr MUL = [U.MUL U.noAnn]+    handleInstr EDIV = [U.EDIV U.noAnn]+    handleInstr ABS = [U.ABS U.noAnn]+    handleInstr NEG = [U.NEG]+    handleInstr LSL = [U.LSL U.noAnn]+    handleInstr LSR = [U.LSR U.noAnn]+    handleInstr OR = [U.OR U.noAnn]+    handleInstr AND = [U.AND U.noAnn]+    handleInstr XOR = [U.XOR U.noAnn]+    handleInstr NOT = [U.NOT U.noAnn]+    handleInstr COMPARE = [U.COMPARE U.noAnn]+    handleInstr Instr.EQ = [U.EQ U.noAnn]+    handleInstr NEQ = [U.NEQ U.noAnn]+    handleInstr Instr.LT = [U.LT U.noAnn]+    handleInstr Instr.GT = [U.GT U.noAnn]+    handleInstr LE = [U.LE U.noAnn]+    handleInstr GE = [U.GE U.noAnn]+    handleInstr INT = [U.INT U.noAnn]+    handleInstr SELF = [U.SELF U.noAnn]+    handleInstr i@(CONTRACT nt)+      | _ :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s) <- i =+          [U.CONTRACT (U.noAnn) (mkUType (sing @p) nt)]+    handleInstr TRANSFER_TOKENS = [U.TRANSFER_TOKENS U.noAnn]+    handleInstr SET_DELEGATE = [U.SET_DELEGATE U.noAnn]+    handleInstr CREATE_ACCOUNT = [U.CREATE_ACCOUNT U.noAnn U.noAnn]+    handleInstr i@(CREATE_CONTRACT ops)+      | _ :: Instr+          (  'Tc 'CKeyHash+          ': 'TOption ('Tc 'CKeyHash)+          ': 'Tc 'CBool+          ': 'Tc 'CBool+          ': 'Tc 'CMutez+          ': g+          ': s)+          ('TOperation ': 'Tc 'CAddress ': s) <- i+      , code :: Instr '[ 'TPair p g] '[ 'TPair ('TList 'TOperation) g] <- ops =+        let contract = U.Contract (toUType $ fromSingT (sing @p))+              (toUType $ fromSingT (sing @g)) (instrToOps code)+        in [U.CREATE_CONTRACT U.noAnn U.noAnn contract]+    handleInstr IMPLICIT_ACCOUNT = [U.IMPLICIT_ACCOUNT U.noAnn]+    handleInstr NOW = [U.NOW U.noAnn]+    handleInstr AMOUNT = [U.AMOUNT U.noAnn]+    handleInstr BALANCE = [U.BALANCE U.noAnn]+    handleInstr CHECK_SIGNATURE = [U.CHECK_SIGNATURE U.noAnn]+    handleInstr SHA256 = [U.SHA256 U.noAnn]+    handleInstr SHA512 = [U.SHA512 U.noAnn]+    handleInstr BLAKE2B = [U.BLAKE2B U.noAnn]+    handleInstr HASH_KEY = [U.HASH_KEY U.noAnn]+    handleInstr STEPS_TO_QUOTA = [U.STEPS_TO_QUOTA U.noAnn]+    handleInstr SOURCE = [U.SOURCE U.noAnn]+    handleInstr SENDER = [U.SENDER U.noAnn]+    handleInstr ADDRESS = [U.ADDRESS U.noAnn] +untypeStackRef :: StackRef s -> U.StackRef+untypeStackRef (StackRef n) = U.StackRef (peanoVal n)++untypePrintComment :: PrintComment s -> U.PrintComment+untypePrintComment (PrintComment pc) = U.PrintComment $ map (second untypeStackRef) pc++extInstrToOps :: ExtInstr s -> U.ExtInstrAbstract U.ExpandedOp+extInstrToOps = \case+  PRINT pc -> U.UPRINT (untypePrintComment pc)+  TEST_ASSERT (TestAssert nm pc i) ->+    U.UTEST_ASSERT $ U.TestAssert nm (untypePrintComment pc) (instrToOps i)+ -- It's an orphan instance, but it's better than checking all cases manually. -- We can also move this convertion to the place where `Instr` is defined, -- but then there will be a very large module (as we'll have to move a lot of -- stuff as well).-instance (ConversibleExt, Eq Un.ExpandedInstrExtU) => Eq (Instr inp out) where+instance Eq (Instr inp out) where   i1 == i2 = instrToOps i1 == instrToOps i2++instance Typeable s => Eq (TestAssert s) where+  TestAssert   name1 pattern1 instr1+    ==+    TestAssert name2 pattern2 instr2+    = and+    [ name1 == name2+    , pattern1 `eqParam1` pattern2+    , instr1 `eqParam2` instr2+    ]++deriving instance Typeable s => Eq (ExtInstr s)
src/Michelson/Typed/Extract.hs view
@@ -8,19 +8,22 @@ -- I.e. @Michelson.Types.Type@ is split to value @t :: T@ and value of type -- @Notes t@ for which @t@ is a type representation of value @t@. module Michelson.Typed.Extract-  ( extractNotes+  ( TypeConvergeError(..)+  , extractNotes   , fromUType   , mkUType   , toUType   ) where +import Fmt (Buildable(..), (+|), (|+))+ import Michelson.Typed.Annotation (Notes(..), Notes'(..), mkNotes) import Michelson.Typed.Sing (Sing(..), fromSingCT, fromSingT) import Michelson.Typed.T (T(..)) import qualified Michelson.Untyped as Un  -- | Extracts 'T' type from 'Michelson.Untyped.Type'.-fromUType :: Un.Type -> T+fromUType :: HasCallStack => Un.Type -> T fromUType (Un.Type wholeT _) = conv wholeT   where     conv (Un.Tc ct) = Tc ct@@ -37,7 +40,10 @@     conv (Un.TLambda lT rT) = TLambda (fromUType lT) (fromUType rT)     conv (Un.TMap (Un.Comparable key _) val) = TMap key (fromUType val)     conv (Un.TBigMap (Un.Comparable key _) val) = TBigMap key (fromUType val)-+fromUType Un.TypeParameter+  = error "Parameter implicit type cannot be represented in Typed.T"+fromUType Un.TypeStorage+  = error "Parameter implicit type cannot be represented in Typed.T"  mkUType :: Sing x -> Notes x -> Un.Type mkUType sing notes = case (sing, notes) of@@ -85,12 +91,29 @@   mt = Un.Type   na = Un.noAnn +data TypeConvergeError+  = TypeConvergeError Un.T T+  | TParameterConvergeError+  | TStorageConvergeError+  deriving (Show, Eq)++instance Buildable TypeConvergeError where+  build (TypeConvergeError type1 type2) =+    "Failed to construct annotation, provided types do not match: "+    +| type1 |+ " /= " +| show type2+  build (TParameterConvergeError) =+    "Cannot converge TypeParameter"+  build (TStorageConvergeError) =+    "Cannot converge TypeStorage"+ -- | Extracts @Notes t@ type from 'Michelson.Type.Type' and corresponding -- singleton.-extractNotes :: Un.Type -> Sing t -> Either Text (Notes t)+extractNotes :: Un.Type -> Sing t -> Either TypeConvergeError (Notes t)+extractNotes Un.TypeParameter _ = Left TParameterConvergeError+extractNotes Un.TypeStorage _ = Left TStorageConvergeError extractNotes (Un.Type wholeT tn) s = conv wholeT s   where-    conv :: Un.T -> Sing t -> Either Text (Notes t)+    conv :: Un.T -> Sing t -> Either TypeConvergeError (Notes t)     conv (Un.Tc ct) (STc cst)       | fromSingCT cst == ct = pure $ mkNotes $ NTc tn     conv Un.TKey STKey = pure $ mkNotes $ NTKey tn@@ -123,8 +146,7 @@       | fromSingCT kst == kt =         mkNotes . NTBigMap tn kn  <$> extractNotes vt svt     conv a (fromSingT -> b) =-      Left $ "failed to construct annotation, provided types do not match: "-                <> show a <> " /= " <> show b+      Left $ TypeConvergeError a b  -- | Converts from 'T' to 'Michelson.Type.Type'. toUType :: T -> Un.Type
+ src/Michelson/Typed/Haskell.hs view
@@ -0,0 +1,7 @@+-- | Haskell-Michelson conversions.+module Michelson.Typed.Haskell+  ( module Exports+  ) where++import Michelson.Typed.Haskell.Instr as Exports+import Michelson.Typed.Haskell.Value as Exports hiding (GIsoValue(..))
+ src/Michelson/Typed/Haskell/Instr.hs view
@@ -0,0 +1,6 @@+module Michelson.Typed.Haskell.Instr+  ( module Exports+  ) where++import Michelson.Typed.Haskell.Instr.Product as Exports+import Michelson.Typed.Haskell.Instr.Sum as Exports
+ src/Michelson/Typed/Haskell/Instr/Helpers.hs view
@@ -0,0 +1,34 @@+module Michelson.Typed.Haskell.Instr.Helpers+  ( Branch (..)+  , Path+  , RSplit (..)+  ) where++import Data.Vinyl.Core (Rec(..))+import Data.Vinyl.TypeLevel (type (++))++-- | Which branch to choose in generic tree representation: left,+-- straight or right. 'S' is used when there is one constructor with+-- one field (something newtype-like).+--+-- The reason why we need 'S' can be explained by this example:+-- data A = A1 B | A2 Integer+-- data B = B Bool+-- Now we may search for A1 constructor or B constructor. Without 'S' in+-- both cases path will be the same ([L]).+data Branch = L | S | R++-- | Path to a leaf (some field or constructor) in generic tree representation.+type Path = [Branch]++-- | Split a record into two pieces.+class RSplit (l :: [k]) (r :: [k]) where+  rsplit :: forall f. Rec f (l ++ r) -> (Rec f l, Rec f r)++instance RSplit '[] r where+  rsplit = (RNil, )++instance RSplit ls r => RSplit (l ': ls) r where+  rsplit (x :& r) =+    let (x1, r1) = rsplit r+    in (x :& x1, r1)
+ src/Michelson/Typed/Haskell/Instr/Product.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Instructions working on product types derived from Haskell ones.+module Michelson.Typed.Haskell.Instr.Product+  ( InstrGetFieldC+  , InstrSetFieldC+  , InstrConstructC+  , instrGetField+  , instrSetField+  , instrConstruct++  , GetFieldType+  , ConstructorFieldTypes+  , FieldConstructor (..)+  ) where++import qualified Data.Kind as Kind+import Data.Type.Bool (If)+import Data.Type.Equality (type (==))+import Data.Vinyl.Core (Rec(..))+import Data.Vinyl.Derived (Label)+import Data.Vinyl.TypeLevel (type (++))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)+import Named ((:!), (:?), NamedF(..))++import Michelson.Typed.Haskell.Instr.Helpers+import Michelson.Typed.Haskell.Value+import Michelson.Typed.Instr+import Michelson.Text+import Util.Named (NamedInner)++-- Fields lookup (helper)+----------------------------------------------------------------------------++-- | Result of field lookup - its type and path to it in+-- the tree.+data LookupNamedResult = LNR Kind.Type Path++type family LnrFieldType (lnr :: LookupNamedResult) where+  LnrFieldType ('LNR f _) = f+type family LnrBranch (lnr :: LookupNamedResult) :: Path where+  LnrBranch ('LNR _ p) = p++-- | Find field of some product type by its name.+--+-- Name might be either field record name, or one in 'NamedF' if+-- field is wrapped using '(:!)' or '(:?)'.+type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))++-- | Force result of 'GLookupNamed' to be 'Just'+type family LNRequireFound+  (name :: Symbol)+  (a :: Kind.Type)+  (mf :: Maybe LookupNamedResult)+    :: LookupNamedResult where+  LNRequireFound _ _ ('Just lnr) = lnr+  LNRequireFound name a 'Nothing = TypeError+    ('Text "Datatype " ':<>: 'ShowType a ':<>:+     'Text " has no field " ':<>: 'ShowType name)++type family GLookupNamed (name :: Symbol) (x :: Kind.Type -> Kind.Type)+          :: Maybe LookupNamedResult where+  GLookupNamed name (G.D1 _ x) = GLookupNamed name x+  GLookupNamed name (G.C1 _ x) = GLookupNamed name x++  GLookupNamed name (G.S1 ('G.MetaSel ('Just recName) _ _ _) (G.Rec0 a)) =+    If (name == recName)+      ('Just $ 'LNR a '[])+      'Nothing+  GLookupNamed name (G.S1 _ (G.Rec0 (NamedF f a fieldName))) =+    If (name == fieldName)+      ('Just $ 'LNR (NamedInner (NamedF f a fieldName)) '[])+      'Nothing+  GLookupNamed _ (G.S1 _ _) = 'Nothing++  GLookupNamed name (x :*: y) =+    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)+  GLookupNamed name (_ :+: _) = TypeError+    ('Text "Cannot seek for a field " ':<>: 'ShowType name ':<>:+     'Text " in sum type")+  GLookupNamed _ G.U1 = 'Nothing+  GLookupNamed _ G.V1 = TypeError+    ('Text "Cannot access fields of void-like type")++type family LNMergeFound+  (name :: Symbol)+  (f1 :: Maybe LookupNamedResult)+  (f2 :: Maybe LookupNamedResult)+    :: Maybe LookupNamedResult where+  LNMergeFound _ 'Nothing 'Nothing = 'Nothing+  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)+  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)+  LNMergeFound name ('Just _) ('Just _) = TypeError+    ('Text "Ambigous reference to datatype field: " ':<>: 'ShowType name)++-- | Get type of field by datatype it is contained in and field name.+type GetFieldType dt name = LnrFieldType (GetNamed name dt)++----------------------------------------------------------------------------+-- Value accessing instruction+----------------------------------------------------------------------------++-- | Make an instruction which accesses given field of the given datatype.+instrGetField+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> Instr (ToT dt ': st) (ToT (GetFieldType dt name) ': st)+instrGetField _ =+  gInstrGetField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))+    @(GetFieldType dt name)++-- | Constraint for 'instrGetField'.+type InstrGetFieldC dt name =+  ( IsoValue dt, Generic dt+  , GInstrGet name (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (LnrFieldType (GetNamed name dt))+  , GValueType (G.Rep dt) ~ ToT dt+  )++{- Note about bulkiness of `instrGetField` type signature:++Read this only if you are going to modify the signature qualitatively.++It may seem that you can replace 'LnrBranch' and 'LnrFieldType' getters since+their result is already assigned to a type variable, but if you do so,+on attempt to access non-existing field GHC will prompt you a couple of huge+"cannot deduce type" errors along with desired "field is not present".+To make error messages clearer we prevent GHC from deducing 'GInstrAccess' when+no field is found via using those getters.+-}++-- | Generic traversal for 'instrAccess'.+class GIsoValue x =>+  GInstrGet+    (name :: Symbol)+    (x :: Kind.Type -> Kind.Type)+    (path :: Path)+    (fieldTy :: Kind.Type) where+  gInstrGetField+    :: GIsoValue x+    => Instr (GValueType x ': s) (ToT fieldTy ': s)++instance GInstrGet name x path f => GInstrGet name (G.M1 t i x) path f where+  gInstrGetField = gInstrGetField @name @x @path @f++instance (IsoValue f, ToT f ~ ToT f') =>+         GInstrGet name (G.Rec0 f) '[] f' where+  gInstrGetField = Nop++instance (GInstrGet name x path f, GIsoValue y) => GInstrGet name (x :*: y) ('L ': path) f where+  gInstrGetField = CAR `Seq` gInstrGetField @name @x @path @f++instance (GInstrGet name y path f, GIsoValue x) => GInstrGet name (x :*: y) ('R ': path) f where+  gInstrGetField = CDR `Seq` gInstrGetField @name @y @path @f++-- Examples+----------------------------------------------------------------------------++type MyType1 = ("int" :! Integer, "bytes" :! ByteString, "bytes2" :? ByteString)++_getIntInstr1 :: Instr (ToT MyType1 ': s) (ToT Integer ': s)+_getIntInstr1 = instrGetField @MyType1 #int++_getTextInstr1 :: Instr (ToT MyType1 ': s) (ToT (Maybe ByteString) ': s)+_getTextInstr1 = instrGetField @MyType1 #bytes2++data MyType2 = MyType2+  { getInt :: Integer+  , getText :: MText+  , getUnit :: ()+  , getMyType1 :: MyType1+  } deriving stock (Generic)+    deriving anyclass (IsoValue)++_getIntInstr2 :: Instr (ToT MyType2 ': s) (ToT () ': s)+_getIntInstr2 = instrGetField @MyType2 #getUnit++_getIntInstr2' :: Instr (ToT MyType2 ': s) (ToT Integer ': s)+_getIntInstr2' =+  instrGetField @MyType2 #getMyType1 `Seq` instrGetField @MyType1 #int++----------------------------------------------------------------------------+-- Value modification instruction+----------------------------------------------------------------------------++-- | For given complex type @dt@ and its field @fieldTy@ update the field value.+instrSetField+  :: forall dt name st.+     InstrSetFieldC dt name+  => Label name -> Instr (ToT (GetFieldType dt name) ': ToT dt ': st) (ToT dt ': st)+instrSetField _ =+  gInstrSetField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))+    @(GetFieldType dt name)++-- | Constraint for 'instrSetField'.+type InstrSetFieldC dt name =+  ( IsoValue dt, Generic dt+  , GInstrSetField name (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (LnrFieldType (GetNamed name dt))+  , GValueType (G.Rep dt) ~ ToT dt+  )++-- | Generic traversal for 'instrSetField'.+class GIsoValue x =>+  GInstrSetField+    (name :: Symbol)+    (x :: Kind.Type -> Kind.Type)+    (path :: Path)+    (fieldTy :: Kind.Type) where+  gInstrSetField+    :: Instr (ToT fieldTy ': GValueType x ': s) (GValueType x ': s)++instance GInstrSetField name x path f => GInstrSetField name (G.M1 t i x) path f where+  gInstrSetField = gInstrSetField @name @x @path @f++instance (IsoValue f, ToT f ~ ToT f') =>+         GInstrSetField name (G.Rec0 f) '[] f' where+  gInstrSetField = DIP DROP++instance (GInstrSetField name x path f, GIsoValue y) => GInstrSetField name (x :*: y) ('L ': path) f where+  gInstrSetField =+    DIP (DUP `Seq` DIP CDR `Seq` CAR) `Seq`+    gInstrSetField @name @x @path @f `Seq`+    PAIR++instance (GInstrSetField name y path f, GIsoValue x) => GInstrSetField name (x :*: y) ('R ': path) f where+  gInstrSetField =+    DIP (DUP `Seq` DIP CAR `Seq` CDR) `Seq`+    gInstrSetField @name @y @path @f `Seq`+    SWAP `Seq` PAIR++-- Examples+----------------------------------------------------------------------------++_setIntInstr1 :: Instr (ToT Integer ': ToT MyType2 ': s) (ToT MyType2 ': s)+_setIntInstr1 = instrSetField @MyType2 #getInt++----------------------------------------------------------------------------+-- Value construction instruction+----------------------------------------------------------------------------++-- | Way to construct one of the fields in a complex datatype.+newtype FieldConstructor (st :: [k]) (field :: Kind.Type) =+  FieldConstructor (Instr (ToTs' st) (ToT field ': ToTs' st))++-- | For given complex type @dt@ and its field @fieldTy@ update the field value.+instrConstruct+  :: forall dt st. InstrConstructC dt+  => Rec (FieldConstructor st) (ConstructorFieldTypes dt)+  -> Instr st (ToT dt ': st)+instrConstruct = gInstrConstruct @(G.Rep dt)++-- | Types of all fields in a datatype.+type ConstructorFieldTypes dt = GFieldTypes (G.Rep dt)++-- | Constraint for 'instrConstruct'.+type InstrConstructC dt =+  ( IsoValue dt, Generic dt, GInstrConstruct (G.Rep dt)+  , GValueType (G.Rep dt) ~ ToT dt+  )++-- | Generic traversal for 'instrConstruct'.+class GIsoValue x => GInstrConstruct (x :: Kind.Type -> Kind.Type) where+  type GFieldTypes x :: [Kind.Type]+  gInstrConstruct :: Rec (FieldConstructor st) (GFieldTypes x) -> Instr st (GValueType x ': st)++instance GInstrConstruct x => GInstrConstruct (G.M1 t i x) where+  type GFieldTypes (G.M1 t i x) = GFieldTypes x+  gInstrConstruct = gInstrConstruct @x++instance ( GInstrConstruct x, GInstrConstruct y+         , RSplit (GFieldTypes x) (GFieldTypes y)+         ) => GInstrConstruct (x :*: y) where+  type GFieldTypes (x :*: y) = GFieldTypes x ++ GFieldTypes y+  gInstrConstruct fs =+    let (lfs, rfs) = rsplit fs+        linstr = gInstrConstruct @x lfs+        rinstr = gInstrConstruct @y rfs+    in linstr `Seq` DIP rinstr `Seq` PAIR++instance GInstrConstruct G.U1 where+  type GFieldTypes G.U1 = '[]+  gInstrConstruct RNil = UNIT++instance ( TypeError ('Text "Cannot construct sum type")+         , GIsoValue x, GIsoValue y+         ) => GInstrConstruct (x :+: y) where+  type GFieldTypes (x :+: y) = '[]+  gInstrConstruct = error "impossible"++instance IsoValue a => GInstrConstruct (G.Rec0 a) where+  type GFieldTypes (G.Rec0 a) = '[a]+  gInstrConstruct (FieldConstructor i :& RNil) = i++-- Examples+----------------------------------------------------------------------------++_constructInstr1 :: Instr (ToT MyType1 ': s) (ToT MyType2 ': ToT MyType1 ': s)+_constructInstr1 =+  instrConstruct @MyType2 $+    FieldConstructor (PUSH (toVal @Integer 5)) :&+    FieldConstructor (PUSH (toVal @MText [mt||])) :&+    FieldConstructor UNIT :&+    FieldConstructor DUP :&+    RNil
+ src/Michelson/Typed/Haskell/Instr/Sum.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Instructions working on sum types derived from Haskell ones.+module Michelson.Typed.Haskell.Instr.Sum+  ( InstrWrapC+  , InstrCaseC+  , InstrUnwrapC+  , instrWrap+  , hsWrap+  , instrCase+  , (//->)+  , instrUnwrapUnsafe+  , hsUnwrap++  , CaseClauseParam (..)+  , CaseClause (..)+  , CaseClauses++  , CtorField (..)+  , ExtractCtorField+  , AppendCtorField+  , AppendCtorFieldAxiom+  , appendCtorFieldAxiom+  , GetCtorField+  , CtorHasOnlyField+  , CtorOnlyField+  , MyCompoundType+  ) where++import Data.Constraint (Dict(..))+import qualified Data.Kind as Kind+import Data.Singletons (SingI(..))+import Data.Type.Bool (If, type (||))+import Data.Type.Equality (type (==))+import Data.Vinyl.Core (Rec(..))+import Data.Vinyl.Derived (Label)+import Data.Vinyl.TypeLevel (type (++))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, ErrorMessage(..), Symbol, TypeError)+import Named ((:!))+import Type.Reflection ((:~:)(Refl))+import Unsafe.Coerce (unsafeCoerce)++import Michelson.Typed.Haskell.Instr.Helpers+import Michelson.Typed.Haskell.Value+import Michelson.Typed.Instr+import Michelson.Typed.T+import Michelson.Text (mt)+import Michelson.Typed.Value+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)+import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Util.TypeTuple++-- Constructors lookup (helper)+----------------------------------------------------------------------------++-- | We support only two scenarious - constructor with one field and+-- without fields. Nonetheless, it's not that sad since for sum types+-- we can't even assign names to fields if there are many (the style+-- guide prohibits partial records).+data CtorField+  = OneField Kind.Type+  | NoFields++-- | Get /something/ as field of the given constructor.+type family ExtractCtorField (cf :: CtorField) where+  ExtractCtorField ('OneField t) = t+  ExtractCtorField 'NoFields = ()++-- | Push field to stack, if any.+type family AppendCtorField (cf :: CtorField) (l :: [k]) :: [k] where+  AppendCtorField ('OneField t) (l :: [T]) = ToT t ': l+  AppendCtorField ('OneField t) (l :: [Kind.Type]) = t ': l+  AppendCtorField 'NoFields (l :: [T]) = l+  AppendCtorField 'NoFields (l :: [Kind.Type]) = l++-- | To use 'AppendCtorField' not only here for 'T'-based stacks, but also+-- later in Lorentz with 'Kind.Type'-based stacks we need the following property.+type AppendCtorFieldAxiom (cf :: CtorField) (st :: [Kind.Type]) =+  ToTs (AppendCtorField cf st) ~ AppendCtorField cf (ToTs st)++-- | Proof of 'AppendCtorFieldAxiom'.+appendCtorFieldAxiom+  :: ( AppendCtorFieldAxiom ('OneField Word) '[Int]+     , AppendCtorFieldAxiom 'NoFields '[Int]+     )+  => Dict (AppendCtorFieldAxiom cf st)+appendCtorFieldAxiom =+  -- In order to avoid a lot of boilerplate and burdening GHC type checker we+  -- write an unsafe code. Its correctness is tested in dummy constraints of+  -- this function.+  -- Alternative approach I compare this unsafe one with+  -- would be to implement @instance SingI@ for 'CtorField' and consider cases+  -- of 'CtorField' one by one, but this would require propagading+  -- @SingI (cf :: CtorField)@ constraint to all users of 'appendCtorFieldAxiom'.+  unsafeCoerce $ Dict @(AppendCtorFieldAxiom 'NoFields '[])++-- | Result of constructor lookup - entry type and path to it in the tree.+data LookupNamedResult = LNR CtorField Path++type family LnrFieldType (lnr :: LookupNamedResult) where+  LnrFieldType ('LNR f _) = f+type family LnrBranch (lnr :: LookupNamedResult) :: Path where+  LnrBranch ('LNR _ p) = p++-- | Transitively find constructor of some sum type by its name.+--+-- Transitivity means that if sum type consists of other sum types,+-- they will be searched recursively.+type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))++-- | Force result of 'GLookupNamed' to be 'Just'+type family LNRequireFound+  (name :: Symbol)+  (a :: Kind.Type)+  (mf :: Maybe LookupNamedResult)+    :: LookupNamedResult where+  LNRequireFound _ _ ('Just lnr) = lnr+  LNRequireFound name a 'Nothing = TypeError+    ('Text "Datatype " ':<>: 'ShowType a ':<>:+     'Text " has no (sub)constructor " ':<>: 'ShowType name)++type family GLookupNamed (name :: Symbol) (x :: Kind.Type -> Kind.Type)+          :: Maybe LookupNamedResult where+  GLookupNamed name (G.D1 _ x) = GLookupNamed name x+  GLookupNamed name (G.C1 ('G.MetaCons ctorName _ _) x) =+    -- This case corresponds to going straight into a data type (as+    -- opposed to going left or right when we encounter a sum type),+    -- so we need to prepend 'S' here if we successfully find a+    -- constructor.+    PrependS+    -- If we encounter a constructor with requested name, we consider+    -- search successful.+    (If (name == ctorName || name == ("c" `AppendSymbol` ctorName))+       ('Just $ 'LNR (GExtractFields x) '[])+        -- If we do not, we check whether we can go deeper (see+        -- description below).+        (If (GCanGoDeeper x)+        -- And here we essentially just recursively call this search.+        (GLookupNamedDeeper name x)+        -- Or return 'Nothing' if we can not go deeper.+         'Nothing+      )+    )+  GLookupNamed name (x :+: y) =+    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)+  GLookupNamed _ G.V1 = 'Nothing++-- Prepend 'S' to the path inside 'LookupNamedResult' (if 'Just' is passed).+-- Should be done in the case when we go straight into a data type.+type family PrependS (x :: Maybe LookupNamedResult) :: Maybe LookupNamedResult where+  PrependS 'Nothing = 'Nothing+  PrependS ('Just ('LNR cf path)) = 'Just ('LNR cf ('S ': path))++-- Helper type family to check whether we should search for a+-- constructor inside given data type which is supposed to be part of+-- another constructor. Basically we can go deeper only if we+-- encounter another ADT with a constructor storing at least something+-- and which is not a primitive type. We do not go deeper when we+-- encounter a product type here, because it means that there are multiple+-- fields inside one constructor (it is not supported).+type family GCanGoDeeper (x :: Kind.Type -> Kind.Type) :: Bool where+  GCanGoDeeper (_ :+: _) = 'True+  GCanGoDeeper (G.D1 _ x) = GCanGoDeeper x+  GCanGoDeeper (G.S1 _ (G.Rec0 x)) = CanGoDeeper x+  GCanGoDeeper (G.C1 _ _) = 'True+  GCanGoDeeper G.V1 = 'False+  GCanGoDeeper G.U1 = 'False+  GCanGoDeeper (_ :*: _) = 'False+  GCanGoDeeper x = TypeError+    ('Text "GCanGoDeeper encountered unexpected pattern: " ':<>: 'ShowType x)++-- Some types don't have Generic instances (e. g. primitives like Integer), so+-- we need another type family to handle them.+type family CanGoDeeper (x :: Kind.Type) :: Bool where+  CanGoDeeper Integer = 'False+  CanGoDeeper Natural = 'False+  CanGoDeeper Text = 'False+  CanGoDeeper Bool = 'False+  CanGoDeeper ByteString = 'False+  CanGoDeeper Mutez = 'False+  CanGoDeeper Address = 'False+  CanGoDeeper KeyHash = 'False+  CanGoDeeper Timestamp = 'False+  CanGoDeeper PublicKey = 'False+  CanGoDeeper Signature = 'False+  CanGoDeeper (ContractAddr _) = 'False+  CanGoDeeper (BigMap _ _) = 'False+  CanGoDeeper (Map _ _) = 'False+  CanGoDeeper (Set _) = 'False+  CanGoDeeper ([_]) = 'False+  CanGoDeeper x = GCanGoDeeper (G.Rep x)++type family GLookupNamedDeeper (name :: Symbol) (x :: Kind.Type -> Kind.Type)+          :: Maybe LookupNamedResult where+  GLookupNamedDeeper name (G.S1 _ (G.Rec0 y))  = GLookupNamed name (G.Rep y)+  GLookupNamedDeeper name _ = TypeError+    ('Text "Attempt to go deeper failed while looking for sum type constructor"+     ':<>: 'ShowType name+     ':$$:+     'Text "Make sure that all constructors have exactly one field inside."+    )++type family LNMergeFound+  (name :: Symbol)+  (f1 :: Maybe LookupNamedResult)+  (f2 :: Maybe LookupNamedResult)+    :: Maybe LookupNamedResult where+  LNMergeFound _ 'Nothing 'Nothing = 'Nothing+  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)+  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)+  LNMergeFound name ('Just _) ('Just _) = TypeError+    ('Text "Ambiguous reference to datatype constructor: " ':<>: 'ShowType name)++type family GExtractFields (x :: Kind.Type -> Kind.Type)+          :: CtorField where+  GExtractFields (G.S1 _ x) = GExtractFields x+  GExtractFields (G.Rec0 a) = 'OneField a+  GExtractFields G.U1 = 'NoFields+  GExtractFields (_ :*: _) = TypeError+    ('Text "Cannot automatically lookup constructors having multiple fields"+     ':$$:+     'Text "Consider using tuple instead")+    --- ^ @martoon: Probably we will have no use cases for such scenario+    --- anyway, tuples seem to be not worse than separate fields in most cases.++-- | Get type of constructor fields (one or zero) referred by given datatype+-- and name.+type GetCtorField dt ctor =+  LnrFieldType (GetNamed ctor dt)++-- | Expect referred constructor to have only one field (in form of constraint)+-- and extract its type.+type CtorHasOnlyField ctor dt f =+  GetCtorField dt ctor ~ 'OneField f++type family RequireOneField (ctor :: Symbol) (cf :: CtorField) :: Kind.Type where+  RequireOneField _ ('OneField f) = f+  RequireOneField ctor 'NoFields = TypeError+    ('Text "Expected exactly one field" ':$$:+     'Text "In constructor " ':<>: 'ShowType ctor)++-- | Expect referred constructor to have only one field+-- (otherwise compile error is raised) and extract its type.+type CtorOnlyField name dt =+  RequireOneField name (GetCtorField dt name)++----------------------------------------------------------------------------+-- Constructor wrapping instruction+----------------------------------------------------------------------------++-- | Wrap given element into a constructor with the given name.+--+-- Mentioned constructor must have only one field.+--+-- Since labels interpretable by "OverloadedLabels" extension cannot+-- start with capital latter, prepend constructor name with letter+-- "c" (see examples below).+instrWrap+  :: forall dt name st.+     InstrWrapC dt name+  => Label name+  -> Instr (AppendCtorField (GetCtorField dt name) st)+           (ToT dt ': st)+instrWrap _ =+  gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                         @(LnrFieldType (GetNamed name dt))++type InstrWrapC dt name =+  ( IsoValue dt, Generic dt+  , GInstrWrap (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (LnrFieldType (GetNamed name dt))+  , GValueType (G.Rep dt) ~ ToT dt+  )++-- | Wrap a haskell value into a constructor with the given name.+--+-- This is symmetric to 'instrWrap'.+hsWrap+  :: forall dt name.+     InstrWrapC dt name+  => Label name+  -> ExtractCtorField (GetCtorField dt name)+  -> dt+hsWrap _ =+  G.to . gHsWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                             @(LnrFieldType (GetNamed name dt))++-- | Generic traversal for 'instrWrap'.+class GIsoValue x =>+  GInstrWrap+    (x :: Kind.Type -> Kind.Type)+    (path :: Path)+    (entryTy :: CtorField) where+  gInstrWrap+    :: GIsoValue x+    => Instr (AppendCtorField entryTy s) (GValueType x ': s)+  gHsWrap+    :: GIsoValue x+    => ExtractCtorField entryTy -> x p++instance GInstrWrap x path e => GInstrWrap (G.D1 i x) path e where+  gInstrWrap = gInstrWrap @x @path @e+  gHsWrap = G.M1 . gHsWrap @x @path @e++instance (GInstrWrap x path e, GIsoValue y, SingI (GValueType y)) =>+         GInstrWrap (x :+: y) ('L ': path) e where+  gInstrWrap = gInstrWrap @x @path @e `Seq` LEFT+  gHsWrap = G.L1 . gHsWrap @x @path @e++instance (GInstrWrap y path e, GIsoValue x, SingI (GValueType x)) =>+         GInstrWrap (x :+: y) ('R ': path) e where+  gInstrWrap = gInstrWrap @y @path @e `Seq` RIGHT+  gHsWrap = G.R1 . gHsWrap @y @path @e++instance (IsoValue e) =>+         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] ('OneField e) where+  gInstrWrap = Nop+  gHsWrap = G.M1 . G.M1 . G.K1++-- This is the case when a sum type is part of another sum type.+-- Here 'sub' is intermediate sum type.+instance ( path ~ (x ': xs)+         , GInstrWrap (G.Rep sub) path e+         , Generic sub+         , GIsoValue (G.Rep sub), IsoValue sub, GValueType (G.Rep sub) ~ ToT sub+         ) =>+         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where+  gInstrWrap = gInstrWrap @(G.Rep sub) @path @e+  gHsWrap = G.M1 . G.M1 . G.K1 . G.to . gHsWrap @(G.Rep sub) @path @e++instance GInstrWrap (G.C1 c G.U1) '[ 'S] 'NoFields where+  gInstrWrap = PUSH VUnit+  gHsWrap () = G.M1 G.U1++-- Examples+----------------------------------------------------------------------------++-- TODO [TM-186] Consider moving this stuff to test-suite using+-- doctest. Or at least add tests for correctness.++data MyType+  = MyCtor Integer+  | ComplexThing ()+  | UselessThing ("field1" :! ByteString, "field2" :! ())+  deriving stock Generic+  deriving anyclass IsoValue++_MyTypeMyCtor ::+  GetNamed "cMyCtor" MyType :~: 'LNR ('OneField Integer) '[ 'L, 'S]+_MyTypeMyCtor = Refl++_MyTypeComplexThing ::+  GetNamed "cComplexThing" MyType :~: 'LNR ('OneField ()) '[ 'R, 'L, 'S]+_MyTypeComplexThing = Refl++_wrapMyType1 :: Instr (ToT Integer ': s) (ToT MyType ': s)+_wrapMyType1 = instrWrap @MyType #cMyCtor++-- If "c" prefix is too annoying, one can construct labels without+-- OverloadedLabels extension.+_wrapMyType1' :: Instr (ToT Integer ': s) (ToT MyType ': s)+_wrapMyType1' = instrWrap @MyType @"MyCtor" fromLabel++_wrapMyType2 :: Instr (ToT () ': s) (ToT MyType ': s)+_wrapMyType2 = instrWrap @MyType #cComplexThing++_wrapMyType3 :: Instr (ToT (ByteString, ()) ': s) (ToT MyType ': s)+_wrapMyType3 = instrWrap @MyType #cUselessThing++data MyType' = WrapBool Bool+  deriving stock Generic+  deriving anyclass IsoValue++_MyType'WrapBool ::+  GetNamed "cWrapBool" MyType' :~: 'LNR ('OneField Bool) '[ 'S]+_MyType'WrapBool = Refl++_wrapMyType' :: Instr (ToT Bool ': s) (ToT MyType' ': s)+_wrapMyType' = instrWrap @MyType' #cWrapBool++data MyCompoundType+  = CompoundPart1 MyType+  | CompoundPart2 Integer+  | CompoundPart3 Address+  | CompoundPart4 MyType'+  deriving stock Generic+  deriving anyclass IsoValue++_MyCompoundTypeCompoundPart1 ::+  GetNamed "cCompoundPart1" MyCompoundType :~: 'LNR ('OneField MyType) '[ 'L, 'L, 'S]+_MyCompoundTypeCompoundPart1 = Refl++_MyCompoundTypeMyCtor ::+  GetNamed "cMyCtor" MyCompoundType :~: 'LNR ('OneField Integer) '[ 'L, 'L, 'S, 'L, 'S]+_MyCompoundTypeMyCtor = Refl++_MyCompoundTypeCompoundPart2 ::+  GetNamed "cCompoundPart2" MyCompoundType :~: 'LNR ('OneField Integer) '[ 'L, 'R, 'S]+_MyCompoundTypeCompoundPart2 = Refl++_MyCompoundTypeCompoundPart4 ::+  GetNamed "cCompoundPart4" MyCompoundType :~: 'LNR ('OneField MyType') '[ 'R, 'R, 'S]+_MyCompoundTypeCompoundPart4 = Refl++_MyCompoundTypeWrapBool ::+  GetNamed "cWrapBool" MyCompoundType :~: 'LNR ('OneField Bool) '[ 'R, 'R, 'S, 'S]+_MyCompoundTypeWrapBool = Refl++_wrapMyCompoundType1 :: Instr (ToT Integer ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType1 = instrWrap @MyCompoundType #cMyCtor++_wrapMyCompoundType2 :: Instr (ToT Integer ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType2 = instrWrap @MyCompoundType #cCompoundPart2++_wrapMyCompoundType3 :: Instr (ToT Bool ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType3 = instrWrap @MyCompoundType #cWrapBool++_wrapMyCompoundType4 :: Instr (ToT MyType' ': s) (ToT MyCompoundType ': s)+_wrapMyCompoundType4 = instrWrap @MyCompoundType #cCompoundPart4++data MyEnum = Case1 | Case2 | CaseN Integer | CaseDef+  deriving stock Generic+  deriving anyclass IsoValue++_wrapMyEnum1 :: Instr s (ToT MyEnum ': s)+_wrapMyEnum1 = instrWrap @MyEnum #cCase1++_wrapMyEnum2 :: Instr (ToT Integer ': s) (ToT MyEnum ': s)+_wrapMyEnum2 = instrWrap @MyEnum #cCaseN++----------------------------------------------------------------------------+-- "case" instruction+----------------------------------------------------------------------------++-- | Pattern-match on the given datatype.+instrCase+  :: forall dt out inp.+     InstrCaseC dt inp out+  => Rec (CaseClause inp out) (CaseClauses dt) -> Instr (ToT dt ': inp) out+instrCase = gInstrCase @(G.Rep dt)++type InstrCaseC dt inp out =+  ( IsoValue dt+  , GInstrCase (G.Rep dt)+  , GValueType (G.Rep dt) ~ ToT dt+  )++-- | In what different case branches differ - related constructor name and+-- input stack type which the branch starts with.+data CaseClauseParam = CaseClauseParam Symbol CtorField++-- | Type information about single case clause.+data CaseClause (inp :: [T]) (out :: [T]) (param :: CaseClauseParam) where+  CaseClause :: Instr (AppendCtorField x inp) out -> CaseClause inp out ('CaseClauseParam ctor x)++-- | Lift an instruction to case clause.+--+-- You should write out constructor name corresponding to the clause+-- explicitly. Prefix constructor name with "c" letter, otherwise+-- your label will not be recognized by Haskell parser.+-- Passing constructor name can be circumvented but doing so is not recomended+-- as mentioning contructor name improves readability and allows avoiding+-- some mistakes.+(//->)+  :: Label ("c" `AppendSymbol` ctor)+  -> Instr (AppendCtorField x inp) out+  -> CaseClause inp out ('CaseClauseParam ctor x)+(//->) _ = CaseClause+infixr 8 //->++-- | List of 'CaseClauseParam's required to pattern match on the given type.+type CaseClauses a = GCaseClauses (G.Rep a)++-- | Generic traversal for 'instrWrap'.+class GIsoValue x => GInstrCase (x :: Kind.Type -> Kind.Type) where++  type GCaseClauses x :: [CaseClauseParam]++  gInstrCase+    :: GIsoValue x+    => Rec (CaseClause inp out) (GCaseClauses x) -> Instr (GValueType x ': inp) out++instance GInstrCase x => GInstrCase (G.D1 i x) where+  type GCaseClauses (G.D1 i x) = GCaseClauses x+  gInstrCase = gInstrCase @x++instance (GInstrCase x, GInstrCase y, RSplit (GCaseClauses x) (GCaseClauses y)) =>+         GInstrCase (x :+: y) where+  type GCaseClauses (x :+: y) = GCaseClauses x ++ GCaseClauses y+  gInstrCase clauses =+    let (leftClauses, rightClauses) = rsplit clauses+        lbranch = gInstrCase @x leftClauses+        rbranch = gInstrCase @y rightClauses+    in IF_LEFT lbranch rbranch++instance GInstrCaseBranch ctor x => GInstrCase (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GCaseClauses (G.C1 ('G.MetaCons ctor _1 _2) x) = '[GCaseBranchInput ctor x]+  gInstrCase (clause :& RNil) = gInstrCaseBranch @ctor @x clause++-- | Traverse a single contructor and supply its field to instruction in case clause.+class GIsoValue x =>+      GInstrCaseBranch (ctor :: Symbol) (x :: Kind.Type -> Kind.Type) where++  type GCaseBranchInput ctor x :: CaseClauseParam++  gInstrCaseBranch+    :: CaseClause inp out (GCaseBranchInput ctor x)+    -> Instr (GValueType x ': inp) out++instance+  ( GIsoValue x, GIsoValue y+  , TypeError ('Text "Cannot pattern match on constructors with more than 1 field"+               ':$$: 'Text "Consider using tuples instead")+  ) => GInstrCaseBranch ctor (x :*: y) where++  type GCaseBranchInput ctor (x :*: y) = 'CaseClauseParam ctor 'NoFields+  gInstrCaseBranch = error "impossible"++instance GInstrCaseBranch ctor x => GInstrCaseBranch ctor (G.S1 i x) where+  type GCaseBranchInput ctor (G.S1 i x) = GCaseBranchInput ctor x+  gInstrCaseBranch = gInstrCaseBranch @ctor @x++instance IsoValue a => GInstrCaseBranch ctor (G.Rec0 a) where+  type GCaseBranchInput ctor (G.Rec0 a) = 'CaseClauseParam ctor ('OneField a)+  gInstrCaseBranch (CaseClause i) = i++instance GInstrCaseBranch ctor G.U1 where+  type GCaseBranchInput ctor G.U1 = 'CaseClauseParam ctor 'NoFields+  gInstrCaseBranch (CaseClause i) = DROP `Seq` i++-- Examples+----------------------------------------------------------------------------++_caseMyType :: Instr (ToT MyType ': s) (ToT Integer ': s)+_caseMyType = instrCase @MyType $+     #cMyCtor //-> Nop+  :& #cComplexThing //-> (DROP `Seq` PUSH (toVal @Integer 5))+  :& #cUselessThing //-> (DROP `Seq` PUSH (toVal @Integer 0))+  :& RNil++-- Another version, written via tuple.+_caseMyType2 :: Instr (ToT MyType ': s) (ToT Integer ': s)+_caseMyType2 = instrCase @MyType $ recFromTuple+  ( #cMyCtor //->+      Nop+  , #cComplexThing //->+      (DROP `Seq` PUSH (toVal @Integer 5))+  , #cUselessThing //->+      (DROP `Seq` PUSH (toVal @Integer 0))+  )++_caseMyEnum :: Instr (ToT MyEnum ': ToT Integer ': s) (ToT Integer ': s)+_caseMyEnum = instrCase @MyEnum $ recFromTuple+  ( #cCase1 //-> (DROP `Seq` PUSH (toVal @Integer 1))+  , #cCase2 //-> (DROP `Seq` PUSH (toVal @Integer 2))+  , #cCaseN //-> (DIP DROP `Seq` Nop)+  , #cCaseDef //-> Nop+  )++----------------------------------------------------------------------------+-- Constructor unwrapping instruction+----------------------------------------------------------------------------++-- | Unwrap a constructor with the given name.+--+-- Rules which apply to 'instrWrap' function work here as well.+-- Although, unlike @instrWrap@, this function does not work for nullary+-- constructors.+instrUnwrapUnsafe+  :: forall dt name st.+     InstrUnwrapC dt name+  => Label name+  -> Instr (ToT dt ': st)+           (ToT (CtorOnlyField name dt) ': st)+instrUnwrapUnsafe _ =+  gInstrUnwrapUnsafe @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                                 @(CtorOnlyField name dt)++type InstrUnwrapC dt name =+  ( IsoValue dt, Generic dt+  , GInstrUnwrap (G.Rep dt)+      (LnrBranch (GetNamed name dt))+      (CtorOnlyField name dt)+  , GValueType (G.Rep dt) ~ ToT dt+  )++-- | Try to unwrap a constructor with the given name.+hsUnwrap+  :: forall dt name.+     InstrUnwrapC dt name+  => Label name+  -> dt+  -> Maybe (CtorOnlyField name dt)+hsUnwrap _ =+  gHsUnwrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+            @(CtorOnlyField name dt) .+  G.from++class GIsoValue x =>+  GInstrUnwrap+    (x :: Kind.Type -> Kind.Type)+    (path :: Path)+    (entryTy :: Kind.Type) where+  gInstrUnwrapUnsafe+    :: GIsoValue x+    => Instr (GValueType x ': s) (ToT entryTy ': s)+  gHsUnwrap+    :: x p -> Maybe entryTy++instance GInstrUnwrap x path e => GInstrUnwrap (G.D1 i x) path e where+  gInstrUnwrapUnsafe = gInstrUnwrapUnsafe @x @path @e+  gHsUnwrap = gHsUnwrap @x @path @e . G.unM1++instance (GInstrUnwrap x path e, GIsoValue y, SingI (GValueType y)) =>+         GInstrUnwrap (x :+: y) ('L ': path) e where+  gInstrUnwrapUnsafe = IF_LEFT (gInstrUnwrapUnsafe @x @path @e) failWithWrongCtor+  gHsUnwrap = \case+    G.L1 x -> gHsUnwrap @x @path @e x+    G.R1 _ -> Nothing++instance (GInstrUnwrap y path e, GIsoValue x, SingI (GValueType x)) =>+         GInstrUnwrap (x :+: y) ('R ': path) e where+  gInstrUnwrapUnsafe = IF_LEFT failWithWrongCtor (gInstrUnwrapUnsafe @y @path @e)+  gHsUnwrap = \case+    G.R1 y -> gHsUnwrap @y @path @e y+    G.L1 _ -> Nothing++instance (IsoValue e) =>+         GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] e where+  gInstrUnwrapUnsafe = Nop+  gHsUnwrap = Just . G.unK1 . G.unM1 . G.unM1++-- This is the case when a sum type is part of another sum type.+-- Here 'sub' is intermediate sum type.+instance ( path ~ (x ': xs)+         , GInstrUnwrap (G.Rep sub) path e+         , Generic sub+         , GIsoValue (G.Rep sub), IsoValue sub, GValueType (G.Rep sub) ~ ToT sub+         ) =>+         GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where+  gInstrUnwrapUnsafe = gInstrUnwrapUnsafe @(G.Rep sub) @path @e+  gHsUnwrap = gHsUnwrap @(G.Rep sub) @path @e . G.from . G.unK1 . G.unM1 . G.unM1++-- | Failure indicating that we expected value created with one constructor,+-- but got value with different one.+failWithWrongCtor :: Instr i o+failWithWrongCtor =+  PUSH (toVal [mt|unwrapUnsafe: unexpected constructor|]) `Seq`+  FAILWITH++-- Examples+----------------------------------------------------------------------------++_unwrapMyType :: Instr (ToT MyType ': s) (ToT Integer ': s)+_unwrapMyType = instrUnwrapUnsafe @MyType #cMyCtor++_unwrapMyCompoundType :: Instr (ToT MyCompoundType ': s) (ToT Integer ': s)+_unwrapMyCompoundType = instrUnwrapUnsafe @MyCompoundType #cMyCtor++_unwrapMyCompoundType2 :: Instr (ToT MyCompoundType ': s) (ToT Address ': s)+_unwrapMyCompoundType2 = instrUnwrapUnsafe @MyCompoundType #cCompoundPart3++_unwrapMyCompoundType3 :: Instr (ToT MyCompoundType ': s) (ToT Bool ': s)+_unwrapMyCompoundType3 = instrUnwrapUnsafe @MyCompoundType #cWrapBool++_unwrapMyCompoundType4 :: Instr (ToT MyCompoundType ': s) (ToT MyType' ': s)+_unwrapMyCompoundType4 = instrUnwrapUnsafe @MyCompoundType #cCompoundPart4
+ src/Michelson/Typed/Haskell/Value.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE DerivingStrategies #-}++-- | Conversions between haskell types/values and Michelson ones.+module Michelson.Typed.Haskell.Value+  ( IsoCValue (..)+  , IsoValue (..)+  , GIsoValue (GValueType)+  , ToTs+  , ToT'+  , ToTs'+  , IsComparable++  , ContractAddr (..)+  , BigMap (..)+  ) where++import qualified Data.Kind as Kind+import Data.Default (Default)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import Named (NamedF(..))++import Michelson.Typed.Aliases+import Michelson.Typed.CValue+import Michelson.Typed.T+import Michelson.Text+import Michelson.Typed.Value+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)+import Tezos.Crypto (KeyHash, PublicKey, Signature)++-- | Isomorphism between Michelson primitive values and plain Haskell types.+class IsoCValue a where+  -- | Type function that converts a regular Haskell type into a comparable type+  -- (which has kind @CT@).+  type ToCT a :: CT++  -- | Converts a single Haskell value into @CVal@ representation.+  toCVal :: a -> CValue (ToCT a)++  -- | Converts a @CVal@ value into a single Haskell value.+  fromCVal :: CValue (ToCT a) -> a++instance IsoCValue Integer where+  type ToCT Integer = 'CInt+  toCVal = CvInt+  fromCVal (CvInt i) = i++instance IsoCValue Natural where+  type ToCT Natural = 'CNat+  toCVal = CvNat+  fromCVal (CvNat i) = i++instance IsoCValue MText where+  type ToCT MText = 'CString+  toCVal = CvString+  fromCVal (CvString s) = s++instance DoNotUseTextError => IsoCValue Text where+  type ToCT Text = DoNotUseTextError+  toCVal = error "impossible"+  fromCVal _ = error "impossible"++instance IsoCValue Bool where+  type ToCT Bool = 'CBool+  toCVal = CvBool+  fromCVal (CvBool b) = b++instance IsoCValue ByteString where+  type ToCT ByteString = 'CBytes+  toCVal = CvBytes+  fromCVal (CvBytes b) = b++instance IsoCValue Mutez where+  type ToCT Mutez = 'CMutez+  toCVal = CvMutez+  fromCVal (CvMutez m) = m++instance IsoCValue Address where+  type ToCT Address = 'CAddress+  toCVal = CvAddress+  fromCVal (CvAddress a) = a++instance IsoCValue KeyHash where+  type ToCT KeyHash = 'CKeyHash+  toCVal = CvKeyHash+  fromCVal (CvKeyHash k) = k++instance IsoCValue Timestamp where+  type ToCT Timestamp = 'CTimestamp+  toCVal = CvTimestamp+  fromCVal (CvTimestamp t) = t++-- | Isomorphism between Michelson values and plain Haskell types.+--+-- Default implementation of this typeclass converts ADTs to Michelson+-- "pair"s and "or"s.+class IsoValue a where+  -- | Type function that converts a regular Haskell type into a @T@ type.+  type ToT a :: T+  type ToT a = GValueType (G.Rep a)++  -- | Converts a Haskell structure into @Value@ representation.+  toVal :: a -> Value (ToT a)+  default toVal+    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GValueType (G.Rep a))+    => a -> Value (ToT a)+  toVal = gToValue . G.from++  -- | Converts a @Value@ into Haskell type.+  fromVal :: Value (ToT a) -> a+  default fromVal+    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GValueType (G.Rep a))+    => Value (ToT a) -> a+  fromVal = G.to . gFromValue++-- | Type function to convert a Haskell stack type to @T@-based one.+type family ToTs (ts :: [Kind.Type]) :: [T] where+  ToTs '[] = '[]+  ToTs (x ': xs) = ToT x ': ToTs xs++-- | Overloaded version of 'ToT' to work on Haskell and @T@ types.+type family ToT' (t :: k) :: T where+  ToT' (t :: T) = t+  ToT' (t :: Kind.Type) = ToT t++-- | Overloaded version of 'ToTs' to work on Haskell and @T@ stacks.+type family ToTs' (t :: [k]) :: [T] where+  ToTs' (t :: [T]) = t+  ToTs' (a :: [Kind.Type]) = ToTs a++-- | A useful property which holds for all 'CT' types.+type IsComparable c = ToT c ~ 'Tc (ToCT c)++instance IsoValue Integer where+  type ToT Integer = 'Tc (ToCT Integer)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue Natural where+  type ToT Natural = 'Tc (ToCT Natural)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue MText where+  type ToT MText = 'Tc (ToCT MText)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance DoNotUseTextError => IsoValue Text where+  type ToT Text = DoNotUseTextError+  toVal = error "impossible"+  fromVal = error "impossible"++instance IsoValue Bool where+  type ToT Bool = 'Tc (ToCT Bool)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue ByteString where+  type ToT ByteString = 'Tc (ToCT ByteString)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue Mutez where+  type ToT Mutez = 'Tc (ToCT Mutez)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue KeyHash where+  type ToT KeyHash = 'Tc (ToCT KeyHash)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue Timestamp where+  type ToT Timestamp = 'Tc (ToCT Timestamp)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue Address where+  type ToT Address = 'Tc (ToCT Address)+  toVal = VC . toCVal+  fromVal (VC x) = fromCVal x++instance IsoValue PublicKey where+  type ToT PublicKey = 'TKey+  toVal = VKey+  fromVal (VKey x) = x++instance IsoValue Signature where+  type ToT Signature = 'TSignature+  toVal = VSignature+  fromVal (VSignature x) = x++instance IsoValue ()++instance IsoValue a => IsoValue [a] where+  type ToT [a] = 'TList (ToT a)+  toVal = VList . map toVal+  fromVal (VList x) = map fromVal x++instance IsoValue a => IsoValue (Maybe a) where+  type ToT (Maybe a) = 'TOption (ToT a)+  toVal = VOption . fmap toVal+  fromVal (VOption x) = fmap fromVal x++instance (IsoValue l, IsoValue r) => IsoValue (Either l r)++instance (IsoValue a, IsoValue b) => IsoValue (a, b)++instance (Ord c, IsoCValue c) => IsoValue (Set c) where+  type ToT (Set c) = 'TSet (ToCT c)+  toVal = VSet . Set.map toCVal+  fromVal (VSet x) = Set.map fromCVal x++instance (Ord k, IsoCValue k, IsoValue v) => IsoValue (Map k v) where+  type ToT (Map k v) = 'TMap (ToCT k) (ToT v)+  toVal = VMap . Map.mapKeys toCVal . Map.map toVal+  fromVal (VMap x) = Map.map fromVal $ Map.mapKeys fromCVal x++instance IsoValue Operation where+  type ToT Operation = 'TOperation+  toVal = VOp+  fromVal (VOp x) = x+++deriving newtype instance IsoValue a => IsoValue (Identity a)+deriving newtype instance IsoValue a => IsoValue (NamedF Identity a name)+deriving newtype instance IsoValue a => IsoValue (NamedF Maybe a name)++instance (IsoValue a, IsoValue b, IsoValue c) => IsoValue (a, b, c)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d)+       => IsoValue (a, b, c, d)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e)+       => IsoValue (a, b, c, d, e)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e,+          IsoValue f)+       => IsoValue (a, b, c, d, e, f)+instance (IsoValue a, IsoValue b, IsoValue c, IsoValue d, IsoValue e,+          IsoValue f, IsoValue g)+       => IsoValue (a, b, c, d, e, f, g)++-- Types used specifically for conversion+----------------------------------------------------------------------------++-- | Since @Contract@ name is used to designate contract code, lets call+-- analogy of 'TContract' type as follows.+newtype ContractAddr (cp :: Kind.Type) =+  ContractAddr { unContractAddress :: Address }++instance IsoValue (ContractAddr cp) where+  type ToT (ContractAddr cp) = 'TContract (ToT cp)+  toVal = VContract . unContractAddress+  fromVal (VContract a) = ContractAddr a++newtype BigMap k v = BigMap { unBigMap :: Map k v }+  deriving stock (Eq, Show)+  deriving newtype (Default, Semigroup, Monoid)++instance (Ord k, IsoCValue k, IsoValue v) => IsoValue (BigMap k v) where+  type ToT (BigMap k v) = 'TBigMap (ToCT k) (ToT v)+  toVal = VBigMap . Map.mapKeys toCVal . Map.map toVal . unBigMap+  fromVal (VBigMap x) = BigMap $ Map.map fromVal $ Map.mapKeys fromCVal x++-- Generic magic+----------------------------------------------------------------------------++-- | Implements ADT conversion to Michelson value.+--+-- Thanks to Generic, Michelson representation will+-- be a balanced tree; this reduces average access time in general case.+--+-- A drawback of such approach is that, in theory, in new GHC version+-- generified representation may change; however, chances are small and+-- I (martoon) believe that contract versions will change much faster anyway.+class GIsoValue (x :: Kind.Type -> Kind.Type) where+  type GValueType x :: T+  gToValue :: x p -> Value (GValueType x)+  gFromValue :: Value (GValueType x) -> x p++instance GIsoValue x => GIsoValue (G.M1 t i x) where+  type GValueType (G.M1 t i x) = GValueType x+  gToValue = gToValue . G.unM1+  gFromValue = G.M1 . gFromValue++instance (GIsoValue x, GIsoValue y) => GIsoValue (x :+: y) where+  type GValueType (x :+: y) = 'TOr (GValueType x) (GValueType y)+  gToValue = VOr . \case+    L1 x -> Left (gToValue x)+    R1 y -> Right (gToValue y)+  gFromValue (VOr e) = case e of+    Left vx -> L1 (gFromValue vx)+    Right vy -> R1 (gFromValue vy)++instance (GIsoValue x, GIsoValue y) => GIsoValue (x :*: y) where+  type GValueType (x :*: y) = 'TPair (GValueType x) (GValueType y)+  gToValue (x :*: y) = VPair (gToValue x, gToValue y)+  gFromValue (VPair (vx, vy)) = gFromValue vx :*: gFromValue vy++instance GIsoValue G.U1 where+  type GValueType G.U1 = 'TUnit+  gToValue G.U1 = VUnit+  gFromValue VUnit = G.U1++instance IsoValue a => GIsoValue (G.Rec0 a) where+  type GValueType (G.Rec0 a) = ToT a+  gToValue = toVal . G.unK1+  gFromValue = G.K1 . fromVal
src/Michelson/Typed/Instr.hs view
@@ -1,34 +1,28 @@+{-# LANGUAGE DerivingStrategies #-}+ -- | Module, containing data types for Michelson value.  module Michelson.Typed.Instr   ( Instr (..)-  , (#)+  , ExtInstr (..)+  , StackRef (..)+  , mkStackRef+  , PrintComment (..)+  , TestAssert (..)   , Contract-  , ExtT-  , InstrExtT   ) where -import Data.Kind (Type)-import Data.Singletons (SingI)+import Data.Singletons (SingI(..))+import Fmt ((+||), (||+))+import qualified Text.Show +import Michelson.Typed.Annotation (Notes) import Michelson.Typed.Arith import Michelson.Typed.Polymorphic+import Michelson.Typed.Scope import Michelson.Typed.T (CT(..), T(..))-import Michelson.Typed.Value (ContractInp, ContractOut, Val(..))---- | Infix version of @Seq@ constructor.------ One can represent sequence of Michelson opertaions as follows:--- @SWAP; DROP; DUP;@ -> @SWAP # DROP # DUP@.-(#) :: Typeable b => Instr a b -> Instr b c -> Instr a c-(#) = Seq--infixl 0 #---- | ExtT is extension of Instr by Morley instructions-type family ExtT (instr :: [T] -> [T] -> Type) :: Type--type InstrExtT = ExtT Instr+import Michelson.Typed.Value (ContractInp, ContractOut, Value'(..))+import Util.Peano  -- | Representation of Michelson instruction or sequence -- of instructions.@@ -46,16 +40,12 @@ -- -- Type parameter @out@ states for output stack type or type -- of stack that will be left after instruction's execution.---- pva701: Typeable constraints are added during TM-29.--- Maybe it makes sense to think how to eliminate them--- if they break something data Instr (inp :: [T]) (out :: [T]) where-  Seq :: Typeable b => Instr a b -> Instr b c -> Instr a c+  Seq :: Instr a b -> Instr b c -> Instr a c   -- | Nop operation. Missing in Michelson spec, added to parse construction   -- like  `IF {} { SWAP; DROP; }`.   Nop :: Instr s s-  Ext :: ExtT Instr -> Instr s s+  Ext :: ExtInstr s -> Instr s s   -- | Nested wrapper is going to wrap a sequence of instructions with { }.   -- It is crucial because serialisation of a contract   -- depends on precise structure of its code.@@ -64,44 +54,38 @@   DROP :: Instr (a ': s) s   DUP  :: Instr (a ': s) (a ': a ': s)   SWAP :: Instr (a ': b ': s) (b ': a ': s)-  PUSH :: forall t s . SingI t => Val Instr t -> Instr s (t ': s)+  PUSH+    :: forall t s . (SingI t, HasNoOp t, HasNoBigMap t)+    => Value' Instr t -> Instr s (t ': s)   SOME :: Instr (a ': s) ('TOption a ': s)   NONE :: forall a s . SingI a => Instr s ('TOption a ': s)   UNIT :: Instr s ('TUnit ': s)   IF_NONE-    :: (Typeable a, Typeable s)-    => Instr s s'+    :: Instr s s'     -> Instr (a ': s) s'     -> Instr ('TOption a ': s) s'   PAIR :: Instr (a ': b ': s) ('TPair a b ': s)   CAR :: Instr ('TPair a b ': s) (a ': s)   CDR :: Instr ('TPair a b ': s) (b ': s)-  LEFT :: forall a b s . SingI b => Instr (a ': s) ('TOr a b ': s)+  LEFT :: forall b a s . SingI b => Instr (a ': s) ('TOr a b ': s)   RIGHT :: forall a b s . SingI a => Instr (b ': s) ('TOr a b ': s)   IF_LEFT-    :: (Typeable s, Typeable a, Typeable b)-    => Instr (a ': s) s'+    :: Instr (a ': s) s'     -> Instr (b ': s) s'     -> Instr ('TOr a b ': s) s'-  IF_RIGHT-    :: (Typeable s, Typeable b, Typeable a)-    => Instr (b ': s) s'-    -> Instr (a ': s) s'-    -> Instr ('TOr a b ': s) s'   NIL :: SingI p => Instr s ('TList p ': s)   CONS :: Instr (a ': 'TList a ': s) ('TList a ': s)   IF_CONS-    :: (Typeable s, Typeable a)-    => Instr (a ': 'TList a ': s) s'+    :: Instr (a ': 'TList a ': s) s'     -> Instr s s'     -> Instr ('TList a ': s) s'   SIZE :: SizeOp c => Instr (c ': s) ('Tc 'CNat ': s)-  EMPTY_SET :: SingI e => Instr s ('TSet e ': s)-  EMPTY_MAP :: (SingI a, SingI b) => Instr s ('TMap a b ': s)-  MAP :: (Typeable (MapOpInp c ': s), MapOp c b)+  EMPTY_SET :: (Typeable e, SingI e) => Instr s ('TSet e ': s)+  EMPTY_MAP :: (Typeable a, Typeable b, SingI a, SingI b) => Instr s ('TMap a b ': s)+  MAP :: MapOp c       => Instr (MapOpInp c ': s) (b ': s)       -> Instr (c ': s) (MapOpRes c b ': s)-  ITER :: (Typeable (IterOpEl c ': s), IterOp c) => Instr (IterOpEl c ': s) s -> Instr (c ': s) s+  ITER :: IterOp c => Instr (IterOpEl c ': s) s -> Instr (c ': s) s   MEM :: MemOp c => Instr ('Tc (MemOpKey c) ': c ': s) ('Tc 'CBool ': s)   GET     :: GetOp c@@ -109,26 +93,23 @@   UPDATE     :: UpdOp c     => Instr ('Tc (UpdOpKey c) ': UpdOpParams c ': c ': s) (c ': s)-  IF :: Typeable s-     => Instr s s'+  IF :: Instr s s'      -> Instr s s'      -> Instr ('Tc 'CBool ': s) s'-  LOOP :: Typeable s-       => Instr s ('Tc 'CBool ': s)+  LOOP :: Instr s ('Tc 'CBool ': s)        -> Instr ('Tc 'CBool ': s) s   LOOP_LEFT-    :: (Typeable a, Typeable s)-    => Instr (a ': s) ('TOr a b ': s)+    :: Instr (a ': s) ('TOr a b ': s)     -> Instr ('TOr a b ': s) (b ': s)-  LAMBDA :: forall i o s . (SingI i, SingI o)-         => Val Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)-  EXEC :: Typeable t1 => Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)-  DIP :: Typeable a => Instr a c -> Instr (b ': a) (b ': c)-  FAILWITH :: Instr (a ': s) t+  LAMBDA :: forall i o s . (Each [Typeable, SingI] [i, o])+         => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)+  EXEC :: Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)+  DIP :: Instr a c -> Instr (b ': a) (b ': c)+  FAILWITH :: (Typeable a, SingI a) => Instr (a ': s) t   CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)   RENAME :: Instr (a ': s) (a ': s)-  PACK :: Instr (a ': s) ('Tc 'CBytes ': s)-  UNPACK :: SingI a => Instr ('Tc 'CBytes ': s) ('TOption a ': s)+  PACK :: (SingI a, HasNoOp a, HasNoBigMap a) => Instr (a ': s) ('Tc 'CBytes ': s)+  UNPACK :: (SingI a, HasNoOp a, HasNoBigMap a) => Instr ('Tc 'CBytes ': s) ('TOption a ': s)   CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s)   CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s)   SLICE@@ -136,13 +117,13 @@     => Instr ('Tc 'CNat ': 'Tc 'CNat ': c ': s) ('TOption c ': s)   ISNAT :: Instr ('Tc 'CInt ': s) ('TOption ('Tc 'CNat) ': s)   ADD-    :: ArithOp Add n m+    :: (ArithOp Add n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Add n m) ': s)   SUB-    :: ArithOp Sub n m+    :: (ArithOp Sub n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Sub n m) ': s)   MUL-    :: ArithOp Mul n m+    :: (ArithOp Mul n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Mul n m) ': s)   EDIV     :: EDivOp n m@@ -156,25 +137,25 @@     :: UnaryArithOp Neg n     => Instr ('Tc n ': s) ('Tc (UnaryArithRes Neg n) ': s)   LSL-    :: ArithOp Lsl n m+    :: (ArithOp Lsl n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Lsl n m) ': s)   LSR-    :: ArithOp Lsr n m+    :: (ArithOp Lsr n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Lsr n m) ': s)   OR-    :: ArithOp Or n m+    :: (ArithOp Or n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Or n m) ': s)   AND-    :: ArithOp And n m+    :: (ArithOp And n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes And n m) ': s)   XOR-    :: ArithOp Xor n m+    :: (ArithOp Xor n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Xor n m) ': s)   NOT     :: UnaryArithOp Not n     => Instr ('Tc n ': s) ('Tc (UnaryArithRes Not n) ': s)   COMPARE-    :: ArithOp Compare n m+    :: (ArithOp Compare n m, Typeable n, Typeable m)     => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Compare n m) ': s)   EQ     :: UnaryArithOp Eq' n@@ -197,9 +178,11 @@   INT :: Instr ('Tc 'CNat ': s) ('Tc 'CInt ': s)   SELF :: forall (cp :: T) s . Instr s ('TContract cp ': s)   CONTRACT-    :: SingI p => Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)+    :: (SingI p, Typeable p) => Notes p -> Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)+  -- Store Notes to be able to verify CONTRACT in typechecker   TRANSFER_TOKENS-    :: Typeable p => Instr (p ': 'Tc 'CMutez ': 'TContract p ': s)+    :: (Typeable p, SingI p, HasNoOp p, HasNoBigMap p) =>+       Instr (p ': 'Tc 'CMutez ': 'TContract p ': s)                    ('TOperation ': s)   SET_DELEGATE     :: Instr ('TOption ('Tc 'CKeyHash) ': s) ('TOperation ': s)@@ -210,15 +193,7 @@          ': 'Tc 'CMutez ': s) ('TOperation ': 'Tc 'CAddress ': s)    CREATE_CONTRACT-    :: (SingI p, SingI g, Typeable p, Typeable g)-    => Instr-        ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash) ': 'Tc 'CBool-          ': 'Tc 'CBool ': 'Tc 'CMutez-          ': 'TLambda ('TPair p g)-                       ('TPair ('TList 'TOperation) g) ': g ': s)-        ('TOperation ': 'Tc 'CAddress ': s)-  CREATE_CONTRACT2-    :: (SingI p, SingI g, Typeable p, Typeable g)+    :: (Each [Typeable, SingI, HasNoOp] [p, g], HasNoBigMap p, BigMapConstraint g)     => Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ]     -> Instr ('Tc 'CKeyHash ':               'TOption ('Tc 'CKeyHash) ':@@ -245,6 +220,54 @@   SENDER :: Instr s ('Tc 'CAddress ': s)   ADDRESS :: Instr ('TContract a ': s) ('Tc 'CAddress ': s) -deriving instance Show (ExtT Instr) => Show (Instr inp out)+deriving instance Show (Instr inp out)++---------------------------------------------------++data TestAssert (s :: [T]) where+  TestAssert+    :: (Typeable out)+    => Text+    -> PrintComment inp+    -> Instr inp ('Tc 'CBool ': out)+    -> TestAssert inp++deriving instance Show (TestAssert s)++-- | A reference into the stack of a given type.+data StackRef (st :: [T]) where+  -- | Keeps 0-based index to a stack element counting from the top.+  StackRef+    :: (KnownPeano idx, LongerThan st idx)+    => Sing (idx :: Peano) -> StackRef st++instance Eq (StackRef st) where+  StackRef snat1 == StackRef snat2 = peanoVal snat1 == peanoVal snat2++instance Show (StackRef st) where+  show (StackRef snat) = "StackRef {" +|| peanoVal snat ||+ "}"++-- | Create a stack reference, performing checks at compile time.+mkStackRef+  :: forall (gn :: Nat) st n.+      (n ~ ToPeano gn, SingI n, KnownPeano n, RequireLongerThan st n)+  => StackRef st+mkStackRef = requiredLongerThan @st @n $ StackRef $ sing @(ToPeano gn)++-- | A print format with references into the stack+newtype PrintComment (st :: [T]) = PrintComment+  { unPrintComment :: [Either Text (StackRef st)]+  } deriving stock (Eq, Show, Generic)+    deriving newtype (Semigroup, Monoid)++instance IsString (PrintComment st) where+  fromString = PrintComment . one . Left . fromString++data ExtInstr s+  = TEST_ASSERT (TestAssert s)+  | PRINT (PrintComment s)+  deriving (Show)++---------------------------------------------------  type Contract cp st = Instr (ContractInp cp st) (ContractOut st)
src/Michelson/Typed/Polymorphic.hs view
@@ -16,17 +16,17 @@ import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.Text as T -import Michelson.Typed.CValue (CVal(..))+import Michelson.Text+import Michelson.Typed.CValue (CValue(..)) import Michelson.Typed.T (CT(..), T(..))-import Michelson.Typed.Value (Val(..))+import Michelson.Typed.Value (Value'(..))  import Tezos.Core (divModMutez, divModMutezInt)  class MemOp (c :: T) where   type MemOpKey c :: CT-  evalMem :: CVal (MemOpKey c) -> Val cp c -> Bool+  evalMem :: CValue (MemOpKey c) -> Value' cp c -> Bool instance MemOp ('TSet e) where   type MemOpKey ('TSet e) = e   evalMem e (VSet s) = e `S.member` s@@ -37,27 +37,30 @@   type MemOpKey ('TBigMap k v) = k   evalMem k (VBigMap m) = k `M.member` m -class MapOp (c :: T) (b :: T) where+class MapOp (c :: T) where   type MapOpInp c :: T-  type MapOpRes c b :: T-  mapOpToList :: Val instr c -> [Val instr (MapOpInp c)]-  mapOpFromList :: Val instr c -> [Val instr b] -> Val instr (MapOpRes c b)-instance MapOp ('TMap k v) v' where+  type MapOpRes c :: T -> T+  mapOpToList :: Value' instr c -> [Value' instr (MapOpInp c)]+  mapOpFromList :: Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)+instance MapOp ('TMap k v) where   type MapOpInp ('TMap k v) = 'TPair ('Tc k) v-  type MapOpRes ('TMap k v) v' = 'TMap k v'+  type MapOpRes ('TMap k v) = 'TMap k   mapOpToList (VMap m) = map (\(k, v) -> VPair (VC k, v)) $ M.toAscList m   mapOpFromList (VMap m) l =     VMap $ M.fromList $ zip (map fst $ M.toAscList m) l-instance MapOp ('TList e) e' where+instance MapOp ('TList e) where   type MapOpInp ('TList e) = e-  type MapOpRes ('TList e) e' = 'TList e'+  type MapOpRes ('TList e) = 'TList   mapOpToList (VList l) = l   mapOpFromList (VList _) l' = VList l'+-- If you find it difficult to implement 'MapOp' for your datatype+-- because of order of type arguments in it, consider wrapping it+-- into a newtype.  class IterOp (c :: T) where   type IterOpEl c :: T   iterOpDetachOne ::-    Val instr c -> (Maybe (Val instr (IterOpEl c)), Val instr c)+    Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c) instance IterOp ('TMap k v) where   type IterOpEl ('TMap k v) = 'TPair ('Tc k) v   iterOpDetachOne (VMap m) =@@ -73,7 +76,7 @@   iterOpDetachOne (VSet s) = (VC <$> S.lookupMin s, VSet $ S.deleteMin s)  class SizeOp (c :: T) where-  evalSize :: Val cp c -> Int+  evalSize :: Value' cp c -> Int instance SizeOp ('Tc 'CString) where   evalSize (VC (CvString s)) = length s instance SizeOp ('Tc 'CBytes) where@@ -89,8 +92,8 @@   type UpdOpKey c :: CT   type UpdOpParams c :: T   evalUpd-    :: CVal (UpdOpKey c)-    -> Val cp (UpdOpParams c) -> Val cp c -> Val cp c+    :: CValue (UpdOpKey c)+    -> Value' cp (UpdOpParams c) -> Value' cp c -> Value' cp c instance UpdOp ('TMap k v) where   type UpdOpKey ('TMap k v) = k   type UpdOpParams ('TMap k v) = 'TOption v@@ -116,7 +119,7 @@ class GetOp (c :: T) where   type GetOpKey c :: CT   type GetOpVal c :: T-  evalGet :: CVal (GetOpKey c) -> Val cp c -> Maybe (Val cp (GetOpVal c))+  evalGet :: CValue (GetOpKey c) -> Value' cp c -> Maybe (Value' cp (GetOpVal c)) instance GetOp ('TBigMap k v) where   type GetOpKey ('TBigMap k v) = k   type GetOpVal ('TBigMap k v) = v@@ -127,47 +130,48 @@   evalGet k (VMap m) = k `M.lookup` m  class ConcatOp (c :: T) where-  evalConcat :: Val cp c -> Val cp c -> Val cp c-  evalConcat' :: [Val cp c] -> Val cp c+  evalConcat :: Value' cp c -> Value' cp c -> Value' cp c+  evalConcat' :: [Value' cp c] -> Value' cp c instance ConcatOp ('Tc 'CString) where   evalConcat (VC (CvString s1)) (VC (CvString s2)) = (VC . CvString) (s1 <> s2)   evalConcat' l =-    (VC . CvString . fromString) $ concat $ (map (\(VC (CvString s)) -> toString s)) l+    (VC . CvString) $ mconcat $ map (\(VC (CvString s)) -> s) l instance ConcatOp ('Tc 'CBytes) where   evalConcat (VC (CvBytes b1)) (VC (CvBytes b2)) = (VC . CvBytes) (b1 <> b2)   evalConcat' l =-    (VC . CvBytes) $ foldr (<>) mempty (map (\(VC (CvBytes b)) -> b) l)+    (VC . CvBytes) $ foldr ((<>) . (\(VC (CvBytes b)) -> b)) mempty l  class SliceOp (c :: T) where-  evalSlice :: Natural -> Natural -> Val cp c -> Maybe (Val cp c)+  evalSlice :: Natural -> Natural -> Value' cp c -> Maybe (Value' cp c) instance SliceOp ('Tc 'CString) where   evalSlice o l (VC (CvString s)) =-    if o > fromIntegral (length s) || o + l > fromIntegral (length s)-    then Nothing-    else (Just . VC . CvString . toText) $ sliceText o l s-    where-      sliceText :: Natural -> Natural -> Text -> Text-      sliceText o' l' s' =-        T.drop ((fromIntegral . toInteger) o') $-          T.take ((fromIntegral . toInteger) l') s'+    VC . CvString <$> sliceImpl dropMText takeMText o l s instance SliceOp ('Tc 'CBytes) where   evalSlice o l (VC (CvBytes b)) =-    if o > fromIntegral (length b) || o + l > fromIntegral (length b)-    then Nothing-    else (Just . VC . CvBytes) $ sliceBytes o l b-    where-      sliceBytes :: Natural -> Natural -> ByteString -> ByteString-      sliceBytes o' l' b' =-        B.drop ((fromIntegral . toInteger) o') $-          B.take ((fromIntegral . toInteger) l') b'+    VC . CvBytes <$> sliceImpl B.drop B.take o l b +sliceImpl ::+  Container str+  => (Int -> str -> str)+  -> (Int -> str -> str)+  -> Natural+  -> Natural+  -> str+  -> Maybe str+sliceImpl dropF takeF offset l s+  | offset >= fromIntegral (length s) || offset + l > fromIntegral (length s) =+    Nothing+  | otherwise+  -- Drop offset and then take requested number of items.+   = Just . takeF (fromIntegral l) . dropF (fromIntegral offset) $ s+ class EDivOp (n :: CT) (m :: CT) where   type EDivOpRes n m :: CT   type EModOpRes n m :: CT   evalEDivOp-    :: CVal n-    -> CVal m-    -> Val instr ('TOption ('TPair ('Tc (EDivOpRes n m))+    :: CValue n+    -> CValue m+    -> Value' instr ('TOption ('TPair ('Tc (EDivOpRes n m))                                      ('Tc (EModOpRes n m))))  instance EDivOp 'CInt 'CInt where
+ src/Michelson/Typed/Print.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Types printing.+--+-- Moved in a separate module, because we print via converting to+-- untyped @T@ type to avoid duplication.+module Michelson.Typed.Print+  ( buildStack+  ) where++import Fmt (Buildable(..), Builder, listF)++import Michelson.Typed.Extract+import Michelson.Typed.T++instance Buildable T where+  build = build . toUType++-- | Format type stack in a pretty way.+buildStack :: [T] -> Builder+buildStack = listF
+ src/Michelson/Typed/Scope.hs view
@@ -0,0 +1,332 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Module, containing restrictions imposed by instruction or value scope.++module Michelson.Typed.Scope+  ( AllowBigMap+  , HasNoBigMap+  , HasNoOp+  , ForbidBigMap+  , ForbidOp+  , BigMapPresence (..)+  , OpPresence (..)+  , BigMapConstraint+  , checkOpPresence+  , checkBigMapPresence+  , checkBigMapConstraint+  , opAbsense+  , bigMapAbsense+  , forbiddenOp+  , forbiddenBigMap+  , bigMapConstrained+  ) where++import Data.Constraint (Dict(..))+import Data.Singletons (SingI(..))+import Data.Type.Bool  (type (||))+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Michelson.Typed.Sing (Sing(..))+import Michelson.Typed.T (T(..))++-- | Whether this type contains 'TOperation' type.+--+-- 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 ('Tc _) = 'False+  ContainsOp 'TKey = 'False+  ContainsOp 'TUnit = 'False+  ContainsOp 'TSignature = 'False+  ContainsOp ('TOption t) = ContainsOp t+  ContainsOp ('TList t) = ContainsOp t+  ContainsOp ('TSet _) = 'False+  ContainsOp 'TOperation = 'True+  ContainsOp ('TContract t) = ContainsOp t+  ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b+  ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b+  ContainsOp ('TLambda _ _) = 'False+  ContainsOp ('TMap _ v) = ContainsOp v+  ContainsOp ('TBigMap _ v) = ContainsOp v++-- | Whether this type contains 'TBigMap' type.+--+-- In some scopes (constants, parameters) appearing for big_map type+-- is prohibited. It is permitted in toplevel left element of storage pair.+-- Big_maps in input/output of lambdas are allowed without limits though.+type family ContainsBigMap (t :: T) :: Bool where+  ContainsBigMap ('Tc _) = 'False+  ContainsBigMap 'TKey = 'False+  ContainsBigMap 'TUnit = 'False+  ContainsBigMap 'TSignature = 'False+  ContainsBigMap ('TOption t) = ContainsBigMap t+  ContainsBigMap ('TList t) = ContainsBigMap t+  ContainsBigMap ('TSet _) = 'False+  ContainsBigMap 'TOperation = 'False+  ContainsBigMap ('TContract t) = ContainsBigMap t+  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++-- | Constraint which ensures that operation type does not appear in a given type.+--+-- 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 bigmap does not appear in a given type.+class (ContainsBigMap t ~ 'False) => HasNoBigMap t+instance (ContainsBigMap t ~ 'False) => HasNoBigMap t++-- | Type family to check if t is ill-typed contract storage+--   (it contains bigmap not on the left of its toplevel pair)+--+-- Used in @BigMapConstraint@+type family BadBigMapPair t :: Bool where+  BadBigMapPair ('TPair ('TBigMap _ v) b) =+    ContainsBigMap v || ContainsBigMap b+  BadBigMapPair t = ContainsBigMap t++-- | Constraint which ensures, that @t@ can be used as type of contract storage+--   so it optionally has bigmap only on the left of its toplevel pair+type BigMapConstraint t = BadBigMapPair t ~ 'False++-- | Report a human-readable error about 'TOperation' at a wrong place.+type family FailOnOperationFound (enabled :: Bool) :: Constraint where+  FailOnOperationFound 'True =+    TypeError ('Text "Operations are not allowed in this scope")+  FailOnOperationFound 'False = ()++-- | Report a human-readable error about 'TBigMap' at a wrong place.+type family FailOnBigMapFound (enabled :: Bool) :: Constraint where+  FailOnBigMapFound 'True =+    TypeError ('Text "BigMaps are not allowed in this scope")+  FailOnBigMapFound 'False = ()++-- | This is like 'HasNoOp', it raises a more human-readable error+-- when @t@ type is concrete, but you cannot easily extract a proof+-- of no-operation-presence from it.+--+-- Use it in our eDSL.+type ForbidOp t = FailOnOperationFound (ContainsOp t)++type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t)++type AllowBigMap t = FailOnBigMapFound (BadBigMapPair t)++-- | Reify 'HasNoOp' contraint from 'ForbidOp'.+forbiddenOp+  :: forall t a.+     (SingI t, ForbidOp t)+  => (HasNoOp t => a)+  -> a+forbiddenOp a =+  -- It's not clear now to proof GHC that @HasNoOp t@ is implication of+  -- @ForbidOp t@, so we use @error@ below and also disable+  -- "-Wredundant-constraints" extension.+  case checkOpPresence (sing @t) of+    OpAbsent -> a+    OpPresent -> error "impossible"++forbiddenBigMap+  :: forall t a.+     (SingI t, ForbidBigMap t)+  => (HasNoBigMap t => a)+  -> a+forbiddenBigMap a =+  case checkBigMapPresence (sing @t) of+    BigMapAbsent -> a+    BigMapPresent -> error "impossible"++checkBigMapConstraint+  :: forall t a.+     (SingI t, AllowBigMap t)+  => (BigMapConstraint t => a)+  -> a+checkBigMapConstraint a =+  case bigMapConstrained (sing @t) of+    Just Dict -> a+    Nothing -> error "impossible"++-- | Whether the type contains 'TOperation', with proof.+data OpPresence (t :: T)+  = ContainsOp t ~ 'True => OpPresent+  | ContainsOp t ~ 'False => OpAbsent++data BigMapPresence (t :: T)+  = ContainsBigMap t ~ 'True => BigMapPresent+  | ContainsBigMap t ~ 'False => BigMapAbsent++-- @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 the given type contains 'TOperation'.+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.+  STc _ -> OpAbsent+  STKey -> OpAbsent+  STSignature -> OpAbsent+  STUnit -> OpAbsent+  STOption t -> case checkOpPresence t of+    OpPresent -> OpPresent+    OpAbsent -> OpAbsent+  STList t -> case checkOpPresence t of+    OpPresent -> OpPresent+    OpAbsent -> OpAbsent+  STSet _ -> OpAbsent+  STOperation -> OpPresent+  STContract 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 _ v -> case checkOpPresence v of+    OpPresent -> OpPresent+    OpAbsent -> OpAbsent+  STBigMap _ v -> case checkOpPresence v of+    OpPresent -> OpPresent+    OpAbsent -> OpAbsent++-- | Check at runtime whether the given type contains 'TBigMap'.+checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty+checkBigMapPresence = \case+  -- More boilerplate to boilerplate god.+  STc _ -> BigMapAbsent+  STKey -> BigMapAbsent+  STSignature -> 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 t -> case checkBigMapPresence t of+    BigMapPresent -> BigMapPresent+    BigMapAbsent -> BigMapAbsent+  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++-- | Check at runtime that the given type does not contain 'TOperation'.+opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)+opAbsense s = case checkOpPresence s of+  OpPresent -> Nothing+  OpAbsent -> Just Dict++-- | Check at runtime that the given type does not containt 'TBigMap'+bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)+bigMapAbsense s = case checkBigMapPresence s of+  BigMapPresent -> Nothing+  BigMapAbsent -> Just Dict++-- | Check at runtime that the given type optionally has bigmap+--   only on the left of its toplevel pair, which is actuall constraint for+--   bigmap appearance in the storage+bigMapConstrained :: Sing (t :: T) -> Maybe (Dict $ BigMapConstraint t)+bigMapConstrained = \case+  -- Yet another bunch of boilerplate+  -- We have to make pattern matching on first argument of STPair+  -- to prove, that BigMap appears only on its leftmost position,+  -- and also make pattern matching on all Sing constructors+  -- to prove that TPair appears only in STPair+  STPair (STBigMap _ v) b ->+    case (bigMapAbsense v, bigMapAbsense b) of+      (Just Dict, Just Dict) -> Just Dict+      _ -> Nothing+  STPair (STc _) b -> case bigMapAbsense b of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STPair STKey b -> case bigMapAbsense b of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STPair STUnit b -> case bigMapAbsense b of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STPair STSignature b -> case bigMapAbsense b of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STPair (STOption a) b -> case (bigMapAbsense a, bigMapAbsense b) of+    (Just Dict, Just Dict) -> Just Dict+    _ -> Nothing+  STPair (STList a) b -> case (bigMapAbsense a, bigMapAbsense b) of+    (Just Dict, Just Dict) -> Just Dict+    _ -> Nothing+  STPair (STSet _) b -> case bigMapAbsense b of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STPair STOperation b ->  case bigMapAbsense b of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STPair (STContract a) b -> case (bigMapAbsense a, bigMapAbsense b) of+    (Just Dict, Just Dict) -> Just Dict+    _ -> Nothing+  STPair (STPair a b) c ->+    case (bigMapAbsense a, bigMapAbsense b, bigMapAbsense c) of+      (Just Dict, Just Dict, Just Dict) -> Just Dict+      _ -> Nothing+  STPair (STOr a b) c ->+    case (bigMapAbsense a, bigMapAbsense b, bigMapAbsense c) of+      (Just Dict, Just Dict, Just Dict) -> Just Dict+      _ -> Nothing+  STPair (STLambda _ _) c ->+    case bigMapAbsense c of+      Just Dict -> Just Dict+      Nothing -> Nothing+  STPair (STMap _ v) b -> case (bigMapAbsense v, bigMapAbsense b) of+    (Just Dict, Just Dict) -> Just Dict+    _ -> Nothing+  STc _ -> Just Dict+  STKey -> Just Dict+  STSignature -> Just Dict+  STUnit -> Just Dict+  STOption t -> case bigMapAbsense t of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STList t -> case bigMapAbsense t of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STSet _ -> Just Dict+  STOperation -> Just Dict+  STContract t -> case bigMapAbsense t of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STOr a b -> case (bigMapAbsense a, bigMapAbsense b) of+    (Just Dict, Just Dict) -> Just Dict+    _ -> Nothing+  STLambda _ _ -> Just Dict+  STMap _ v -> case bigMapAbsense v of+    Just Dict -> Just Dict+    Nothing -> Nothing+  STBigMap _ _ -> Nothing
src/Michelson/Typed/Sing.hs view
@@ -9,8 +9,7 @@ -- 'Converge', not provided in instances generated by TH.  module Michelson.Typed.Sing-  (-    Sing (..)+  ( Sing (..)   , withSomeSingT   , withSomeSingCT   , fromSingT@@ -18,7 +17,7 @@   ) where  import Data.Kind (Type)-import Data.Singletons (Sing(..), SingI(..))+import Data.Singletons (Sing(..), SingI(..), SingKind(..), SomeSing(..))  import Michelson.Typed.T (CT(..), T(..)) @@ -100,6 +99,11 @@ toSingCT CTimestamp = SomeSingCT SCTimestamp toSingCT CAddress = SomeSingCT SCAddress +instance SingKind CT where+  type Demote CT = CT+  fromSing  = fromSingCT+  toSing t = case toSingCT t of SomeSingCT s -> SomeSing s+ instance SingI  'CInt where   sing = SCInt instance SingI  'CNat where@@ -123,7 +127,6 @@ -- Singleton-related helpers for T -------------------------------------------- - -- | Version of 'SomeSing' with 'Typeable' constraint, -- specialized for use with 'T' kind. data SomeSingT where@@ -192,6 +195,11 @@   withSomeSingCT l $ \lSing ->   withSomeSingT r $ \rSing ->     SomeSingT $ STBigMap lSing rSing++instance SingKind T where+  type Demote T = T+  fromSing  = fromSingT+  toSing t = case toSingT t of SomeSingT s -> SomeSing s  instance (SingI t, Typeable t) => SingI ( 'Tc (t :: CT)) where   sing = STc sing
src/Michelson/Typed/T.hs view
@@ -5,14 +5,9 @@ module Michelson.Typed.T   ( CT (..)   , T (..)-  , ToCT-  , ToT   ) where -import Michelson.Untyped.Type (CT(..), ToCT)-import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp)-import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Michelson.Untyped.Type (CT(..))  -- | Michelson language type with annotations stripped off. data T =@@ -31,28 +26,3 @@   | TMap CT T   | TBigMap CT T   deriving (Eq, Show)---- | Type function that converts a regular Haskell type into a @T@ type.--- TODO: what should be done with 'TBigMap'?-type family ToT t :: T where-  ToT Integer = 'Tc (ToCT Integer)-  ToT Int = 'Tc (ToCT Int)-  ToT Natural = 'Tc (ToCT Natural)-  ToT Word64 = 'Tc (ToCT Word64)-  ToT Text = 'Tc (ToCT Text)-  ToT Bool = 'Tc (ToCT Bool)-  ToT ByteString = 'Tc (ToCT ByteString)-  ToT Mutez = 'Tc (ToCT Mutez)-  ToT Address = 'Tc (ToCT Address)-  ToT KeyHash = 'Tc (ToCT KeyHash)-  ToT Timestamp = 'Tc (ToCT Timestamp)--  ToT () = 'TUnit-  ToT (a, b) = 'TPair (ToT a) (ToT b)-  ToT [a] = 'TList (ToT a)-  ToT (Maybe a) = 'TOption (ToT a)-  ToT (Either a b) = 'TOr (ToT a) (ToT b)-  ToT (Set k) = 'TSet (ToCT k)-  ToT (Map k v) = 'TMap (ToCT k) (ToT v)-  ToT PublicKey = 'TKey-  ToT Signature = 'TSignature
src/Michelson/Typed/Value.hs view
@@ -1,31 +1,28 @@ -- | Module, containing data types for Michelson value.  module Michelson.Typed.Value-  ( Val (..)+  ( Value' (..)+  , ContractInp1   , ContractInp+  , ContractOut1   , ContractOut   , CreateAccount (..)   , CreateContract (..)-  , CVal (..)-  , Operation (..)+  , CValue (..)+  , Operation' (..)   , SetDelegate (..)   , TransferTokens (..)-  , ToVal-  , FromVal-  , toVal-  , fromVal   ) where -import qualified Data.Map.Strict as Map-import qualified Data.Set as Set import Data.Singletons (SingI) import Fmt (Buildable(build), (+|), (|+))  import Michelson.EqParam-import Michelson.Typed.CValue (CVal(..), FromCVal, ToCVal, fromCVal, toCVal)-import Michelson.Typed.T (T(..), ToT)+import Michelson.Typed.CValue (CValue(..))+import Michelson.Typed.Scope (HasNoOp)+import Michelson.Typed.T (T(..)) import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp)+import Tezos.Core (Mutez) import Tezos.Crypto (KeyHash, PublicKey, Signature)  -- | Data type, representing operation, list of which is returned@@ -33,17 +30,19 @@ -- -- These operations are to be further executed against system state -- after the contract execution.-data Operation instr where-  OpTransferTokens :: Typeable p => TransferTokens instr p -> Operation instr-  OpSetDelegate :: SetDelegate -> Operation instr-  OpCreateAccount :: CreateAccount -> Operation instr+data Operation' instr where+  OpTransferTokens+    :: (Typeable p, SingI p, HasNoOp p)+    => TransferTokens instr p -> Operation' instr+  OpSetDelegate :: SetDelegate -> Operation' instr+  OpCreateAccount :: CreateAccount -> Operation' instr   OpCreateContract     :: ( Show (instr (ContractInp cp st) (ContractOut st)), SingI cp, SingI st-       , Typeable t, Typeable cp, Typeable st)-    => CreateContract instr t cp st-    -> Operation instr+       , Typeable instr, Typeable cp, Typeable st, HasNoOp cp, HasNoOp st)+    => CreateContract instr cp st+    -> Operation' instr -instance Buildable (Operation instr) where+instance Buildable (Operation' instr) where   build =     \case       OpTransferTokens tt -> build tt@@ -51,8 +50,8 @@       OpCreateAccount ca -> build ca       OpCreateContract cc -> build cc -deriving instance Show (Operation instr)-instance Eq (Operation instr) where+deriving instance Show (Operation' instr)+instance Eq (Operation' instr) where   op1 == op2 = case (op1, op2) of     (OpTransferTokens tt1, OpTransferTokens tt2) -> eqParam1 tt1 tt2     (OpTransferTokens _, _) -> False@@ -64,9 +63,9 @@     (OpCreateContract _, _) -> False  data TransferTokens instr p = TransferTokens-  { ttContractParameter :: !(Val instr p)+  { ttContractParameter :: !(Value' instr p)   , ttAmount :: !Mutez-  , ttContract :: !(Val instr ('TContract p))+  , ttContract :: !(Value' instr ('TContract p))   } deriving (Show, Eq)  instance Buildable (TransferTokens instr p) where@@ -97,7 +96,7 @@     ", spendable: " +| caSpendable |+     " and balance = " +| caBalance |+ "" -data CreateContract instr t cp st+data CreateContract instr cp st   = ( Show (instr (ContractInp cp st) (ContractOut st))     , Eq (instr (ContractInp cp st) (ContractOut st))     )@@ -107,11 +106,11 @@   , ccSpendable :: !Bool   , ccDelegatable :: !Bool   , ccBalance :: !Mutez-  , ccStorageVal :: !(Val instr t)+  , ccStorageVal :: !(Value' instr st)   , ccContractCode :: !(instr (ContractInp cp st) (ContractOut st))   } -instance Buildable (CreateContract instr t cp st) where+instance Buildable (CreateContract instr cp st) where   build CreateContract {..} =     "Create a new contract with manager " +| ccManager |+     " and delegate " +| maybe "<nobody>" build ccDelegate |+@@ -119,174 +118,54 @@     ", delegatable: " +| ccDelegatable |+     " and balance = " +| ccBalance |+ "" -deriving instance Show (CreateContract instr t cp st)-deriving instance Eq (CreateContract instr t cp st)+deriving instance Show (CreateContract instr cp st)+deriving instance Eq (CreateContract instr cp st) -type ContractInp param st = '[ 'TPair param st ]-type ContractOut st = '[ 'TPair ('TList 'TOperation) st ]+type ContractInp1 param st = 'TPair param st+type ContractInp param st = '[ ContractInp1 param st ] +type ContractOut1 st = 'TPair ('TList 'TOperation) st+type ContractOut st = '[ ContractOut1 st ]+ -- | Representation of Michelson value. -- -- Type parameter @instr@ stands for Michelson instruction -- type, i.e. data type to represent an instruction of language.-data Val instr t where-  VC :: CVal t -> Val instr ('Tc t)-  VKey :: PublicKey -> Val instr 'TKey-  VUnit :: Val instr 'TUnit-  VSignature :: Signature -> Val instr 'TSignature-  VOption :: Maybe (Val instr t) -> Val instr ('TOption t)-  VList :: [Val instr t] -> Val instr ('TList t)-  VSet :: Set (CVal t) -> Val instr ('TSet t)-  VOp :: Operation instr -> Val instr 'TOperation-  VContract :: Address -> Val instr ('TContract p)-  VPair :: (Val instr l, Val instr r) -> Val instr ('TPair l r)-  VOr :: Either (Val instr l) (Val instr r) -> Val instr ('TOr l r)++data Value' instr t where+  VC :: CValue t -> Value' instr ('Tc t)+  VKey :: PublicKey -> Value' instr 'TKey+  VUnit :: Value' instr 'TUnit+  VSignature :: Signature -> Value' instr 'TSignature+  VOption :: forall t instr. Maybe (Value' instr t) -> Value' instr ('TOption t)+  VList :: forall t instr. [Value' instr t] -> Value' instr ('TList t)+  VSet :: forall t instr. Set (CValue t) -> Value' instr ('TSet t)+  VOp :: Operation' instr -> Value' instr 'TOperation+  VContract :: forall p instr. Address -> Value' instr ('TContract p)+  VPair :: forall l r instr. (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)+  VOr :: forall l r instr. Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)   VLam-    :: ( Show (instr '[inp] '[out])+    :: forall inp out instr.+       ( Show (instr '[inp] '[out])        , Eq (instr '[inp] '[out])        )-    => instr (inp ': '[]) (out ': '[]) -> Val instr ('TLambda inp out)-  VMap :: Map (CVal k) (Val instr v) -> Val instr ('TMap k v)-  VBigMap :: Map (CVal k) (Val instr v) -> Val instr ('TBigMap k v)+    => instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out)+  VMap :: forall k v instr. Map (CValue k) (Value' instr v) -> Value' instr ('TMap k v)+  VBigMap :: forall k v instr. Map (CValue k) (Value' instr v) -> Value' instr ('TBigMap k v) -deriving instance Show (Val instr t)-deriving instance Eq (Val instr t)+deriving instance Show (Value' instr t)+deriving instance Eq (Value' instr t)  -- TODO: actually we should handle big maps with something close -- to following: -----  VBigMap :: BigMap op ref k v -> Val cp ('TBigMap k v)+--  VBigMap :: BigMap op ref k v -> Value' cp ('TBigMap k v) ----- data ValueOp v+-- data Value'Op v --     = New v --     | Upd v --     | Rem --     | NotExisted -- -- data BigMap op ref k v = BigMap---  { bmRef :: ref k v, bmChanges :: Map (CVal k) (ValueOp (Val cp v)) }----- | Converts a complex Haskell structure into @Val@ representation.-class ToVal a where-  toVal :: a -> Val instr (ToT a)---- | Converts a @Val@ value into complex Haskell type.-class FromVal t where-  fromVal :: Val instr (ToT t) -> t---- ToVal / FromVal instances---- @gromak: we can write the following code instead of these--- instances below, but I am not sure whether it's a good idea.--- Note: if it breaks compilation for you, try to clean and--- rebuild from scratch. It seems to compile fine.--- instance {-# OVERLAPPABLE #-} ('Tc (ToCT t) ~ ToT t, FromCVal t) => FromVal t where---   fromVal (VC cval) = fromCVal cval--instance FromVal Integer where-  fromVal (VC cval) = fromCVal cval--instance FromVal Natural where-  fromVal (VC cval) = fromCVal cval--instance FromVal Text where-  fromVal (VC cval) = fromCVal cval--instance FromVal Bool where-  fromVal (VC cval) = fromCVal cval--instance FromVal ByteString where-  fromVal (VC cval) = fromCVal cval--instance FromVal Mutez where-  fromVal (VC cval) = fromCVal cval--instance FromVal KeyHash where-  fromVal (VC cval) = fromCVal cval--instance FromVal Timestamp where-  fromVal (VC cval) = fromCVal cval--instance FromVal Address where-  fromVal (VC cval) = fromCVal cval--instance FromVal () where-  fromVal VUnit = ()--instance FromVal a => FromVal [a] where-  fromVal (VList lVals) = map fromVal lVals--instance FromVal a => FromVal (Maybe a) where-  fromVal (VOption Nothing) = Nothing-  fromVal (VOption (Just val)) = Just $ fromVal val--instance (FromVal a, FromVal b) => FromVal (Either a b) where-  fromVal (VOr (Left l)) = Left $ fromVal l-  fromVal (VOr (Right r)) = Right $ fromVal r--instance (FromVal a, FromVal b) => FromVal (a, b) where-  fromVal (VPair (a, b)) = (fromVal a, fromVal b)--instance (Ord k, FromCVal k) => FromVal (Set k) where-  fromVal (VSet s) = Set.map fromCVal s--instance (Ord k, FromCVal k, FromVal a) => FromVal (Map k a) where-  fromVal (VMap m) = Map.map fromVal $ Map.mapKeys fromCVal m--instance ToVal () where-  toVal _ = VUnit--instance ToVal Integer where-  toVal = VC . toCVal--instance ToVal Int where-  toVal = VC . toCVal--instance ToVal Word64 where-  toVal = VC . toCVal--instance ToVal Natural where-  toVal = VC . toCVal--instance ToVal Text where-  toVal = VC . toCVal--instance ToVal ByteString where-  toVal = VC . toCVal--instance ToVal Bool where-  toVal = VC . toCVal--instance ToVal Mutez where-  toVal = VC . toCVal--instance ToVal KeyHash where-  toVal = VC . toCVal--instance ToVal Timestamp where-  toVal = VC . toCVal--instance ToVal Address where-  toVal = VC . toCVal--instance ToVal a => ToVal (Maybe a) where-  toVal Nothing = VOption Nothing-  toVal (Just a) = VOption (Just $ toVal a)--instance (ToVal a, ToVal b) => ToVal (Either a b) where-  toVal (Left l) = VOr $ Left $ toVal l-  toVal (Right r) = VOr $ Right $ toVal r--instance (ToVal a, ToVal b) => ToVal (a, b) where-  toVal (l, r) = VPair (toVal l, toVal r)--instance ToVal x => ToVal [x] where-  toVal = VList . map toVal--instance ToCVal k => ToVal (Set k) where-  toVal = VSet . Set.map toCVal---- Note: the instance produces Map not BigMap-instance (ToCVal k, ToVal a) => ToVal (Map k a) where-  toVal = VMap . Map.mapKeys toCVal . Map.map toVal+--  { bmRef :: ref k v, bmChanges :: Map (CValue k) (Value'Op (Value' cp v)) }
src/Michelson/Untyped.hs view
@@ -5,6 +5,7 @@ import Michelson.Untyped.Aliases as Exports import Michelson.Untyped.Annotation as Exports import Michelson.Untyped.Contract as Exports+import Michelson.Untyped.Ext as Exports import Michelson.Untyped.Instr as Exports import Michelson.Untyped.Type as Exports import Michelson.Untyped.Value as Exports
src/Michelson/Untyped/Aliases.hs view
@@ -1,13 +1,16 @@ -- | Some simple aliases for Michelson types.  module Michelson.Untyped.Aliases-  ( UntypedContract-  , UntypedValue+  ( Contract+  , Value+  , ExpandedExtInstr   ) where +import qualified Michelson.Untyped.Contract as Untyped+import qualified Michelson.Untyped.Ext as Untyped import qualified Michelson.Untyped.Instr as Untyped import qualified Michelson.Untyped.Value as Untyped-import qualified Michelson.Untyped.Contract as Untyped -type UntypedValue = Untyped.Value Untyped.ExpandedOp-type UntypedContract = Untyped.Contract Untyped.ExpandedOp+type Value = Untyped.Value' Untyped.ExpandedOp+type Contract = Untyped.Contract' Untyped.ExpandedOp+type ExpandedExtInstr = Untyped.ExtInstrAbstract Untyped.ExpandedOp
src/Michelson/Untyped/Annotation.hs view
@@ -8,6 +8,7 @@   , TypeAnn   , FieldAnn   , VarAnn+  , RenderAnn (..)   , noAnn   , ann   , unifyAnn@@ -50,7 +51,6 @@ type FieldAnn = Annotation FieldTag type VarAnn = Annotation VarTag - instance RenderDoc TypeAnn where   renderDoc = renderAnnotation ":" @@ -60,10 +60,33 @@ instance RenderDoc VarAnn where   renderDoc = renderAnnotation "@" ++-- | Typeclass for printing annotations, @renderAnn@+-- prints empty prefix in case of @noAnn@.+--+-- Such functionality is required in case when instruction+-- has two annotations of the same type, former is empty+-- and the latter is not. So that `PAIR noAnn noAnn noAnn %kek`+-- is printed as `PAIR % %kek`+class RenderAnn t where+  renderAnn :: t -> Doc++instance RenderAnn TypeAnn where+  renderAnn = renderWithEmptyAnnotation ":"++instance RenderAnn FieldAnn where+  renderAnn = renderWithEmptyAnnotation "%"++instance RenderAnn VarAnn where+  renderAnn = renderWithEmptyAnnotation "@"+ renderAnnotation :: Doc -> Annotation tag -> Doc renderAnnotation prefix a@(Annotation text)   | a == noAnn = ""   | otherwise = prefix <> (textStrict text)++renderWithEmptyAnnotation :: Doc -> Annotation tag -> Doc+renderWithEmptyAnnotation prefix (Annotation text) = prefix <> (textStrict text)  instance Buildable TypeAnn where   build = buildRenderDoc
src/Michelson/Untyped/Contract.hs view
@@ -5,7 +5,7 @@ module Michelson.Untyped.Contract   ( Parameter   , Storage-  , Contract (..)+  , Contract' (..)   ) where  import Data.Aeson.TH (defaultOptions, deriveJSON)@@ -18,19 +18,19 @@  type Parameter = Type type Storage = Type-data Contract op = Contract+data Contract' op = Contract   { para :: Parameter   , stor :: Storage   , code :: [op]   } deriving stock (Eq, Show, Functor, Data, Generic) -instance (RenderDoc op) => RenderDoc (Contract op) where+instance (RenderDoc op) => RenderDoc (Contract' op) where   renderDoc (Contract parameter storage code) =     "parameter" <+> renderDoc parameter  <> semi <$$>     "storage"   <+> renderDoc storage    <> semi <$$>     "code"      <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi) -instance RenderDoc op => Buildable (Contract op) where+instance RenderDoc op => Buildable (Contract' op) where   build = buildRenderDoc -deriveJSON defaultOptions ''Contract+deriveJSON defaultOptions ''Contract'
+ src/Michelson/Untyped/Ext.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++module Michelson.Untyped.Ext+  ( ExtInstrAbstract (..)+  , StackRef (..)+  , PrintComment (..)+  , TestAssert (..)+  , Var (..)+  , TyVar (..)+  , StackTypePattern (..)+  , StackFn (..)+  , varSet+  , stackTypePatternToList+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Fmt (Buildable(build), Builder, genericF, listF)++import Michelson.Printer.Util (RenderDoc(..), renderOpsList)+import Michelson.Untyped.Type++-- | Implementation-specific instructions embedded in a @NOP@ primitive, which+-- mark a specific point during a contract's typechecking or execution.+--+-- These instructions are not allowed to modify the contract's stack, but may+-- impose additional constraints that can cause a contract to report errors in+-- type-checking or testing.+--+-- 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 =+    STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern+  | FN T.Text StackFn [op]     -- ^ A typed stack function (push and pop a @TcExtFrame@)+  | UTEST_ASSERT (TestAssert op)   -- ^ Copy the current stack and run an inline assertion on it+  | UPRINT PrintComment         -- ^ Print a comment with optional embedded @StackRef@s+  deriving (Eq, Show, Data, Generic, Functor)++instance RenderDoc op => RenderDoc (ExtInstrAbstract op) where+  renderDoc =+    \case+      FN _ _ ops -> renderOpsList True ops+      _ -> mempty+  isRenderable =+    \case+      FN {} -> True+      _ -> False++instance Buildable op => Buildable (ExtInstrAbstract op) where+  build = genericF++-- | A reference into the stack.+newtype StackRef = StackRef Natural+  deriving (Eq, Show, Data, Generic)++instance Buildable StackRef where+  build (StackRef i) = "%[" <> show i <> "]"++newtype Var = Var T.Text deriving (Eq, Show, Ord, Data, Generic)++instance Buildable Var where+  build = genericF++-- | A type-variable or a type-constant+data TyVar =+    VarID Var+  | TyCon Type+  deriving (Eq, Show, Data, Generic)++instance Buildable TyVar where+  build = genericF++-- | A stack pattern-match+data StackTypePattern+ = StkEmpty+ | StkRest+ | StkCons TyVar StackTypePattern+  deriving (Eq, Show, Data, Generic)++-- | Convert 'StackTypePattern' to a list of types. Also returns+-- 'Bool' which is 'True' if the pattern is a fixed list of types and+-- 'False' if it's a pattern match on the head of the stack.+stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)+stackTypePatternToList StkEmpty = ([], True)+stackTypePatternToList StkRest = ([], False)+stackTypePatternToList (StkCons t pat) =+  first (t :) $ stackTypePatternToList pat++instance Buildable StackTypePattern where+  build = listF . pairToList . stackTypePatternToList+    where+      pairToList :: ([TyVar], Bool) -> [Builder]+      pairToList (types, fixed)+        | fixed = map build types+        | otherwise = map build types ++ ["..."]++-- | A stack function that expresses the type signature of a @LetMacro@+data StackFn = StackFn+  { quantifiedVars :: Maybe (Set Var)+  , inPattern :: StackTypePattern+  , outPattern :: StackTypePattern+  } deriving (Eq, Show, Data, Generic)++instance Buildable StackFn where+  build = genericF++-- | Get the set of variables in a stack pattern+varSet :: StackTypePattern -> Set Var+varSet StkEmpty = Set.empty+varSet StkRest = Set.empty+varSet (StkCons (VarID v) stk) = v `Set.insert` (varSet stk)+varSet (StkCons _ stk) = varSet stk++newtype PrintComment = PrintComment+  { unUPrintComment :: [Either T.Text StackRef]+  } deriving (Eq, Show, Data, Generic)++instance Buildable PrintComment where+  build = foldMap (either build build) . unUPrintComment++-- An inline test assertion+data TestAssert op = TestAssert+  { tassName :: T.Text+  , tassComment :: PrintComment+  , tassInstrs :: [op]+  } deriving (Eq, Show, Functor, Data, Generic)++instance Buildable code => Buildable (TestAssert code) where+  build = genericF++-------------------------------------+-- Aeson instances+-------------------------------------++deriveJSON defaultOptions ''ExtInstrAbstract+deriveJSON defaultOptions ''PrintComment+deriveJSON defaultOptions ''StackTypePattern+deriveJSON defaultOptions ''StackRef+deriveJSON defaultOptions ''StackFn+deriveJSON defaultOptions ''Var+deriveJSON defaultOptions ''TyVar+deriveJSON defaultOptions ''TestAssert
src/Michelson/Untyped/Instr.hs view
@@ -8,9 +8,9 @@   , Instr   , ExpandedOp (..)   , ExpandedInstr-  , ExtU   , InstrExtU   , ExpandedInstrExtU+  , flattenExpandedOp    -- * Contract's address   , OriginationOperation (..)@@ -20,16 +20,19 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as BSL import Data.Data (Data(..))-import qualified Data.Kind as K import Fmt (Buildable(build), (+|), (|+))+import Generics.SYB (everywhere, mkT) import Prelude hiding (EQ, GT, LT) import Text.PrettyPrint.Leijen.Text (braces, nest, (<$$>), (<+>)) +import Michelson.ErrorPos (InstrCallStack) import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOpsList, spaces)-import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, VarAnn)-import Michelson.Untyped.Contract (Contract(..))+import Michelson.Untyped.Annotation+  (FieldAnn, TypeAnn, VarAnn, RenderAnn(..))+import Michelson.Untyped.Contract (Contract'(..))+import Michelson.Untyped.Ext (ExtInstrAbstract) import Michelson.Untyped.Type (Comparable, Type)-import Michelson.Untyped.Value (Value(..))+import Michelson.Untyped.Value (Value'(..)) import Tezos.Address (Address, mkContractAddressRaw) import Tezos.Core (Mutez) import Tezos.Crypto (KeyHash)@@ -37,60 +40,78 @@ ------------------------------------- -- Flattened types after macroexpander --------------------------------------type InstrExtU = ExtU InstrAbstract Op+type InstrExtU = ExtInstrAbstract Op type Instr = InstrAbstract Op newtype Op = Op {unOp :: Instr}-  deriving stock (Generic)+  deriving stock (Show, Eq, Generic)   deriving newtype (RenderDoc, Buildable) -deriving instance Eq (ExtU InstrAbstract Op) => Eq Op-deriving instance Show (ExtU InstrAbstract Op) => Show Op- ------------------------------------- -- Types after macroexpander ------------------------------------- -type ExpandedInstrExtU = ExtU InstrAbstract ExpandedOp+type ExpandedInstrExtU = ExtInstrAbstract ExpandedOp type ExpandedInstr = InstrAbstract ExpandedOp  data ExpandedOp   = PrimEx ExpandedInstr   | SeqEx [ExpandedOp]-  deriving stock (Generic)--deriving instance Eq ExpandedInstr => Eq ExpandedOp-deriving instance Show ExpandedInstr => Show ExpandedOp-deriving instance Data ExpandedInstr => Data ExpandedOp+  | WithSrcEx InstrCallStack ExpandedOp+  deriving stock (Show, Eq, Data, Generic)  instance RenderDoc ExpandedOp where-  renderDoc (PrimEx i)  = renderDoc i-  renderDoc (SeqEx i)   = renderOpsList True i+  renderDoc (WithSrcEx _ op) = renderDoc op+  renderDoc (PrimEx i) = renderDoc i+  renderDoc (SeqEx i)    = renderOpsList True i   isRenderable =     \case PrimEx i -> isRenderable i+          WithSrcEx _ op -> isRenderable op           _ -> True  instance Buildable ExpandedOp where+  build (WithSrcEx _ op) = build op   build (PrimEx expandedInstr) = "<PrimEx: "+|expandedInstr|+">"   build (SeqEx expandedOps)    = "<SeqEx: "+|expandedOps|+">" +-- | Flatten all 'SeqEx' in 'ExpandedOp'. This function is mostly for+-- testing. It returns instructions with the same logic, but they are+-- not strictly equivalent, because they are serialized differently+-- (grouping instructions into sequences affects the way they are+-- PACK'ed).+--+-- Note: it does not return a list of 'Instr' because this type is not+-- used anywhere and should probably be removed.+flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]+flattenExpandedOp =+  \case+    PrimEx i -> [flattenInstr i]+    SeqEx ops -> concatMap flattenExpandedOp ops+    WithSrcEx _ op -> flattenExpandedOp op+  where+    flattenInstr :: ExpandedInstr -> ExpandedInstr+    flattenInstr = everywhere (mkT flattenOps)++    flattenOps :: [ExpandedOp] -> [ExpandedOp]+    flattenOps [] = []+    flattenOps (SeqEx s : xs) = s ++ flattenOps xs+    flattenOps (x@(PrimEx _) : xs) = x : flattenOps xs+    flattenOps (WithSrcEx _ op : xs) = op : flattenOps xs+ ------------------------------------- -- Abstract instruction ------------------------------------- --- | ExtU is extension of InstrAbstract by Morley instructions-type family ExtU (instr :: K.Type -> K.Type) :: K.Type -> K.Type- -- | 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               (ExtU InstrAbstract op)+  = EXT               (ExtInstrAbstract op)   | DROP   | DUP               VarAnn   | SWAP-  | PUSH              VarAnn Type (Value op)+  | PUSH              VarAnn Type (Value' op)   | SOME              TypeAnn VarAnn FieldAnn   | NONE              TypeAnn VarAnn FieldAnn Type   | UNIT              TypeAnn VarAnn@@ -101,7 +122,6 @@   | LEFT              TypeAnn VarAnn FieldAnn FieldAnn Type   | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Type   | IF_LEFT           [op] [op]-  | IF_RIGHT          [op] [op]   | NIL               TypeAnn VarAnn Type   | CONS              VarAnn -- TODO add TypeNote param   | IF_CONS           [op] [op]@@ -154,8 +174,7 @@   | TRANSFER_TOKENS   VarAnn   | SET_DELEGATE      VarAnn   | CREATE_ACCOUNT    VarAnn VarAnn-  | CREATE_CONTRACT   VarAnn VarAnn-  | CREATE_CONTRACT2  VarAnn VarAnn (Contract op)+  | CREATE_CONTRACT   VarAnn VarAnn (Contract' op)   | IMPLICIT_ACCOUNT  VarAnn   | NOW               VarAnn   | AMOUNT            VarAnn@@ -169,16 +188,11 @@   | SOURCE            VarAnn   | SENDER            VarAnn   | ADDRESS           VarAnn-  deriving (Generic)--deriving instance (Eq op, Eq (ExtU InstrAbstract op)) => Eq (InstrAbstract op)-deriving instance (Show op, Show (ExtU InstrAbstract op)) => Show (InstrAbstract op)-deriving instance Functor (ExtU InstrAbstract) => Functor InstrAbstract-deriving instance (Data op, Data (ExtU InstrAbstract op)) => Data (InstrAbstract op)+  deriving (Eq, Show, Functor, Data, Generic)  instance (RenderDoc op) => RenderDoc (InstrAbstract op) where   renderDoc = \case-    EXT _                 -> ""+    EXT extInstr          -> renderDoc extInstr     DROP                  -> "DROP"     DUP va                -> "DUP" <+> renderDoc va     SWAP                  -> "SWAP"@@ -187,13 +201,12 @@     NONE ta va fa t       -> "NONE" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa <+> renderDoc t     UNIT ta va            -> "UNIT" <+> renderDoc ta <+> renderDoc va     IF_NONE x y           -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)-    PAIR ta va fa1 fa2    -> "PAIR" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2+    PAIR ta va fa1 fa2    -> "PAIR" <+> renderDoc ta <+> renderDoc va <+> renderAnn fa1 <+> renderAnn fa2     CAR va fa             -> "CAR" <+> renderDoc va <+> renderDoc fa     CDR va fa             -> "CDR" <+> renderDoc va <+> renderDoc fa-    LEFT ta va fa1 fa2 t  -> "LEFT" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2 <+> renderDoc t-    RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2 <+> renderDoc t+    LEFT ta va fa1 fa2 t  -> "LEFT" <+> renderDoc ta <+> renderDoc va <+> renderAnn fa1 <+> renderAnn fa2 <+> renderDoc t+    RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderDoc ta <+> renderDoc va <+> renderAnn fa1 <+> renderAnn fa2 <+> renderDoc t     IF_LEFT x y           -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)-    IF_RIGHT x y          -> "IF_RIGHT" <+> nest 10 (renderOps x) <$$> spaces 9 <> nest 10 (renderOps y)     NIL ta va t           -> "NIL" <+> renderDoc ta <+> renderDoc va <+> renderDoc t     CONS va               -> "CONS" <+> renderDoc va     IF_CONS x y           -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)@@ -243,9 +256,9 @@     CONTRACT va t         -> "CONTRACT" <+> renderDoc va <+> renderDoc t     TRANSFER_TOKENS va    -> "TRANSFER_TOKENS" <+> renderDoc va     SET_DELEGATE va       -> "SET_DELEGATE" <+> renderDoc va-    CREATE_ACCOUNT va1 va2  -> "CREATE_ACCOUNT" <+> renderDoc va1 <+> renderDoc va2-    CREATE_CONTRACT va1 va2 -> "CREATE_CONTRACT" <+> renderDoc va1 <+> renderDoc va2-    CREATE_CONTRACT2 va1 va2 contract -> "CREATE_CONTRACT" <+> renderDoc va1 <+> renderDoc va2 <$$> braces (renderDoc contract)+    CREATE_ACCOUNT va1 va2  -> "CREATE_ACCOUNT" <+> renderAnn va1 <+> renderAnn va2+    CREATE_CONTRACT va1 va2 contract ->+      "CREATE_CONTRACT" <+> renderAnn va1 <+> renderAnn va2 <$$> braces (renderDoc contract)     IMPLICIT_ACCOUNT va   -> "IMPLICIT_ACCOUNT" <+> renderDoc va     NOW va                -> "NOW" <+> renderDoc va     AMOUNT va             -> "AMOUNT" <+> renderDoc va@@ -263,11 +276,13 @@       renderOps = renderOpsList True    isRenderable = \case-    EXT {} -> False+    EXT extInstr -> isRenderable extInstr     _ -> True -instance (RenderDoc op) => Buildable (InstrAbstract op) where-  build = buildRenderDoc+instance (RenderDoc op, Buildable op) => Buildable (InstrAbstract op) where+  build = \case+    EXT ext -> build ext+    mi -> buildRenderDoc mi  ---------------------------------------------------------------------------- -- Contract's address computation@@ -289,31 +304,29 @@   -- ^ Whether the contract is delegatable.   , ooBalance :: !Mutez   -- ^ Initial balance of the contract.-  , ooStorage :: !(Value ExpandedOp)+  , ooStorage :: !(Value' ExpandedOp)   -- ^ Initial storage value of the contract.-  , ooContract :: !(Contract ExpandedOp)+  , ooContract :: !(Contract' ExpandedOp)   -- ^ The contract itself.-  } deriving (Generic)--deriving instance Show ExpandedInstrExtU => Show OriginationOperation+  } deriving (Show, Generic)  -- | Compute address of a contract from its origination operation. -- -- TODO [TM-62] It's certainly imprecise, real Tezos implementation doesn't -- use JSON, but we don't need precise format yet, so we just use some -- serialization format (JSON because we have necessary instances already).-mkContractAddress :: Aeson.ToJSON ExpandedInstrExtU => OriginationOperation -> Address+mkContractAddress :: OriginationOperation -> Address mkContractAddress = mkContractAddressRaw . BSL.toStrict . Aeson.encode  ---------------------------------------------------------------------------- -- JSON serialization ---------------------------------------------------------------------------- -instance Aeson.ToJSON Instr => Aeson.ToJSON Op-instance Aeson.FromJSON Instr => Aeson.FromJSON Op-instance Aeson.ToJSON ExpandedInstr => Aeson.ToJSON ExpandedOp-instance Aeson.FromJSON ExpandedInstr => Aeson.FromJSON ExpandedOp-instance (Aeson.ToJSON op, Aeson.ToJSON (ExtU InstrAbstract op)) => Aeson.ToJSON (InstrAbstract op)-instance (Aeson.FromJSON op, Aeson.FromJSON (ExtU InstrAbstract op)) => Aeson.FromJSON (InstrAbstract op)-instance Aeson.FromJSON ExpandedOp => Aeson.FromJSON OriginationOperation-instance Aeson.ToJSON ExpandedOp => Aeson.ToJSON OriginationOperation+instance Aeson.ToJSON Op+instance Aeson.FromJSON Op+instance Aeson.ToJSON ExpandedOp+instance Aeson.FromJSON ExpandedOp+instance Aeson.ToJSON op => Aeson.ToJSON (InstrAbstract op)+instance Aeson.FromJSON op => Aeson.FromJSON (InstrAbstract op)+instance Aeson.FromJSON OriginationOperation+instance Aeson.ToJSON OriginationOperation
src/Michelson/Untyped/Type.hs view
@@ -9,7 +9,6 @@   , typeToComp   , T (..)   , CT (..)-  , ToCT   , pattern Tint   , pattern Tnat   , pattern Tstring@@ -50,12 +49,14 @@  import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, wrapInParens) import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, TypeAnn)-import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp)-import Tezos.Crypto (KeyHash)  -- Annotated type-data Type = Type T TypeAnn+data Type+  = Type T TypeAnn+  | TypeParameter+  -- ^ Implicit Parameter type which can be used in contract code+  | TypeStorage+  -- ^ Implicit Storage type which can be used in contract code   deriving (Eq, Show, Data, Generic)  instance RenderDoc Comparable where@@ -63,6 +64,8 @@  instance RenderDoc Type where   renderDoc (Type t ta) = renderType t (Just ta) Nothing+  renderDoc TypeParameter = "Parameter"+  renderDoc TypeStorage = "Storage"  instance RenderDoc T where   renderDoc t = renderType t Nothing Nothing@@ -77,7 +80,12 @@ renderType :: T -> Maybe TypeAnn -> Maybe FieldAnn -> Doc renderType t mta mfa =   let rta = case mta of Just ta -> renderDoc ta; Nothing -> ""-      rfa = case mfa of Just fa -> renderDoc fa; Nothing -> "" in+      rfa = case mfa of Just fa -> renderDoc fa; Nothing -> ""+      renderer type_ mfa' =+        case type_ of+          Type tt ta -> renderType tt (Just ta) mfa'+          tt -> renderDoc tt+  in   case t of     Tc ct             -> wrapInParens $ renderDoc ct :| [rta, rfa]     TKey              -> wrapInParens $ "key"  :| [rta, rfa]@@ -87,34 +95,38 @@     TOption fa1 (Type t1 ta1) ->       parens ("option" <+> rta <+> rfa               <+> renderType t1 (Just ta1) (Just fa1))+    TOption _fa1 t1 ->+      parens ("option" <+> rta <+> rfa <+> renderDoc t1)     TList (Type t1 ta1)       -> parens ("list" <+> rta <+> rfa <+> renderType t1 (Just ta1) Nothing)+    TList t1                  -> parens ("list" <+> rta <+> rfa <+> renderDoc t1)     TSet (Comparable ct1 ta1) -> parens ("set" <+> rta <+> rfa <+> renderType (Tc ct1) (Just ta1) Nothing)     TContract (Type t1 ta1)   -> parens ("contract" <+> rta <+> rfa <+> renderType t1 (Just ta1) Nothing)+    TContract t1              -> parens ("contract" <+> rta <+> rfa <+> renderDoc t1) -    TPair fa1 fa2 (Type t1 ta1) (Type t2 ta2) ->+    TPair fa1 fa2 t1 t2 ->       parens ("pair" <+> rta <+> rfa-              <+> (renderType t1 (Just ta1) (Just fa1))-              <+> (renderType t2 (Just ta2) (Just fa2)))+              <+> renderer t1 (Just fa1)+              <+> renderer t2 (Just fa2)) -    TOr fa1 fa2 (Type t1 ta1) (Type t2 ta2) ->+    TOr fa1 fa2 t1 t2 ->       parens ("or" <+> rta <+> rfa-              <+> (renderType t1 (Just ta1) (Just fa1))-              <+> (renderType t2 (Just ta2) (Just fa2)))+              <+> renderer t1 (Just fa1)+              <+> renderer t2 (Just fa2)) -    TLambda (Type t1 ta1) (Type t2 ta2) ->+    TLambda t1 t2 ->       parens ("lambda" <+> rta <+> rfa-              <+> (renderType t1 (Just ta1) Nothing)-              <+> (renderType t2 (Just ta2) Nothing))+             <+> renderer t1 Nothing+             <+> renderer t2 Nothing) -    TMap (Comparable ct1 ta1) (Type t2 ta2) ->+    TMap (Comparable ct1 ta1) t2 ->       parens ("map" <+> rta <+> rfa               <+> (renderType (Tc ct1) (Just ta1) Nothing)-              <+> (renderType t2 (Just ta2) Nothing))+              <+> renderer t2 Nothing) -    TBigMap (Comparable ct1 ta1) (Type t2 ta2) ->+    TBigMap (Comparable ct1 ta1) t2 ->       parens ("big_map" <+> rta <+> rfa               <+> (renderType (Tc ct1) (Just ta1) Nothing)-              <+> (renderType t2 (Just ta2) Nothing))+              <+> renderer t2 Nothing)  instance RenderDoc CT where   renderDoc = \case@@ -178,21 +190,6 @@   | CTimestamp   | CAddress   deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic)---- | Type function that converts a regular Haskell type into a comparable type--- (which has kind @CT@)-type family ToCT a :: CT where-  ToCT Integer = 'CInt-  ToCT Int = 'CInt-  ToCT Natural = 'CNat-  ToCT Word64 = 'CNat-  ToCT Text = 'CString-  ToCT Bool = 'CBool-  ToCT ByteString = 'CBytes-  ToCT Mutez = 'CMutez-  ToCT Address = 'CAddress-  ToCT KeyHash = 'CKeyHash-  ToCT Timestamp = 'CTimestamp  instance Buildable CT where   build = buildRenderDoc
src/Michelson/Untyped/Value.hs view
@@ -3,44 +3,44 @@ -- | Untyped Michelson values (i. e. type of a value is not statically known).  module Michelson.Untyped.Value-  ( Value (..)+  ( Value' (..)   , Elt (..)   -- Internal types to avoid orphan instances   , InternalByteString(..)   , unInternalByteString   ) where -import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson (FromJSON(..), ToJSON(..), withText) import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.Data (Data(..))-import qualified Data.List as L import Formatting.Buildable (Buildable(build))-import Text.Hex (encodeHex)+import Text.Hex (decodeHex, encodeHex) import Text.PrettyPrint.Leijen.Text (braces, dquotes, parens, semi, text, textStrict, (<+>))  import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOps)+import Michelson.Text -data Value op =+data Value' op =     ValueInt     Integer-  | ValueString  Text+  | ValueString  MText   | ValueBytes   InternalByteString   | ValueUnit   | ValueTrue   | ValueFalse-  | ValuePair    (Value op) (Value op)-  | ValueLeft    (Value op)-  | ValueRight   (Value op)-  | ValueSome    (Value op)+  | ValuePair    (Value' op) (Value' op)+  | ValueLeft    (Value' op)+  | ValueRight   (Value' op)+  | ValueSome    (Value' op)   | ValueNone   | ValueNil-  | ValueSeq     (NonEmpty $ Value op)+  | ValueSeq     (NonEmpty $ Value' op)   -- ^ A sequence of elements: can be a list or a set.   -- We can't distinguish lists and sets during parsing.   | ValueMap     (NonEmpty $ Elt op)   | ValueLambda  (NonEmpty op)   deriving stock (Eq, Show, Functor, Data, Generic) -data Elt op = Elt (Value op) (Value op)+data Elt op = Elt (Value' op) (Value' op)   deriving stock (Eq, Show, Functor, Data, Generic)  -- | ByteString does not have an instance for ToJSON and FromJSON, to@@ -51,12 +51,12 @@ unInternalByteString :: InternalByteString -> ByteString unInternalByteString (InternalByteString bs) = bs -instance RenderDoc op => RenderDoc (Value op) where+instance RenderDoc op => RenderDoc (Value' op) where   renderDoc =     \case       ValueNil       -> "{ }"       ValueInt x     -> text . show $ x-      ValueString x  -> dquotes (textStrict x)+      ValueString x  -> dquotes (textStrict $ writeMText x)       ValueBytes xs  -> "0x" <> (textStrict . encodeHex . unInternalByteString $ xs)       ValueUnit      -> "Unit"       ValueTrue      -> "True"@@ -66,14 +66,14 @@       ValueRight r   -> parens $ ("Right" <+> renderDoc r)       ValueSome x    -> parens $ ("Some"  <+> renderDoc x)       ValueNone      -> "None"-      ValueSeq xs    -> braces $ mconcat $ (L.intersperse semi (renderDoc <$> toList xs))-      ValueMap xs    -> braces $ mconcat $ (L.intersperse semi (renderDoc <$> toList xs))+      ValueSeq xs    -> braces $ mconcat $ (intersperse semi (renderDoc <$> toList xs))+      ValueMap xs    -> braces $ mconcat $ (intersperse semi (renderDoc <$> toList xs))       ValueLambda xs -> renderOps True xs  instance RenderDoc op => RenderDoc (Elt op) where   renderDoc (Elt k v) = "Elt" <+> renderDoc k <+> renderDoc v -instance (RenderDoc op) => Buildable (Value op) where+instance (RenderDoc op) => Buildable (Value' op) where   build = buildRenderDoc  instance (RenderDoc op) => Buildable (Elt op) where@@ -87,10 +87,14 @@ -- ByteString does not have a ToJSON or FromJSON instance  instance ToJSON InternalByteString where-  toJSON = toJSON @Text . decodeUtf8 . unInternalByteString+  toJSON = toJSON . encodeHex . unInternalByteString  instance FromJSON InternalByteString where-  parseJSON = fmap (InternalByteString . encodeUtf8 @Text) . parseJSON+  parseJSON =+    withText "Hex-encoded bytestring" $ \t ->+      case decodeHex t of+        Nothing -> fail "Invalid hex encoding"+        Just res -> pure (InternalByteString res) -deriveJSON defaultOptions ''Value+deriveJSON defaultOptions ''Value' deriveJSON defaultOptions ''Elt
− src/Morley/Default.hs 
@@ -1,21 +0,0 @@-module Morley.Default-  ( permute2Def , permute3Def-  , Default (..)-  ) where--import Control.Applicative.Permutations (toPermutationWithDefault, runPermutation)-import Data.Default (def, Default)--{- Permutation Parsers -}--permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a,b)-permute2Def a b = runPermutation $-  (,) <$> toPermutationWithDefault def a-      <*> toPermutationWithDefault def b--permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) =>-                f a -> f b -> f c -> f (a,b,c)-permute3Def a b c = runPermutation $-  (,,) <$> toPermutationWithDefault def a-       <*> toPermutationWithDefault def b-       <*> toPermutationWithDefault def c
− src/Morley/Ext.hs 
@@ -1,210 +0,0 @@-module Morley.Ext-  ( interpretMorleyUntyped-  , interpretMorley-  , typeCheckMorleyContract-  , typeCheckHandler-  , interpretHandler-  ) where--import Control.Monad.Except (liftEither, throwError)-import Data.Default (def)-import Data.Map.Lazy (Map, insert, lookup)-import qualified Data.Map.Lazy as Map-import Data.Singletons (Sing)-import qualified Data.Text as T-import Data.Typeable ((:~:)(..))-import Data.Vinyl (Rec(..))--import Michelson.Interpret-  (ContractEnv, ContractReturn, EvalOp, InterpretUntypedError, InterpretUntypedResult,-  InterpreterEnv(..), InterpreterState(..), MichelsonFailed(..), SomeItStack(..), interpret,-  interpretUntyped, runInstrNoGas)-import Michelson.TypeCheck-import Michelson.TypeCheck.Helpers (convergeHST, eqT')-import Michelson.TypeCheck.Types (HST)-import Michelson.Typed (Val, converge, extractNotes, mkUType)-import qualified Michelson.Typed as T-import Michelson.Untyped (CT(..), InstrAbstract(..), UntypedContract, UntypedValue)-import Morley.Types--interpretMorleyUntyped-  :: UntypedContract-  -> UntypedValue-  -> UntypedValue-  -> ContractEnv-  -> Either (InterpretUntypedError MorleyLogs) (InterpretUntypedResult MorleyLogs)-interpretMorleyUntyped c v1 v2 cenv =-  interpretUntyped typeCheckHandler c v1 v2 (InterpreterEnv cenv interpretHandler) def--interpretMorley-  :: (Typeable cp, Typeable st)-  => T.Contract cp st-  -> Val T.Instr cp-  -> Val T.Instr st-  -> ContractEnv-  -> ContractReturn MorleyLogs st-interpretMorley c param initSt env =-  interpret c param initSt (InterpreterEnv env interpretHandler) def--typeCheckMorleyContract :: UntypedContract -> Either TCError SomeContract-typeCheckMorleyContract = typeCheckContract typeCheckHandler--typeCheckHandler :: ExpandedUExtInstr -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe ExtInstr)-typeCheckHandler ext nfs hst@(SomeHST hs) =-  case ext of-    STACKTYPE s -> fitError $ const (nfs, Nothing) <$> checkStackType noBoundVars s hs-    FN t sf     -> fitError $ (, Nothing) <$> checkFn t sf hst nfs-    FN_END      -> fitError $ const (safeTail nfs, Nothing) <$> checkFnEnd hst nfs-    UPRINT pc   -> verifyPrint pc $> (nfs, Just $ PRINT pc)-    UTEST_ASSERT UTestAssert{..} -> do-      verifyPrint tassComment-      si <- typeCheckList tassInstrs hst-      case si of-        SiFail -> thErr "TEST_ASSERT has to return Bool, but it's failed"-        instr ::: (_ :: HST inp, ((_ :: (Sing b, T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do-          Refl <- liftEither $-                    first (const $ TCOtherError "TEST_ASSERT has to return Bool, but returned something else") $-                      eqT' @b @('T.Tc 'CBool)-          pure (nfs, Just $ TEST_ASSERT $ TestAssert tassName tassComment instr)-        _ -> thErr "TEST_ASSERT has to return Bool, but the stack is empty"-  where-    lhs = lengthHST hs-    thErr = throwError . TCOtherError--    verifyPrint :: PrintComment -> TypeCheckT ()-    verifyPrint (PrintComment pc) = do-      let checkStRef (Left _) = pure ()-          checkStRef (Right (StackRef (fromIntegral -> i)))-            | i < 0     = thErr $ "Stack reference is negative " <> show i-            | i >= lhs  = thErr $ "Stack reference is out of the stack: " <> show i <> " >= " <> show lhs-            | otherwise = pure ()-      traverse_ checkStRef pc--    safeTail :: [a] -> [a]-    safeTail (_:as) = as-    safeTail [] = []--    fitError = liftEither . first (TCFailedOnInstr (EXT ext) hst . flip uextErrorText hs)--interpretHandler :: (ExtInstr, SomeItStack) -> EvalOp MorleyLogs ()-interpretHandler (PRINT (PrintComment pc), SomeItStack st) = do-  let getEl (Left l) = l-      getEl (Right (StackRef i)) =-        fromMaybe (error "StackRef " <> show i <> " has to exist in the stack after typechecking, but it doesn't") $-        rat st (fromIntegral i)-  modify (\s -> s {isExtState = MorleyLogs $ mconcat (map getEl pc) : unMorleyLogs (isExtState s)})-interpretHandler (TEST_ASSERT (TestAssert nm pc (instr :: T.Instr inp1 ('T.Tc 'T.CBool ': out1) )),-            SomeItStack (st :: Rec (Val T.Instr) inp2)) = do-  Refl <- liftEither $ first (error "TEST_ASSERT input stack doesn't match") $ eqT' @inp1 @inp2-  runInstrNoGas instr st >>= \case-    (T.VC (T.CvBool False) :& RNil) -> do-      interpretHandler (PRINT pc, SomeItStack st)-      throwError $ MichelsonFailedOther $ "TEST_ASSERT " <> nm <> " failed"-    _  -> pass---- | Various type errors possible when checking a @NopInstr@ with the--- @nopHandler@-data UExtError =-    LengthMismatch StackTypePattern Int-  | VarError Text StackFn-  | TypeMismatch StackTypePattern Int Text-  | TyVarMismatch Var Type StackTypePattern Int Text-  | FnEndMismatch (Maybe (ExpandedUExtInstr, SomeHST))-  | StkRestMismatch StackTypePattern SomeHST SomeHST Text-  | UnexpectedUExt ExpandedUExtInstr---- | Print error messages-uextErrorText :: UExtError -> HST xs -> Text-uextErrorText (LengthMismatch stk n) it = T.concat-  ["Unexpected length of stack: pattern ", show stk, " has length ", show n-  , ", but actual stack is", show it-  ]-uextErrorText (VarError t sf) _ = "In definition of " <> show t <> ": VarError " <> show sf-uextErrorText (TypeMismatch s n e) it = T.concat-  [ "TypeMismatch: Pattern ", show s, " failed on stack ", show it-  , "at index ", show n, " with \"", e, "\""-  ]-uextErrorText (TyVarMismatch v t s n e) it = T.concat-  [ "TyVarMismatch: Variable ", show v, " is bound to type ", show t-  , "but pattern ", show s, " failed on stack ", show it, "at index ", show n-  , " with \"", e, "\""-  ]-uextErrorText (FnEndMismatch n) it = "FnEndMismatch: " <> show n <> " on " <> show it-uextErrorText (UnexpectedUExt n) it = "UnexpectedUExt: " <> show n <> " on " <> show it-uextErrorText (StkRestMismatch s (SomeHST r) (SomeHST r') e) it = T.concat-  ["StkRestMismatch on stack ", show it-  , " in pattern " , show s-  , " against stacks ", show r, " and ", show r'-  , " with error: ", e-  ]---- | Check that the optional "forall" variables are consistent if present-checkVars :: Text -> StackFn -> Either UExtError ()-checkVars t sf = case quantifiedVars sf of-  Just qs-    | varSet (inPattern sf) /= qs -> Left $ VarError t sf-  _ -> pure ()---- | Checks the pattern in @FN@ and pushes a @ExtFrame@ onto the state-checkFn :: Text -> StackFn -> SomeHST -> TcExtFrames -> Either UExtError TcExtFrames-checkFn t sf si@(SomeHST it) nfs = do-  checkVars t sf-  second (const $ (FN t sf, si) : nfs) (checkStackType noBoundVars (inPattern sf) it)---- |  Pops a @ExtFrame@ off the state and checks an @FN_END@ based on it-checkFnEnd :: SomeHST -> TcExtFrames -> Either UExtError BoundVars-checkFnEnd (SomeHST it') (nf@(nop, SomeHST it):_) = case nop of-  FN t sf -> do-    checkVars t sf-    m <- checkStackType noBoundVars (inPattern sf) it-    checkStackType m (outPattern sf) it'-  _ -> Left $ FnEndMismatch (Just nf)-checkFnEnd _ _ = Left $ FnEndMismatch Nothing--data BoundVars = BoundVars (Map Var Type) (Maybe SomeHST)--noBoundVars :: BoundVars-noBoundVars = BoundVars Map.empty Nothing---- | Check that a @StackTypePattern@ matches the type of the current stack-checkStackType :: Typeable xs => BoundVars -> StackTypePattern -> HST xs-               -> Either UExtError BoundVars-checkStackType (BoundVars vars boundStkRest) s it = go vars 0 s it-  where-    go :: Typeable xs => Map Var Type -> Int -> StackTypePattern -> HST xs-       -> Either UExtError BoundVars-    go m _ StkRest sr = case boundStkRest of-      Nothing -> pure $ BoundVars m (Just $ SomeHST sr)-      Just si@(SomeHST sr') ->-        bimap (StkRestMismatch s (SomeHST sr) si)-              (const $ BoundVars m (Just si))-              (eqHST sr sr')-    go m _ StkEmpty SNil = pure $ BoundVars m Nothing-    go _ n StkEmpty _    = Left $ LengthMismatch s n-    go _ n _ SNil        = Left $ LengthMismatch s n-    go m n (StkCons (TyCon t) ts) ((xt, xann, _) ::& xs) = do-      tann <- first (TypeMismatch s n) (extractNotes t xt)-      void $ first (TypeMismatch s n) (converge tann xann)-      go m (n + 1) ts xs-    go m n (StkCons (VarID v) ts) ((xt, xann, _) ::& xs) =-      case lookup v m of-        Nothing -> let t = mkUType xt xann in go (insert v t m) (n + 1) ts xs-        Just t -> do-          tann <- first (TyVarMismatch v t s n) (extractNotes t xt)-          void $ first (TyVarMismatch v t s n) (converge tann xann)-          go m (n + 1) ts xs--eqHST :: (Typeable as, Typeable bs) => HST as -> HST bs -> Either Text (as :~: bs)-eqHST (it :: HST xs) (it' :: HST ys) = do-  Refl <- (eqT' @xs @ys)-  convergeHST it it'-  return Refl--lengthHST :: HST xs -> Int-lengthHST (_ ::& xs) = 1 + lengthHST xs-lengthHST SNil = 0--rat :: Rec (Val T.Instr) xs -> Int -> Maybe Text-rat (x :& _) 0 = Just $ show x-rat (_ :& xs) i = rat xs (i - 1)-rat RNil _ = Nothing
− src/Morley/Lexer.hs 
@@ -1,55 +0,0 @@-module Morley.Lexer (-    lexeme-  , mSpace-  , symbol-  , symbol'-  , string'-  , parens-  , braces-  , brackets-  , brackets'-  , semicolon-  , comma-  ) where--import Morley.Types (Parser)--import Data.Char (toLower)-import qualified Data.Text as T-import Text.Megaparsec (between, MonadParsec, Tokens)-import Text.Megaparsec.Char (space1, string)-import qualified Text.Megaparsec.Char.Lexer as L---- Lexing-lexeme :: Parser a -> Parser a-lexeme = L.lexeme mSpace--mSpace :: Parser ()-mSpace = L.space space1 (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")--symbol :: Tokens Text -> Parser (Tokens Text)-symbol = L.symbol mSpace--symbol' :: Text -> Parser (Tokens Text)-symbol' str = symbol str <|> symbol (T.map toLower str)--string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text-string' str = string str <|> string (T.map toLower str)--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--brackets :: Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")--brackets' :: Parser a -> Parser a-brackets' = between (string "[") (string "]")--semicolon :: Parser (Tokens Text)-semicolon = symbol ";"--comma :: Parser (Tokens Text)-comma = symbol ","
− src/Morley/Macro.hs 
@@ -1,186 +0,0 @@-module Morley.Macro-  (-    -- * For utilities-    expandContract-  , expandValue--    -- * For parsing-  , mapLeaves--    -- * Internals exported for tests-  , expand-  , expandList-  , expandPapair-  , expandUnpapair-  , expandCadr-  , expandSetCadr-  , expandMapCadr-  ) where--import Michelson.Untyped (UntypedContract, UntypedValue)-import Morley.Types-  (CadrStruct(..), Contract(..), Elt(..), ExpandedOp(..), FieldAnn, InstrAbstract(..),-  LetMacro(..), Macro(..), PairStruct(..), ParsedOp(..), TypeAnn, UExtInstrAbstract(..), Value(..),-  VarAnn, ann, noAnn)--expandList :: [ParsedOp] -> [ExpandedOp]-expandList = fmap expand---- | Expand all macros in parsed contract.-expandContract :: Contract ParsedOp -> UntypedContract-expandContract Contract {..} =-  Contract para stor (expandList $ code)---- Probably, some SYB can be used here-expandValue :: Value ParsedOp -> UntypedValue-expandValue = \case-  ValuePair l r -> ValuePair (expandValue l) (expandValue r)-  ValueLeft x -> ValueLeft (expandValue x)-  ValueRight x -> ValueRight (expandValue x)-  ValueSome x -> ValueSome (expandValue x)-  ValueNil -> ValueNil-  ValueSeq valueList -> ValueSeq (map expandValue valueList)-  ValueMap eltList -> ValueMap (map expandElt eltList)-  ValueLambda opList ->-    maybe ValueNil ValueLambda $-    nonEmpty (expandList $ toList opList)-  x -> fmap expand x--expandElt :: Elt ParsedOp -> Elt ExpandedOp-expandElt (Elt l r) = Elt (expandValue l) (expandValue r)--expand :: ParsedOp -> ExpandedOp--- 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.-expand (Mac (PAPAIR (P (F a) (F b)) t v)) =-  PrimEx $ PAIR t v (snd a) (snd b)-expand (Mac m)  = SeqEx $ expandMacro m-expand (Prim i) = PrimEx $ expand <$> i-expand (Seq s)  = SeqEx $ expand <$> s-expand (LMac l)  = SeqEx $ expandLetMac l-  where-    expandLetMac :: LetMacro -> [ExpandedOp]-    expandLetMac LetMacro {..} =-      [ PrimEx $ EXT (FN lmName lmSig)-      , SeqEx $ expand <$> lmExpr-      , PrimEx $ EXT FN_END-      ]--expandMacro :: Macro -> [ExpandedOp]-expandMacro = \case-  CMP i v            -> [PrimEx (COMPARE v), xo i]-  IFX i bt bf        -> [xo i, PrimEx (IF (xp bt) (xp bf))]-  IFCMP i v bt bf    -> PrimEx <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)]-  IF_SOME bt bf      -> [PrimEx (IF_NONE (xp bf) (xp bt))]-  FAIL               -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH]-  ASSERT             -> xol $ IF [] [Mac FAIL]-  ASSERTX i          -> [expand $ Mac $ IFX i [] [Mac FAIL]]-  ASSERT_CMP i       -> [expand $ Mac $ IFCMP i noAnn [] [Mac FAIL]]-  ASSERT_NONE        -> xol $ IF_NONE [] [Mac FAIL]-  ASSERT_SOME        -> xol $ IF_NONE [Mac FAIL] []-  ASSERT_LEFT        -> xol $ IF_LEFT [] [Mac FAIL]-  ASSERT_RIGHT       -> xol $ IF_LEFT [Mac FAIL] []-  PAPAIR ps t v      -> expand <$> expandPapair ps t v-  UNPAIR ps          -> expand <$> expandUnpapair ps-  CADR c v f         -> expand <$> expandCadr c v f-  SET_CADR c v f     -> expand <$> expandSetCadr c v f-  MAP_CADR c v f ops -> expand <$> expandMapCadr c v f ops-  DIIP 1 ops         -> [PrimEx $ DIP (xp ops)]-  DIIP n ops         -> xol $  DIP [Mac $ DIIP (n - 1) ops]-  DUUP 1 v           -> [PrimEx $ DUP v]-  DUUP n v           -> [xo (DIP [Mac $ DUUP (n - 1) v]), PrimEx SWAP]-  where-    xol = one . xo-    xo = PrimEx . fmap expand-    xp = fmap expand---- the correctness of type-annotation expansion is currently untested, as these--- expansions are not explicitly documented in the Michelson Specification-expandPapair :: PairStruct -> TypeAnn -> VarAnn -> [ParsedOp]-expandPapair ps t v = case ps of-  P (F a) (F b) -> [Prim $ PAIR t v (snd a) (snd b)]-  P (F a) r     -> Prim <$> [ DIP [Mac $ PAPAIR r noAnn noAnn]-                            , PAIR t v (snd a) noAnn]-  P l     (F b) -> [ Mac $ PAPAIR l noAnn noAnn-                   , Prim $ PAIR t v noAnn (snd b)]-  P l     r     -> [ Mac $ PAPAIR l noAnn noAnn-                   , Prim $ DIP [Mac $ PAPAIR r noAnn noAnn]-                   , Prim $ PAIR t v noAnn noAnn]-  F _           -> [] -- Do nothing in this case.-  -- It's impossible from the structure of PairStruct and considered cases above,-  -- but if it accidentally happened let's just do nothing.--expandUnpapair :: PairStruct -> [ParsedOp]-expandUnpapair = \case-  P (F (v,f)) (F (w,g)) -> Prim <$> [ DUP noAnn-                                    , CAR v f-                                    , DIP [Prim $ CDR w g]]-  P (F (v, f)) r        -> Prim <$> [ DUP noAnn-                                    , CAR v f-                                    , DIP [Prim $ CDR noAnn noAnn,-                                           Mac $ UNPAIR r]]-  P l     (F (v, f))    -> [ Prim (DUP noAnn)-                           , Prim (DIP [Prim $ CDR v f])-                           , Prim $ CAR noAnn noAnn-                           , Mac $ UNPAIR l]-  P l      r            -> [ Mac unpairOne-                           , Prim $ DIP [Mac $ UNPAIR r]-                           , Mac $ UNPAIR l]-  F _                   -> [] -- Do nothing in this case.-  -- It's impossible from the structure of PairStruct and considered cases above,-  -- but if it accidentally happened let's just do nothing.-  where-    unpairOne = UNPAIR (P fn fn)-    fn = F (noAnn, noAnn)--expandCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp]-expandCadr cs v f = case cs of-  []    -> []-  [A]  -> [Prim $ CAR v f]-  [D]  -> [Prim $ CDR v f]-  A:css -> [Prim $ CAR noAnn noAnn, Mac $ CADR css v f]-  D:css -> [Prim $ CDR noAnn noAnn, Mac $ CADR css v f]--expandSetCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp]-expandSetCadr cs v f = Prim <$> case cs of-  []   -> []-  [A] -> [DUP noAnn, CAR noAnn f, DROP,-           -- ↑ These operations just check that the left element of pair has %f-           CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]-  [D] -> [DUP noAnn, CDR noAnn f, DROP,-           -- ↑ These operations just check that the right element of pair has %f-           CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f]-  A:css -> [DUP noAnn, DIP [Prim carN, Mac $ SET_CADR css noAnn f], cdrN, SWAP, pairN]-  D:css -> [DUP noAnn, DIP [Prim cdrN, Mac $ SET_CADR css noAnn f], carN, pairN]-  where-    carN = CAR noAnn noAnn-    cdrN = CDR noAnn noAnn-    pairN = PAIR noAnn v noAnn noAnn--expandMapCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ParsedOp]-expandMapCadr cs v f ops = case cs of-  []    -> []-  [A]  -> Prim <$> [DUP noAnn, cdrN, DIP [Prim $ CAR noAnn f, Seq ops], SWAP, pairN]-  [D]  -> concat [Prim <$> [DUP noAnn, CDR noAnn f], [Seq ops], Prim <$> [SWAP, carN, pairN]]-  A:css -> Prim <$> [DUP noAnn, DIP [Prim $ carN, Mac $ MAP_CADR css noAnn f ops], cdrN, SWAP, pairN]-  D:css -> Prim <$> [DUP noAnn, DIP [Prim $ cdrN, Mac $ MAP_CADR css noAnn f ops], carN, pairN]-  where-    carN = CAR noAnn noAnn-    cdrN = CDR noAnn noAnn-    pairN = PAIR noAnn v noAnn noAnn--mapLeaves :: [(VarAnn, FieldAnn)] -> PairStruct -> PairStruct-mapLeaves fs p = evalState (leavesST p) fs--leavesST :: PairStruct -> State [(VarAnn, FieldAnn)] PairStruct-leavesST (P l r) = do-  l' <- leavesST l-  r' <- leavesST r-  return $ P l' r'-leavesST (F _) = do-  f <- state getLeaf-  return $ F f-  where-    getLeaf (a:as) = (a, as)-    getLeaf _      = ((noAnn, noAnn), [])
− src/Morley/Parser.hs 
@@ -1,934 +0,0 @@-module Morley.Parser-  ( program-  , parseNoEnv-  , ops-  , ParserException (..)-  , stringLiteral-  , type_-  , value-  , stackType-  , printComment-  , bytesLiteral-  , pushOp-  , intLiteral-  ) where--import Prelude hiding (many, note, some, try)--import Control.Applicative.Permutations (intercalateEffect, toPermutation)-import qualified Data.ByteString.Base16 as B16-import qualified Data.Char as Char-import Data.Default (Default)-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as T--import Text.Megaparsec-  (choice, customFailure, eitherP, many, manyTill, notFollowedBy, parse, satisfy, sepEndBy, some,-  takeWhileP, try)-import Text.Megaparsec.Char (alphaNumChar, char, lowerChar, string, upperChar)-import qualified Text.Megaparsec.Char.Lexer as L--import Morley.Lexer-import qualified Morley.Macro as Macro-import Morley.Parser.Annotations-import Morley.Parser.Helpers-import Morley.Types (CustomParserException(..), ParsedOp(..), Parser, ParserException(..))-import qualified Morley.Types as Mo------------------------------------------------------------------------------------ Top-Level Parsers------------------------------------------------------------------------------------- Contracts----------------------- | Michelson contract with let definitions-program :: Mo.Parsec CustomParserException T.Text (Mo.Contract ParsedOp)-program = runReaderT programInner Mo.noLetEnv--programInner :: Parser (Mo.Contract ParsedOp)-programInner = do-  mSpace-  env <- fromMaybe Mo.noLetEnv <$> (optional letBlock)-  local (const env) contract---- | Parse with empty environment-parseNoEnv :: Parser a -> String -> T.Text-       -> Either (Mo.ParseErrorBundle T.Text CustomParserException) a-parseNoEnv p = parse (runReaderT p Mo.noLetEnv)---- | Michelson contract-contract :: Parser (Mo.Contract ParsedOp)-contract = do-  mSpace-  (p,s,c) <- intercalateEffect semicolon $-              (,,) <$> toPermutation parameter-                   <*> toPermutation storage-                   <*> toPermutation code-  return $ Mo.Contract p s c---- Contract Blocks----------------------- | let block parser-letBlock :: Parser Mo.LetEnv-letBlock = do-  symbol "let"-  symbol "{"-  ls <- local (const Mo.noLetEnv) letInner-  symbol "}"-  semicolon-  return ls--parameter :: Parser Mo.Type-parameter = do void $ symbol "parameter"; type_--storage :: Parser Mo.Type-storage = do void $ symbol "storage"; type_--code :: Parser [ParsedOp]-code = do void $ symbol "code"; ops---- Michelson expressions--------------------------value :: Parser (Mo.Value ParsedOp)-value = lexeme $ valueInner <|> parens valueInner--type_ :: Parser Mo.Type-type_ = (ti <|> parens ti) <|> (customFailure UnknownTypeException)-  where-    ti = snd <$> (lexeme $ typeInner (pure Mo.noAnn))--op' :: Parser Mo.ParsedOp-op' = do-  lms <- asks Mo.letMacros-  choice-    [ (Mo.Prim . Mo.EXT) <$> nopInstr-    , Mo.LMac <$> mkLetMac lms-    , Mo.Prim <$> prim-    , Mo.Mac <$> macro-    , primOrMac-    , Mo.Seq <$> ops-    ]--ops :: Parser [Mo.ParsedOp]-ops = braces $ sepEndBy op' semicolon--ops1 :: Parser (NonEmpty Mo.ParsedOp)-ops1 = braces $ sepEndBy1 op' semicolon------------------------------------------------------------------------------------ Let block------------------------------------------------------------------------------------ | Element of a let block-data Let = LetM Mo.LetMacro | LetV Mo.LetValue | LetT Mo.LetType---- | Incrementally build the let environment-letInner :: Parser Mo.LetEnv-letInner = do-  env <- ask-  l <- lets-  semicolon-  (local (addLet l) letInner) <|> return (addLet l env)---- | add a Let to the environment in the correct place-addLet :: Let -> Mo.LetEnv -> Mo.LetEnv-addLet l (Mo.LetEnv lms lvs lts) = case l of-  LetM lm -> Mo.LetEnv (Map.insert (Mo.lmName lm) lm lms) lvs lts-  LetV lv -> Mo.LetEnv lms (Map.insert (Mo.lvName lv) lv lvs) lts-  LetT lt -> Mo.LetEnv lms lvs (Map.insert (Mo.ltName lt) lt lts)--lets :: Parser Let-lets = choice [ (LetM <$> (try letMacro))-              , (LetV <$> (try letValue))-              , (LetT <$> (try letType))-              ]---- | build a let name parser from a leading character parser-letName :: Parser Char -> Parser T.Text-letName p = lexeme $ do-  v <- p-  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')-  vs <- many (satisfy validChar)-  return $ T.pack (v:vs)--letMacro :: Parser Mo.LetMacro-letMacro = lexeme $ do-  n <- letName lowerChar-  symbol "::"-  s <- stackFn-  symbol "="-  o <- ops-  return $ Mo.LetMacro n s o--letType :: Parser Mo.LetType-letType = lexeme $ do-  symbol "type"-  n <- letName lowerChar-  symbol "="-  t <- type_-  case t of-    (Mo.Type t' a) ->-      if a == Mo.noAnn-      then return $ Mo.LetType n (Mo.Type t' (Mo.ann n))-      else return $ Mo.LetType n t--letValue :: Parser Mo.LetValue-letValue = lexeme $ do-  n <- letName upperChar-  symbol "::"-  t <- type_-  symbol "="-  v <- value-  return $ Mo.LetValue n t v---- | make a parser from a string-mkParser :: (a -> T.Text) -> a -> Parser a-mkParser f a = (try $ symbol (f a)) >> return a--mkLetMac :: Map Text Mo.LetMacro -> Parser Mo.LetMacro-mkLetMac lms = choice $ mkParser Mo.lmName <$> (Map.elems lms)--mkLetVal :: Map Text Mo.LetValue -> Parser Mo.LetValue-mkLetVal lvs = choice $ mkParser Mo.lvName <$> (Map.elems lvs)--mkLetType :: Map Text Mo.LetType -> Parser Mo.LetType-mkLetType lts = choice $ mkParser Mo.ltName <$> (Map.elems lts)--stackFn :: Parser Mo.StackFn-stackFn = do-  vs <- (optional (symbol "forall" >> some varID <* symbol "."))-  a <- stackType-  symbol "->"-  b <- stackType-  return $ Mo.StackFn (Set.fromList <$> vs) a b--tyVar :: Parser Mo.TyVar-tyVar = (Mo.TyCon <$> type_) <|> (Mo.VarID <$> varID)--lowerAlphaNumChar :: Parser Char-lowerAlphaNumChar = satisfy (\x -> Char.isLower x || Char.isDigit x)--varID :: Parser Mo.Var-varID = lexeme $ do-  v <- lowerChar-  vs <- many lowerAlphaNumChar-  return $ Mo.Var (T.pack (v:vs))------------------------------------------------------------------------------------ Value Parsers----------------------------------------------------------------------------------valueInner :: Parser (Mo.Value Mo.ParsedOp)-valueInner = choice $-  [ stringLiteral, bytesLiteral, intLiteral, unitValue-  , trueValue, falseValue, pairValue, leftValue, rightValue-  , someValue, noneValue, nilValue, seqValue, mapValue, lambdaValue-  , dataLetValue-  ]--dataLetValue :: Parser (Mo.Value ParsedOp)-dataLetValue = do-  lvs <- asks Mo.letValues-  Mo.lvVal <$> (mkLetVal lvs)---- Literals-intLiteral :: Parser (Mo.Value a)-intLiteral = try $ Mo.ValueInt <$> (L.signed (return ()) L.decimal)--bytesLiteral :: Parser (Mo.Value a)-bytesLiteral = try $ do-  symbol "0x"-  hexdigits <- takeWhileP Nothing Char.isHexDigit-  let (bytes, remain) = B16.decode $ encodeUtf8 hexdigits-  if remain == ""-  then return . Mo.ValueBytes . Mo.InternalByteString $ bytes-  else customFailure OddNumberBytesException--stringLiteral :: Parser (Mo.Value ParsedOp)-stringLiteral = try $ Mo.ValueString <$>-  (T.pack <$>-    ( (++) <$>-        (concat <$> (string "\"" >> many validChar)) <*>-        (manyTill (lineBreakChar <|> (customFailure $ UnexpectedLineBreak)) (string "\""))-    )-  )-  where-      validChar :: Parser String-      validChar =-        try strEscape <|>-          try ((:[]) <$> satisfy (\x -> x /= '"' && x /= '\n' && x /= '\r'))-      lineBreakChar :: Parser Char-      lineBreakChar = char '\n' <|> char '\r'--strEscape :: Parser String-strEscape = char '\\' >> esc-  where-    esc = (char 't' >> return "\t")-      <|> (char 'b' >> return "\b")-      <|> (char '\\' >> return "\\")-      <|> (char '"' >> return "\"")-      <|> (char 'n' >> return "\n")-      <|> (char 'r' >> return "\r")---unitValue :: Parser (Mo.Value ParsedOp)-unitValue = do symbol "Unit"; return Mo.ValueUnit--trueValue :: Parser (Mo.Value ParsedOp)-trueValue = do symbol "True"; return Mo.ValueTrue--falseValue :: Parser (Mo.Value ParsedOp)-falseValue = do symbol "False"; return Mo.ValueFalse--pairValue :: Parser (Mo.Value ParsedOp)-pairValue = core <|> tuple-  where-    core = do symbol "Pair"; a <- value; Mo.ValuePair a <$> value-    tuple = try $ do-      symbol "("-      a <- value-      comma-      b <- tupleInner <|> value-      symbol ")"-      return $ Mo.ValuePair a b-    tupleInner = try $ do-      a <- value-      comma-      b <- tupleInner <|> value-      return $ Mo.ValuePair a b--leftValue :: Parser (Mo.Value ParsedOp)-leftValue = do void $ symbol "Left"; Mo.ValueLeft <$> value--rightValue :: Parser (Mo.Value ParsedOp)-rightValue = do void $ symbol "Right"; Mo.ValueRight <$> value--someValue :: Parser (Mo.Value ParsedOp)-someValue = do void $ symbol "Some"; Mo.ValueSome <$> value--noneValue :: Parser (Mo.Value ParsedOp)-noneValue = do symbol "None"; return Mo.ValueNone--nilValue :: Parser (Mo.Value ParsedOp)-nilValue = Mo.ValueNil <$ (try $ braces pass)--lambdaValue :: Parser (Mo.Value ParsedOp)-lambdaValue = Mo.ValueLambda <$> ops1--seqValue :: Parser (Mo.Value ParsedOp)-seqValue = Mo.ValueSeq <$> (try $ braces $ sepEndBy1 value semicolon)--eltValue :: Parser (Mo.Elt ParsedOp)-eltValue = do void $ symbol "Elt"; Mo.Elt <$> value <*> value--mapValue :: Parser (Mo.Value ParsedOp)-mapValue = Mo.ValueMap <$> (try $ braces $ sepEndBy1 eltValue semicolon)------------------------------------------------------------------------------------ Types---------------------------------------------------------------------------------field :: Parser (Mo.FieldAnn, Mo.Type)-field = lexeme (fi <|> parens fi)-  where-    fi = typeInner noteF--typeInner :: Parser Mo.FieldAnn -> Parser (Mo.FieldAnn, Mo.Type)-typeInner fp = choice $ (\x -> x fp) <$>-  [ t_ct, t_key, t_unit, t_signature, t_option, t_list, t_set, t_operation-  , t_contract, t_pair, t_or, t_lambda, t_map, t_big_map, t_letType-  ]--t_letType :: Parser fp -> Parser (fp, Mo.Type)-t_letType fp = do-  lts <- asks Mo.letTypes-  lt <- Mo.ltSig <$> (mkLetType lts)-  f <- fp-  return (f, lt)---- Comparable Types-comparable :: Parser Mo.Comparable-comparable = let c = do ct' <- ct; Mo.Comparable ct' <$> noteTDef in parens c <|> c--t_ct :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_ct fp = do ct' <- ct; (f,t) <- fieldType fp; return (f, Mo.Type (Mo.Tc ct') t)--ct :: Parser Mo.CT-ct = (symbol "int" >> return Mo.CInt)-  <|> (symbol "nat" >> return Mo.CNat)-  <|> (symbol "string" >> return Mo.CString)-  <|> (symbol "bytes" >> return Mo.CBytes)-  <|> (symbol "mutez" >> return Mo.CMutez)-  <|> (symbol "bool" >> return Mo.CBool)-  <|> (symbol "key_hash" >> return Mo.CKeyHash)-  <|> (symbol "timestamp" >> return Mo.CTimestamp)-  <|> (symbol "address" >> return Mo.CAddress)---- Protocol Types-t_key :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_key       fp = do symbol "key"; (f,t) <- fieldType fp; return (f, Mo.Type Mo.TKey t)--t_signature :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_signature fp = do symbol "signature"; (f, t) <- fieldType fp; return (f, Mo.Type Mo.TSignature t)--t_operation :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_operation fp = do symbol "operation"; (f, t) <- fieldType fp; return (f, Mo.Type Mo.TOperation t)--t_contract :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_contract  fp = do symbol "contract"; (f, t) <- fieldType fp; a <- type_; return (f, Mo.Type (Mo.TContract a) t)---(do symbol "address"; (f, t) <- ft; return (f, Mo.Type Mo.CAddress t)---- Abstraction Types-t_unit :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_unit fp = do-  symbol "unit" <|> symbol "()"-  (f,t) <- fieldType fp-  return (f, Mo.Type Mo.TUnit t)--t_pair :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_pair fp = core <|> tuple-  where-    core = do-      symbol "pair"-      (f, t) <- fieldType fp-      (l, a) <- field-      (r, b) <- field-      return (f, Mo.Type (Mo.TPair l r a b) t)-    tuple = try $ do-      symbol "("-      (l, a) <- field-      comma-      (r, b) <- tupleInner <|> field-      symbol ")"-      (f, t) <- fieldType fp-      return (f, Mo.Type (Mo.TPair l r a b) t)-    tupleInner = try $ do-      (l, a) <- field-      comma-      (r, b) <- tupleInner <|> field-      return (Mo.noAnn, Mo.Type (Mo.TPair l r a b) Mo.noAnn)--t_or :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_or fp = core <|> bar-  where-    core = do-      symbol "or"-      (f, t) <- fieldType fp-      (l, a) <- field-      (r, b) <- field-      return (f, Mo.Type (Mo.TOr l r a b) t)-    bar = try $ do-      symbol "("-      (l, a) <- field-      symbol "|"-      (r, b) <- barInner <|> field-      symbol ")"-      (f, t) <- fieldType fp-      return (f, Mo.Type (Mo.TOr l r a b) t)-    barInner = try $ do-      (l, a) <- field-      symbol "|"-      (r, b) <- barInner <|> field-      return (Mo.noAnn, Mo.Type (Mo.TOr l r a b) Mo.noAnn)--t_option :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_option fp = do-  symbol "option"-  (f, t) <- fieldType fp-  (fa, a) <- field-  return (f, Mo.Type (Mo.TOption fa a) t)--t_lambda :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_lambda fp = core <|> slashLambda-  where-    core = do-      symbol "lambda"-      (f, t) <- fieldType fp-      a <- type_-      b <- type_-      return (f, Mo.Type (Mo.TLambda a b) t)-    slashLambda = do-      symbol "\\"-      (f, t) <- fieldType fp-      a <- type_-      symbol "->"-      b <- type_-      return (f, Mo.Type (Mo.TLambda a b) t)---- Container types-t_list :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_list fp = core <|> bracketList-  where-    core = do-      symbol "list"-      (f, t) <- fieldType fp-      a <- type_-      return (f, Mo.Type (Mo.TList a) t)-    bracketList = do-      a <- brackets type_-      (f, t) <- fieldType fp-      return (f, Mo.Type (Mo.TList a) t)--t_set :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_set fp = core <|> braceSet-  where-    core = do-      symbol "set"-      (f, t) <- fieldType fp-      a <- comparable-      return (f, Mo.Type (Mo.TSet a) t)-    braceSet = do-      a <- braces comparable-      (f, t) <- fieldType fp-      return (f, Mo.Type (Mo.TSet a) t)--t_map :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_map fp = (do symbol "map"; (f, t) <- fieldType fp; a <- comparable; b <- type_; return (f, Mo.Type (Mo.TMap a b) t))--t_big_map :: (Default a) => Parser a -> Parser (a, Mo.Type)-t_big_map fp = (do symbol "big_map"; (f, t) <- fieldType fp; a <- comparable; b <- type_; return (f, Mo.Type (Mo.TBigMap a b) t))------------------------------------------------------------------------------------ Primitive Instruction Parsers---------------------------------------------------------------------------------prim :: Parser Mo.ParsedInstr-prim = choice-  [ dropOp, dupOp, swapOp, pushOp, someOp, noneOp, unitOp, ifNoneOp-  , carOp, cdrOp, leftOp, rightOp, ifLeftOp, ifRightOp, nilOp, consOp, ifConsOp-  , sizeOp, emptySetOp, emptyMapOp, iterOp, memOp, getOp, updateOp-  , loopLOp, loopOp, lambdaOp, execOp, dipOp, failWithOp, castOp, renameOp-  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, addOp, subOp-  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp-  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp-  , transferTokensOp, setDelegateOp, createAccountOp, createContract2Op-  , createContractOp, implicitAccountOp, nowOp, amountOp, balanceOp, checkSigOp-  , sha256Op, sha512Op, blake2BOp, hashKeyOp, stepsToQuotaOp, sourceOp, senderOp-  ]---- Control Structures--failWithOp :: Parser Mo.ParsedInstr-failWithOp = do symbol' "FAILWITH"; return Mo.FAILWITH--loopOp :: Parser Mo.ParsedInstr-loopOp  = do void $ symbol' "LOOP"; Mo.LOOP <$> ops--loopLOp :: Parser Mo.ParsedInstr-loopLOp = do void $ symbol' "LOOP_LEFT"; Mo.LOOP_LEFT <$> ops--execOp :: Parser Mo.ParsedInstr-execOp = do void $ symbol' "EXEC"; Mo.EXEC <$> noteVDef--dipOp :: Parser Mo.ParsedInstr-dipOp = do void $ symbol' "DIP"; Mo.DIP <$> ops---- Stack Operations--dropOp :: Parser Mo.ParsedInstr-dropOp = do symbol' "DROP"; return Mo.DROP;--dupOp :: Parser Mo.ParsedInstr-dupOp = do void $ symbol' "DUP"; Mo.DUP <$> noteVDef--swapOp :: Parser Mo.ParsedInstr-swapOp = do symbol' "SWAP"; return Mo.SWAP;--pushOp :: Parser Mo.ParsedInstr-pushOp = do-  symbol' "PUSH"-  v <- noteVDef-  (try $ pushLet v) <|> (push' v)-  where-    pushLet v = do-      lvs <- asks Mo.letValues-      lv <- mkLetVal lvs-      return $ Mo.PUSH v (Mo.lvSig lv) (Mo.lvVal lv)-    push' v = do a <- type_; Mo.PUSH v a <$> value--unitOp :: Parser Mo.ParsedInstr-unitOp = do symbol' "UNIT"; (t, v) <- notesTV; return $ Mo.UNIT t v--lambdaOp :: Parser Mo.ParsedInstr-lambdaOp = do symbol' "LAMBDA"; v <- noteVDef; a <- type_; b <- type_;-              Mo.LAMBDA v a b <$> ops---- Generic comparison--eqOp :: Parser Mo.ParsedInstr-eqOp = do void $ symbol' "EQ"; Mo.EQ <$> noteVDef--neqOp :: Parser Mo.ParsedInstr-neqOp = do void $ symbol' "NEQ"; Mo.NEQ <$> noteVDef--ltOp :: Parser Mo.ParsedInstr-ltOp = do void $ symbol' "LT"; Mo.LT <$> noteVDef--gtOp :: Parser Mo.ParsedInstr-gtOp = do void $ symbol' "GT"; Mo.GT <$> noteVDef--leOp :: Parser Mo.ParsedInstr-leOp = do void $ symbol' "LE"; Mo.LE <$> noteVDef--geOp :: Parser Mo.ParsedInstr-geOp = do void $ symbol' "GE"; Mo.GE <$> noteVDef---- ad-hoc comparison--compareOp :: Parser Mo.ParsedInstr-compareOp = do void $ symbol' "COMPARE"; Mo.COMPARE <$> noteVDef---- Operations on booleans--orOp :: Parser Mo.ParsedInstr-orOp = do void $ symbol' "OR";  Mo.OR <$> noteVDef--andOp :: Parser Mo.ParsedInstr-andOp = do void $ symbol' "AND"; Mo.AND <$> noteVDef--xorOp :: Parser Mo.ParsedInstr-xorOp = do void $ symbol' "XOR"; Mo.XOR <$> noteVDef--notOp :: Parser Mo.ParsedInstr-notOp = do void $ symbol' "NOT"; Mo.NOT <$> noteVDef---- Operations on integers and natural numbers--addOp :: Parser Mo.ParsedInstr-addOp = do void $ symbol' "ADD"; Mo.ADD <$> noteVDef--subOp :: Parser Mo.ParsedInstr-subOp = do void $ symbol' "SUB"; Mo.SUB <$> noteVDef--mulOp :: Parser Mo.ParsedInstr-mulOp = do void $ symbol' "MUL"; Mo.MUL <$> noteVDef--edivOp :: Parser Mo.ParsedInstr-edivOp = do void $ symbol' "EDIV";Mo.EDIV <$> noteVDef--absOp :: Parser Mo.ParsedInstr-absOp = do void $ symbol' "ABS"; Mo.ABS <$> noteVDef--negOp :: Parser Mo.ParsedInstr-negOp = do symbol' "NEG"; return Mo.NEG;---- Bitwise logical operators--lslOp :: Parser Mo.ParsedInstr-lslOp = do void $ symbol' "LSL"; Mo.LSL <$> noteVDef--lsrOp :: Parser Mo.ParsedInstr-lsrOp = do void $ symbol' "LSR"; Mo.LSR <$> noteVDef---- Operations on string's--concatOp :: Parser Mo.ParsedInstr-concatOp = do void $ symbol' "CONCAT"; Mo.CONCAT <$> noteVDef--sliceOp :: Parser Mo.ParsedInstr-sliceOp = do void $ symbol' "SLICE"; Mo.SLICE <$> noteVDef---- Operations on pairs-pairOp :: Parser Mo.ParsedInstr-pairOp = do symbol' "PAIR"; (t, v, (p, q)) <- notesTVF2; return $ Mo.PAIR t v p q--carOp :: Parser Mo.ParsedInstr-carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ Mo.CAR v f--cdrOp :: Parser Mo.ParsedInstr-cdrOp = do symbol' "CDR"; (v, f) <- notesVF; return $ Mo.CDR v f---- Operations on collections (sets, maps, lists)--emptySetOp :: Parser Mo.ParsedInstr-emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;-                Mo.EMPTY_SET t v <$> comparable--emptyMapOp :: Parser Mo.ParsedInstr-emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- comparable;-                Mo.EMPTY_MAP t v a <$> type_--memOp :: Parser Mo.ParsedInstr-memOp = do void $ symbol' "MEM"; Mo.MEM <$> noteVDef--updateOp :: Parser Mo.ParsedInstr-updateOp = do symbol' "UPDATE"; return Mo.UPDATE--iterOp :: Parser Mo.ParsedInstr-iterOp = do void $ symbol' "ITER"; Mo.ITER <$> ops--sizeOp :: Parser Mo.ParsedInstr-sizeOp = do void $ symbol' "SIZE"; Mo.SIZE <$> noteVDef--mapOp :: Parser Mo.ParsedInstr-mapOp = do symbol' "MAP"; v <- noteVDef; Mo.MAP v <$> ops--getOp :: Parser Mo.ParsedInstr-getOp = do void $ symbol' "GET"; Mo.GET <$> noteVDef--nilOp :: Parser Mo.ParsedInstr-nilOp = do symbol' "NIL"; (t, v) <- notesTV; Mo.NIL t v <$> type_--consOp :: Parser Mo.ParsedInstr-consOp = do void $ symbol' "CONS"; Mo.CONS <$> noteVDef--ifConsOp :: Parser Mo.ParsedInstr-ifConsOp = do symbol' "IF_CONS"; a <- ops; Mo.IF_CONS a <$> ops---- Operations on options--someOp :: Parser Mo.ParsedInstr-someOp = do symbol' "SOME"; (t, v, f) <- notesTVF; return $ Mo.SOME t v f--noneOp :: Parser Mo.ParsedInstr-noneOp = do symbol' "NONE"; (t, v, f) <- notesTVF; Mo.NONE t v f <$> type_--ifNoneOp :: Parser Mo.ParsedInstr-ifNoneOp = do symbol' "IF_NONE"; a <- ops; Mo.IF_NONE a <$> ops---- Operations on unions--leftOp :: Parser Mo.ParsedInstr-leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2;-               Mo.LEFT t v f f' <$> type_--rightOp :: Parser Mo.ParsedInstr-rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2;-               Mo.RIGHT t v f f' <$> type_--ifLeftOp :: Parser Mo.ParsedInstr-ifLeftOp = do symbol' "IF_LEFT"; a <- ops; Mo.IF_LEFT a <$> ops--ifRightOp :: Parser Mo.ParsedInstr-ifRightOp = do symbol' "IF_RIGHT"; a <- ops; Mo.IF_RIGHT a <$> ops---- Operations on contracts--createContractOp :: Parser Mo.ParsedInstr-createContractOp = do symbol' "CREATE_CONTRACT"; v <- noteVDef;-                       Mo.CREATE_CONTRACT v <$> noteVDef--createContract2Op :: Parser Mo.ParsedInstr-createContract2Op = do symbol' "CREATE_CONTRACT"; v <- noteVDef; v' <- noteVDef;-                       Mo.CREATE_CONTRACT2 v v' <$> braces contract--createAccountOp :: Parser Mo.ParsedInstr-createAccountOp = do symbol' "CREATE_ACCOUNT"; v <- noteVDef; v' <- noteVDef;-                       return $ Mo.CREATE_ACCOUNT v v'--transferTokensOp :: Parser Mo.ParsedInstr-transferTokensOp = do void $ symbol' "TRANSFER_TOKENS"; Mo.TRANSFER_TOKENS <$> noteVDef--setDelegateOp :: Parser Mo.ParsedInstr-setDelegateOp = do void $ symbol' "SET_DELEGATE"; Mo.SET_DELEGATE <$> noteVDef--balanceOp :: Parser Mo.ParsedInstr-balanceOp = do void $ symbol' "BALANCE"; Mo.BALANCE <$> noteVDef--contractOp :: Parser Mo.ParsedInstr-contractOp = do void $ symbol' "CONTRACT"; Mo.CONTRACT <$> noteVDef <*> type_--sourceOp :: Parser Mo.ParsedInstr-sourceOp = do void $ symbol' "SOURCE"; Mo.SOURCE <$> noteVDef--senderOp :: Parser Mo.ParsedInstr-senderOp = do void $ symbol' "SENDER"; Mo.SENDER <$> noteVDef--amountOp :: Parser Mo.ParsedInstr-amountOp = do void $ symbol' "AMOUNT"; Mo.AMOUNT <$> noteVDef--implicitAccountOp :: Parser Mo.ParsedInstr-implicitAccountOp = do void $ symbol' "IMPLICIT_ACCOUNT"; Mo.IMPLICIT_ACCOUNT <$> noteVDef--selfOp :: Parser Mo.ParsedInstr-selfOp = do void $ symbol' "SELF"; Mo.SELF <$> noteVDef--addressOp :: Parser Mo.ParsedInstr-addressOp = do void $ symbol' "ADDRESS"; Mo.ADDRESS <$> noteVDef---- Special Operations-nowOp :: Parser Mo.ParsedInstr-nowOp = do void $ symbol' "NOW"; Mo.NOW <$> noteVDef--stepsToQuotaOp :: Parser Mo.ParsedInstr-stepsToQuotaOp = do void $ symbol' "STEPS_TO_QUOTA"; Mo.STEPS_TO_QUOTA <$> noteVDef---- Operations on bytes-packOp :: Parser Mo.ParsedInstr-packOp = do void $ symbol' "PACK"; Mo.PACK <$> noteVDef--unpackOp :: Parser Mo.ParsedInstr-unpackOp = do symbol' "UNPACK"; v <- noteVDef; Mo.UNPACK v <$> type_---- Cryptographic Primitives--checkSigOp :: Parser Mo.ParsedInstr-checkSigOp = do void $ symbol' "CHECK_SIGNATURE"; Mo.CHECK_SIGNATURE <$> noteVDef--blake2BOp :: Parser Mo.ParsedInstr-blake2BOp = do void $ symbol' "BLAKE2B"; Mo.BLAKE2B <$> noteVDef--sha256Op :: Parser Mo.ParsedInstr-sha256Op = do void $ symbol' "SHA256"; Mo.SHA256 <$> noteVDef--sha512Op :: Parser Mo.ParsedInstr-sha512Op = do void $ symbol' "SHA512"; Mo.SHA512 <$> noteVDef--hashKeyOp :: Parser Mo.ParsedInstr-hashKeyOp = do void $ symbol' "HASH_KEY"; Mo.HASH_KEY <$> noteVDef--{- Type operations -}-castOp :: Parser Mo.ParsedInstr-castOp = do void $ symbol' "CAST"; Mo.CAST <$> noteVDef <*> type_;--renameOp :: Parser Mo.ParsedInstr-renameOp = do void $ symbol' "RENAME"; Mo.RENAME <$> noteVDef--isNatOp :: Parser Mo.ParsedInstr-isNatOp = do void $ symbol' "ISNAT"; Mo.ISNAT <$> noteVDef--intOp :: Parser Mo.ParsedInstr-intOp = do void $ symbol' "INT"; Mo.INT <$> noteVDef------------------------------------------------------------------------------------ Macro Parsers---------------------------------------------------------------------------------cmpOp :: Parser Mo.ParsedInstr-cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp--macro :: Parser Mo.Macro-macro = do symbol' "CMP"; a <- cmpOp; Mo.CMP a <$> noteVDef-  <|> do symbol' "IF_SOME"; a <- ops; Mo.IF_SOME a <$> ops-  <|> do symbol' "FAIL"; return Mo.FAIL-  <|> do void $ symbol' "ASSERT_CMP"; Mo.ASSERT_CMP <$> cmpOp-  <|> do symbol' "ASSERT_NONE"; return Mo.ASSERT_NONE-  <|> do symbol' "ASSERT_SOME"; return Mo.ASSERT_SOME-  <|> do symbol' "ASSERT_LEFT"; return Mo.ASSERT_LEFT-  <|> do symbol' "ASSERT_RIGHT"; return Mo.ASSERT_RIGHT-  <|> do void $ symbol' "ASSERT_"; Mo.ASSERTX <$> cmpOp-  <|> do symbol' "ASSERT"; return Mo.ASSERT-  <|> do string' "DI"; n <- num "I"; symbol' "P"; Mo.DIIP (n + 1) <$> ops-  <|> do string' "DU"; n <- num "U"; symbol' "P"; Mo.DUUP (n + 1) <$> noteVDef-  <|> unpairMac-  <|> cadrMac-  <|> setCadrMac-  where-   num str = fromIntegral . length <$> some (string' str)--pairMac :: Parser Mo.Macro-pairMac = do-  a <- pairMacInner-  symbol' "R"-  (tn, vn, fns) <- permute3Def noteTDef noteV (some noteF)-  let ps = Macro.mapLeaves ((Mo.noAnn,) <$> fns) a-  return $ Mo.PAPAIR ps tn vn--pairMacInner :: Parser Mo.PairStruct-pairMacInner = do-  string' "P"-  l <- (string' "A" >> return (Mo.F (Mo.noAnn, Mo.noAnn))) <|> pairMacInner-  r <- (string' "I" >> return (Mo.F (Mo.noAnn, Mo.noAnn))) <|> pairMacInner-  return $ Mo.P l r--unpairMac :: Parser Mo.Macro-unpairMac = do-  string' "UN"-  a <- pairMacInner-  symbol' "R"-  (vns, fns) <- permute2Def (some noteV) (some noteF)-  return $ Mo.UNPAIR (Macro.mapLeaves (zip vns fns) a)--cadrMac :: Parser Mo.Macro-cadrMac = lexeme $ do-  string' "C"-  a <- some $ try $ cadrInner <* notFollowedBy (string' "R")-  b <- cadrInner-  symbol' "R"-  (vn, fn) <- notesVF-  return $ Mo.CADR (a ++ pure b) vn fn--cadrInner :: Parser Mo.CadrStruct-cadrInner = (string' "A" >> return Mo.A) <|> (string' "D" >> return Mo.D)--setCadrMac :: Parser Mo.Macro-setCadrMac = do-  string' "SET_C"-  a <- some cadrInner-  symbol' "R"-  (v, f) <- notesVF-  return $ Mo.SET_CADR a v f--mapCadrMac :: Parser Mo.Macro-mapCadrMac = do-  string' "MAP_C"-  a <- some cadrInner-  symbol' "R"-  (v, f) <- notesVF-  Mo.MAP_CADR a v f <$> ops--ifCmpMac :: Parser Mo.Macro-ifCmpMac = symbol' "IFCMP" >> Mo.IFCMP <$> cmpOp <*> noteVDef <*> ops <*> ops--ifOrIfX :: Parser Mo.ParsedOp-ifOrIfX = do-  symbol' "IF"-  a <- eitherP cmpOp ops-  case a of-    Left cmp -> Mo.Mac <$> (Mo.IFX cmp <$> ops <*> ops)-    Right op -> Mo.Prim <$> (Mo.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 Mo.ParsedOp-primOrMac = ((Mo.Mac <$> ifCmpMac) <|> ifOrIfX)-  <|> ((Mo.Mac <$> mapCadrMac) <|> (Mo.Prim <$> mapOp))-  <|> (try (Mo.Prim <$> pairOp) <|> Mo.Mac <$> pairMac)------------------------------------------------------------------------------------ Morley Instructions----------------------------------------------------------------------------------nopInstr :: Parser Mo.ParsedUExtInstr-nopInstr = choice [stackOp, testAssertOp, printOp]--stackOp :: Parser Mo.ParsedUExtInstr-stackOp = symbol' "STACKTYPE" >> Mo.STACKTYPE <$> stackType--testAssertOp :: Parser Mo.ParsedUExtInstr-testAssertOp = symbol' "TEST_ASSERT" >> Mo.UTEST_ASSERT <$> testAssert--printOp :: Parser Mo.ParsedUExtInstr-printOp = symbol' "PRINT" >> Mo.UPRINT <$> printComment--testAssert :: Parser Mo.ParsedUTestAssert-testAssert = do-  n <- lexeme (T.pack <$> some alphaNumChar)-  c <- printComment-  o <- ops-  return $ Mo.UTestAssert n c o--printComment :: Parser Mo.PrintComment-printComment = do-  string "\""-  let validChar = T.pack <$> some (satisfy (\x -> x /= '%' && x /= '"'))-  c <- many (Right <$> stackRef <|> Left <$> validChar)-  symbol "\""-  return $ Mo.PrintComment c--stackRef :: Parser Mo.StackRef-stackRef = do-  string "%"-  n <- brackets' L.decimal-  return $ Mo.StackRef n--stackType :: Parser Mo.StackTypePattern-stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)-  where-    emptyStk = try $ symbol "]" >> return Mo.StkEmpty-    stkRest = try $ symbol "..." >> symbol "]" >> return Mo.StkRest-    stkCons = try $ do-      t <- tyVar-      s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk-      return $ Mo.StkCons t s
− src/Morley/Parser/Annotations.hs 
@@ -1,89 +0,0 @@-module Morley.Parser.Annotations-  ( note-  , noteT-  , noteV-  , noteF-  , noteF2-  , noteTDef-  , noteVDef-  , _noteFDef-  , notesTVF-  , notesTVF2-  , notesTV-  , notesVF-  , fieldType-  , permute2Def-  , permute3Def-  ) where--import Prelude hiding (many, note, some, try)--import Control.Applicative.Permutations-  (runPermutation, toPermutationWithDefault)-import Data.Char (isAlpha, isAlphaNum, isAscii)-import qualified Data.Text as T-import Text.Megaparsec (satisfy, takeWhileP, try)-import Text.Megaparsec.Char (string)--import Morley.Default-import Morley.Lexer-import Morley.Types (Parser)-import qualified Morley.Types as Mo---- General T/V/F Annotation parser-note :: T.Text -> Parser T.Text-note c = lexeme $ string c >> (note' <|> emptyNote)-  where-    emptyNote = pure ""-    note' = do-      a <- string "@"-           <|> string "%%"-           <|> string "%"-           <|> T.singleton <$> satisfy (\ x -> isAlpha x && isAscii x)-      let validChar x =-            isAscii x && (isAlphaNum x || x == '\\' || x == '.' || x == '_')-      b <- takeWhileP Nothing validChar-      return $ T.append a b--noteT :: Parser Mo.TypeAnn-noteT = Mo.ann <$> note ":"--noteV :: Parser Mo.VarAnn-noteV = Mo.ann <$> note "@"--noteF :: Parser Mo.FieldAnn-noteF = Mo.ann <$> note "%"--noteF2 :: Parser (Mo.FieldAnn, Mo.FieldAnn)-noteF2 = do a <- noteF; b <- noteF; return (a, b)--parseDef :: Default a => Parser a -> Parser a-parseDef a = try a <|> pure def--noteTDef :: Parser Mo.TypeAnn-noteTDef = parseDef noteT--noteVDef :: Parser Mo.VarAnn-noteVDef = parseDef noteV--_noteFDef :: Parser Mo.FieldAnn-_noteFDef = parseDef noteF--notesTVF :: Parser (Mo.TypeAnn, Mo.VarAnn, Mo.FieldAnn)-notesTVF = permute3Def noteT noteV noteF--notesTVF2 :: Parser (Mo.TypeAnn, Mo.VarAnn, (Mo.FieldAnn, Mo.FieldAnn))-notesTVF2 = permute3Def noteT noteV noteF2--notesTV :: Parser (Mo.TypeAnn, Mo.VarAnn)-notesTV = permute2Def noteT noteV--notesVF :: Parser (Mo.VarAnn, Mo.FieldAnn)-notesVF  = permute2Def noteV noteF--fieldType :: Default a-          => Parser a-          -> Parser (a, Mo.TypeAnn)-fieldType fp = runPermutation $-  (,) <$> toPermutationWithDefault  def     fp-      <*> toPermutationWithDefault Mo.noAnn noteT
− src/Morley/Parser/Helpers.hs 
@@ -1,9 +0,0 @@-module Morley.Parser.Helpers-  ( sepEndBy1-  ) where--import qualified Data.List.NonEmpty as NE-import qualified Text.Megaparsec as P--sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)-sepEndBy1 = fmap NE.fromList ... P.sepEndBy1
− src/Morley/Runtime.hs 
@@ -1,468 +0,0 @@--- | Interpreter of a contract in Morley language.--module Morley.Runtime-       (-         -- * High level interface for end user-         originateContract-       , runContract-       , transfer--       -- * Other helpers-       , parseContract-       , parseExpandContract-       , readAndParseContract-       , prepareContract--       -- * Re-exports-       , ContractState (..)-       , AddressState (..)-       , TxData (..)--       -- * For testing-       , InterpreterOp (..)-       , InterpreterRes (..)-       , InterpreterError (..)-       , interpreterPure-       ) where--import Control.Lens (at, makeLenses, (%=), (.=), (<>=))-import Control.Monad.Except (Except, runExcept, throwError)-import qualified Data.Map.Strict as Map-import Data.Text.IO (getContents)-import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+))-import Named ((:!), (:?), arg, argDef, defaults, (!))-import Text.Megaparsec (parse)--import Michelson.Interpret-  (ContractEnv(..), InterpretUntypedError(..), InterpretUntypedResult(..), InterpreterState(..),-  RemainingSteps(..))-import Michelson.TypeCheck (TCError)-import Michelson.Typed-  (CreateContract(..), Instr, Operation(..), TransferTokens(..), Val(..), convertContract,-  unsafeValToValue)-import Michelson.Untyped-  (Contract(..), OriginationOperation(..), UntypedContract, UntypedValue, mkContractAddress)-import Morley.Ext (interpretMorleyUntyped, typeCheckMorleyContract)-import Morley.Macro (expandContract)-import qualified Morley.Parser as P-import Morley.Runtime.GState-import Morley.Runtime.TxData-import Morley.Types (MorleyLogs(..), ParsedOp)-import Tezos.Address (Address(..))-import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez)-import Tezos.Crypto (parseKeyHash)--------------------------------------------------------------------------------- Auxiliary types--------------------------------------------------------------------------------- | Operations executed by interpreter.--- In our model one Michelson's operation (`operation` type in Michelson)--- corresponds to 0 or 1 interpreter operation.------ Note: 'Address' is not part of 'TxData', because 'TxData' is--- supposed to be provided by the user, while 'Address' can be--- computed by our code.-data InterpreterOp-  = OriginateOp !OriginationOperation-  -- ^ Originate a contract.-  | TransferOp Address-               TxData-  -- ^ Send a transaction to given address which is assumed to be the-  -- address of an originated contract.-  deriving (Show)---- | Result of a single execution of interpreter.-data InterpreterRes = InterpreterRes-  { _irGState :: !GState-  -- ^ New 'GState'.-  , _irOperations :: [InterpreterOp]-  -- ^ List of operations to be added to the operations queue.-  , _irUpdates :: ![GStateUpdate]-  -- ^ Updates applied to 'GState'.-  , _irInterpretResults :: [(Address, InterpretUntypedResult MorleyLogs)]-  -- ^ During execution a contract can print logs and in the end it returns-  -- a pair. All logs and returned values are kept until all called contracts-  -- are executed. In the end they are printed.-  , _irSourceAddress :: !(Maybe Address)-  -- ^ As soon as transfer operation is encountered, this address is-  -- set to its input.-  , _irRemainingSteps :: !RemainingSteps-  -- ^ Now much gas all remaining executions can consume.-  } deriving (Show)--makeLenses ''InterpreterRes---- | Errors that can happen during contract interpreting.-data InterpreterError-  = IEUnknownContract !Address-  -- ^ The interpreted contract hasn't been originated.-  | IEInterpreterFailed !Address-                        !(InterpretUntypedError MorleyLogs)-  -- ^ Interpretation of Michelson contract failed.-  | IEAlreadyOriginated !Address-                        !ContractState-  -- ^ A contract is already originated.-  | IEUnknownSender !Address-  -- ^ Sender address is unknown.-  | IEUnknownManager !Address-  -- ^ Manager address is unknown.-  | IENotEnoughFunds !Address !Mutez-  -- ^ Sender doesn't have enough funds.-  | IEFailedToApplyUpdates !GStateUpdateError-  -- ^ Failed to apply updates to GState.-  | IEIllTypedContract !TCError-  -- ^ A contract is ill-typed.-  deriving (Show)--instance Buildable InterpreterError where-  build =-    \case-      IEUnknownContract addr -> "The contract is not originated " +| addr |+ ""-      IEInterpreterFailed addr err ->-        "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""-      IEAlreadyOriginated addr cs ->-        "The following contract is already originated: " +| addr |+-        ", " +| cs |+ ""-      IEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""-      IEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""-      IENotEnoughFunds addr amount ->-        "The sender (" +| addr |+-        ") doesn't  have enough funds (has only " +| amount |+ ")"-      IEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""-      IEIllTypedContract err -> "The contract is ill-typed " +| err |+ ""--instance Exception InterpreterError where-  displayException = pretty--------------------------------------------------------------------------------- Interface--------------------------------------------------------------------------------- | Parse a contract from 'Text'.-parseContract ::-     Maybe FilePath -> Text -> Either P.ParserException (Contract ParsedOp)-parseContract mFileName =-  first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)---- | Parse a contract from 'Text' and expand macros.-parseExpandContract ::-     Maybe FilePath -> Text -> Either P.ParserException UntypedContract-parseExpandContract mFileName = fmap expandContract . parseContract mFileName---- | Read and parse a contract from give path or `stdin` (if the--- argument is 'Nothing'). The contract is not expanded.-readAndParseContract :: Maybe FilePath -> IO (Contract ParsedOp)-readAndParseContract mFilename = do-  code <- readCode mFilename-  either throwM pure $ parseContract mFilename code-  where-    readCode :: Maybe FilePath -> IO Text-    readCode = maybe getContents readFile---- | Read a contract using 'readAndParseContract', expand and--- flatten. The contract is not type checked.-prepareContract :: Maybe FilePath -> IO UntypedContract-prepareContract mFile = expandContract <$> readAndParseContract mFile---- | Originate a contract. Returns the address of the originated--- contract.-originateContract ::-     FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address-originateContract dbPath origination verbose =-  -- pass 100500 as maxSteps, because it doesn't matter for origination,-  -- as well as 'now'-  mkContractAddress origination <$-  interpreter Nothing 100500 dbPath [OriginateOp origination] verbose-  ! defaults---- | Run a contract. The contract is originated first (if it's not--- already) and then we pretend that we send a transaction to it.-runContract-  :: Maybe Timestamp-  -> Word64-  -> Mutez-  -> FilePath-  -> UntypedValue-  -> UntypedContract-  -> TxData-  -> "verbose" :! Bool-  -> "dryRun" :! Bool-  -> IO ()-runContract maybeNow maxSteps initBalance dbPath storageValue contract txData-  verbose (arg #dryRun -> dryRun) =-  interpreter maybeNow maxSteps dbPath operations verbose ! #dryRun dryRun-  where-    -- We hardcode some random key hash here as delegate to make sure that:-    -- 1. Contract's address won't clash with already originated one (because-    -- it may have different storage value which may be confusing).-    -- 2. If one uses this functionality twice with the same contract and-    -- other data, the contract will have the same address.-    delegate =-      either (error . mappend "runContract can't parse delegate: " . pretty) id $-      parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"-    origination = OriginationOperation-      { ooManager = genesisKeyHash-      , ooDelegate = Just delegate-      , ooSpendable = False-      , ooDelegatable = False-      , ooBalance = initBalance-      , ooStorage = storageValue-      , ooContract = contract-      }-    addr = mkContractAddress origination-    operations =-      [ OriginateOp origination-      , TransferOp addr txData-      ]---- | Send a transaction to given address with given parameters.-transfer ::-     Maybe Timestamp-  -> Word64-  -> FilePath-  -> Address-  -> TxData-  -> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()-transfer maybeNow maxSteps dbPath destination txData =-  interpreter maybeNow maxSteps dbPath [TransferOp destination txData]--------------------------------------------------------------------------------- Interpreter--------------------------------------------------------------------------------- | Interpret a contract on some global state (read from file) and--- transaction data (passed explicitly).-interpreter ::-     Maybe Timestamp-  -> Word64-  -> FilePath-  -> [InterpreterOp]-  -> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()-interpreter maybeNow maxSteps dbPath operations-  (arg #verbose -> verbose)-  (argDef #dryRun False -> dryRun)-    = do-  now <- maybe getCurrentTime pure maybeNow-  gState <- readGState dbPath-  let eitherRes =-        interpreterPure now (RemainingSteps maxSteps) gState operations-  InterpreterRes {..} <- either throwM pure eitherRes-  mapM_ printInterpretResult _irInterpretResults-  when (verbose && not (null _irUpdates)) $ do-    fmtLn $ nameF "Updates:" (blockListF _irUpdates)-    putTextLn $ "Remaining gas: " <> pretty _irRemainingSteps-  unless dryRun $-    writeGState dbPath _irGState-  where-    printInterpretResult-      :: (Address, InterpretUntypedResult MorleyLogs) -> IO ()-    printInterpretResult (addr, InterpretUntypedResult {..}) = do-      putTextLn $ "Executed contract " <> pretty addr-      case iurOps of-        [] -> putTextLn "It didn't return any operations"-        _ -> fmt $ nameF "It returned operations:" (blockListF iurOps)-      putTextLn $-        "It returned storage: " <> pretty (unsafeValToValue iurNewStorage)-      let MorleyLogs logs = isExtState iurNewState-      unless (null logs) $-        mapM_ putTextLn logs-      putTextLn "" -- extra break line to separate logs from two sequence contracts---- | Implementation of interpreter outside 'IO'.  It reads operations,--- interprets them one by one and updates state accordingly.-interpreterPure ::-  Timestamp -> RemainingSteps -> GState -> [InterpreterOp] -> Either InterpreterError InterpreterRes-interpreterPure now maxSteps gState ops =-    runExcept (execStateT (statefulInterpreter now) initialState)-  where-    initialState = InterpreterRes-      { _irGState = gState-      , _irOperations = ops-      , _irUpdates = mempty-      , _irInterpretResults = []-      , _irSourceAddress = Nothing-      , _irRemainingSteps = maxSteps-      }--statefulInterpreter-  :: Timestamp-  -> StateT InterpreterRes (Except InterpreterError) ()-statefulInterpreter now = do-  curGState <- use irGState-  mSourceAddr <- use irSourceAddress-  remainingSteps <- use irRemainingSteps-  use irOperations >>= \case-    [] -> pass-    (op:opsTail) ->-      either throwError (processIntRes opsTail) $-      interpretOneOp now remainingSteps mSourceAddr curGState op-  where-    processIntRes opsTail InterpreterRes {..} = do-      irGState .= _irGState-      irOperations .= opsTail <> _irOperations-      irUpdates <>= _irUpdates-      irInterpretResults <>= _irInterpretResults-      irSourceAddress %= (<|> _irSourceAddress)-      irRemainingSteps .= _irRemainingSteps-      statefulInterpreter now---- | Run only one interpreter operation and update 'GState' accordingly.-interpretOneOp-  :: Timestamp-  -> RemainingSteps-  -> Maybe Address-  -> GState-  -> InterpreterOp-  -> Either InterpreterError InterpreterRes-interpretOneOp _ remainingSteps _ gs (OriginateOp origination) = do-  void $ first IEIllTypedContract $-    typeCheckMorleyContract (ooContract origination)-  let originatorAddress = KeyAddress (ooManager origination)-  originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of-    Nothing -> Left (IEUnknownManager originatorAddress)-    Just (asBalance -> oldBalance)-      | oldBalance < ooBalance origination ->-        Left (IENotEnoughFunds originatorAddress oldBalance)-      | otherwise ->-        -- Subtraction is safe because we have checked its-        -- precondition in guard.-        Right (oldBalance `unsafeSubMutez` ooBalance origination)-  let-    updates =-      [ GSAddAddress address (ASContract contractState)-      , GSSetBalance originatorAddress originatorBalance-      ]-  case applyUpdates updates gs of-    Left _ -> Left (IEAlreadyOriginated address contractState)-    Right newGS -> Right $-      InterpreterRes-      { _irGState = newGS-      , _irOperations = mempty-      , _irUpdates = updates-      , _irInterpretResults = []-      , _irSourceAddress = Nothing-      , _irRemainingSteps = remainingSteps-      }-  where-    contractState = ContractState-      { csBalance = ooBalance origination-      , csStorage = ooStorage origination-      , csContract = ooContract origination-      }-    address = mkContractAddress origination-interpretOneOp now remainingSteps mSourceAddr gs (TransferOp addr txData) = do-    let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr-    let senderAddr = tdSenderAddress txData-    decreaseSenderBalance <- case addresses ^. at senderAddr of-      Nothing -> Left (IEUnknownSender senderAddr)-      Just (asBalance -> balance)-        | balance < tdAmount txData ->-          Left (IENotEnoughFunds senderAddr balance)-        | otherwise ->-          -- Subtraction is safe because we have checked its-          -- precondition in guard.-          Right (GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData))-    let onlyUpdates updates = Right (updates, [], Nothing, remainingSteps)-    (otherUpdates, sideEffects, maybeInterpretRes, newRemSteps)-        <- case (addresses ^. at addr, addr) of-      (Nothing, ContractAddress _) ->-        Left (IEUnknownContract addr)-      (Nothing, KeyAddress _) -> do-        let-          addrState = ASSimple (tdAmount txData)-          upd = GSAddAddress addr addrState-        onlyUpdates [upd]-      (Just (ASSimple oldBalance), _) -> do-        -- can't overflow if global state is correct (because we can't-        -- create money out of nowhere)-        let-          newBalance = oldBalance `unsafeAddMutez` tdAmount txData-          upd = GSSetBalance addr newBalance-        onlyUpdates [upd]-      (Just (ASContract cs), _) -> do-        let-          contract = csContract cs-          contractEnv = ContractEnv-            { ceNow = now-            , ceMaxSteps = remainingSteps-            , ceBalance = csBalance cs-            , ceContracts = Map.mapMaybe extractContract addresses-            , ceSelf = addr-            , ceSource = sourceAddr-            , ceSender = senderAddr-            , ceAmount = tdAmount txData-            }-        iur@InterpretUntypedResult-          { iurOps = sideEffects-          , iurNewStorage = newValue-          , iurNewState = InterpreterState _ newRemainingSteps-          }-          <- first (IEInterpreterFailed addr) $-                interpretMorleyUntyped contract (tdParameter txData)-                                 (csStorage cs) contractEnv-        let-          newValueU = unsafeValToValue newValue-          -- can't overflow if global state is correct (because we can't-          -- create money out of nowhere)-          newBalance = csBalance cs `unsafeAddMutez` tdAmount txData-          updBalance = GSSetBalance addr newBalance-          updStorage = GSSetStorageValue addr newValueU-          updates =-            [ updBalance-            , updStorage-            ]-        Right (updates, sideEffects, Just iur, newRemainingSteps)--    let-      updates = decreaseSenderBalance:otherUpdates--    newGState <- first IEFailedToApplyUpdates $ applyUpdates updates gs--    return InterpreterRes-      { _irGState = newGState-      , _irOperations = mapMaybe (convertOp addr) sideEffects-      , _irUpdates = updates-      , _irInterpretResults = maybe mempty (one . (addr,)) maybeInterpretRes-      , _irSourceAddress = Just sourceAddr-      , _irRemainingSteps = newRemSteps-      }-  where-    addresses :: Map Address AddressState-    addresses = gsAddresses gs--    extractContract :: AddressState -> Maybe UntypedContract-    extractContract =-      \case ASSimple {} -> Nothing-            ASContract cs -> Just (csContract cs)--------------------------------------------------------------------------------- Simple helpers--------------------------------------------------------------------------------- The argument is the address of the contract that generation this operation.-convertOp :: Address -> Operation Instr -> Maybe InterpreterOp-convertOp interpretedAddr =-  \case-    OpTransferTokens tt ->-      let txData =-            TxData-              { tdSenderAddress = interpretedAddr-              , tdParameter = unsafeValToValue (ttContractParameter tt)-              , tdAmount = ttAmount tt-              }-          VContract destAddress = ttContract tt-       in Just (TransferOp destAddress txData)-    OpSetDelegate {} -> Nothing-    OpCreateAccount {} -> Nothing-    OpCreateContract cc ->-      let origination = OriginationOperation-            { ooManager = ccManager cc-            , ooDelegate = ccDelegate cc-            , ooSpendable = ccSpendable cc-            , ooDelegatable = ccDelegatable cc-            , ooBalance = ccBalance cc-            , ooStorage = unsafeValToValue (ccStorageVal cc)-            , ooContract = convertContract (ccContractCode cc)-            }-       in Just (OriginateOp origination)
− src/Morley/Runtime/GState.hs 
@@ -1,227 +0,0 @@--- | Global blockchain state (emulated).--module Morley.Runtime.GState-       (-         -- * Auxiliary types-         ContractState (..)-       , AddressState (..)-       , asBalance--       -- * GState-       , GState (..)-       , genesisAddress-       , genesisAddressText-       , genesisKeyHash-       , initGState-       , readGState-       , writeGState--       -- * Operations on GState-       , GStateUpdate (..)-       , GStateUpdateError (..)-       , applyUpdate-       , applyUpdates-       ) where--import Control.Lens (at)-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encode.Pretty as Aeson-import Data.Aeson.Options (defaultOptions)-import Data.Aeson.TH (deriveJSON)-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map.Strict as Map-import Fmt (genericF, pretty, (+|), (|+))-import Formatting.Buildable (Buildable(build))-import System.IO.Error (IOError, isDoesNotExistError)--import Michelson.Untyped (UntypedContract, UntypedValue)-import Morley.Types ()-import Tezos.Address (Address(..))-import Tezos.Core (Mutez)-import Tezos.Crypto (KeyHash, parseKeyHash)---- | State of a contract with code.-data ContractState = ContractState-  { csBalance :: !Mutez-  -- ^ Amount of mutez owned by this contract.-  , csStorage :: !UntypedValue-  -- ^ Storage value associated with this contract.-  , csContract :: !UntypedContract-  -- ^ Contract itself (untyped).-  } deriving (Show, Generic, Eq)--instance Buildable ContractState where-  build = genericF--deriveJSON defaultOptions ''ContractState---- | State of an arbitrary address.-data AddressState-  = ASSimple !Mutez-  -- ^ For contracts without code we store only its balance.-  | ASContract !ContractState-  -- ^ For contracts with code we store more state represented by-  -- 'ContractState'.-  deriving (Show, Generic, Eq)--instance Buildable AddressState where-  build =-    \case-      ASSimple balance -> "Balance = " +| balance |+ ""-      ASContract cs -> build cs--deriveJSON defaultOptions ''AddressState---- | Extract balance from 'AddressState'.-asBalance :: AddressState -> Mutez-asBalance =-  \case-    ASSimple b -> b-    ASContract cs -> csBalance cs---- | Persistent data passed to Morley contracts which can be updated--- as result of contract execution.-data GState = GState-  { gsAddresses :: Map Address AddressState-  -- ^ All known addresses and their state.-  } deriving Show--deriveJSON defaultOptions ''GState---- | Initially this address has a lot of money.-genesisAddressText :: Text-genesisAddressText = "tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw"---- | KeyHash of genesis address.-genesisKeyHash :: KeyHash-genesisKeyHash =-  either (error . mappend "genesisKeyHash: " . pretty) id $-  parseKeyHash genesisAddressText---- | Initially this address has a lot of money.-genesisAddress :: Address-genesisAddress = KeyAddress genesisKeyHash---- | Initial 'GState'. It's supposed to be used if no 'GState' is--- provided. For now it's empty, but we can hardcode some dummy data--- in the future.-initGState :: GState-initGState =-  GState-  { gsAddresses = Map.fromList-    [ (genesisAddress, ASSimple maxBound)-    ]-  }--data GStateParseError =-  GStateParseError String-  deriving Show--instance Exception GStateParseError where-  displayException (GStateParseError str) = "Failed to parse GState: " <> str---- | Read 'GState' from a file.-readGState :: FilePath -> IO GState-readGState fp = (LBS.readFile fp >>= parseFile) `catch` onExc-  where-    parseFile :: LByteString -> IO GState-    parseFile lByteString =-      if length lByteString == 0-      then pure initGState-      else (either (throwM . GStateParseError) pure . Aeson.eitherDecode') lByteString-    onExc :: IOError -> IO GState-    onExc exc-      | isDoesNotExistError exc = pure initGState-      | otherwise = throwM exc---- | Write 'GState' to a file.-writeGState :: FilePath -> GState -> IO ()-writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs)-  where-    config =-      Aeson.defConfig-      { Aeson.confTrailingNewline = True-      }---- | Updates that can be applied to 'GState'.-data GStateUpdate-  = GSAddAddress !Address-                 !AddressState-  | GSSetStorageValue !Address-                      !UntypedValue-  | GSSetBalance !Address-                 !Mutez-  deriving (Show, Eq)--instance Buildable GStateUpdate where-  build =-    \case-      GSAddAddress addr st ->-        "Add address " +| addr |+ " with state " +| st |+ ""-      GSSetStorageValue addr val ->-        "Set storage value of address " +| addr |+ " to " +| val |+ ""-      GSSetBalance addr balance ->-        "Set balance of address " +| addr |+ " to " +| balance |+ ""--data GStateUpdateError-  = GStateAddressExists !Address-  | GStateUnknownAddress !Address-  | GStateNotContract !Address-  deriving (Show)--instance Buildable GStateUpdateError where-  build =-    \case-      GStateAddressExists addr -> "Address already exists: " <> build addr-      GStateUnknownAddress addr -> "Unknown address: " <> build addr-      GStateNotContract addr -> "Address doesn't have contract: " <> build addr---- | Apply 'GStateUpdate' to 'GState'.-applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState-applyUpdate =-  \case-    GSAddAddress addr st ->-      maybeToRight (GStateAddressExists addr) . addAddress addr st-    GSSetStorageValue addr newValue -> setStorageValue addr newValue-    GSSetBalance addr newBalance -> setBalance addr newBalance---- | Apply a list of 'GStateUpdate's to 'GState'.-applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState-applyUpdates = flip (foldM (flip applyUpdate))---- | Add an address if it hasn't been added before.-addAddress :: Address -> AddressState -> GState -> Maybe GState-addAddress addr st gs-    | addr `Map.member` accounts = Nothing-    | otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st})-  where-    accounts = gsAddresses gs---- | Updare storage value associated with given address.-setStorageValue ::-     Address -> UntypedValue -> GState -> Either GStateUpdateError GState-setStorageValue addr newValue = updateAddressState addr modifier-  where-    modifier (ASSimple _) = Left (GStateNotContract addr)-    modifier (ASContract cs) = Right $ ASContract $ cs { csStorage = newValue }---- | Updare storage value associated with given address.-setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState-setBalance addr newBalance = updateAddressState addr (Right . modifier)-  where-    modifier (ASSimple _) = ASSimple newBalance-    modifier (ASContract cs) = ASContract (cs {csBalance = newBalance})--updateAddressState ::-     Address-  -> (AddressState -> Either GStateUpdateError AddressState)-  -> GState-  -> Either GStateUpdateError GState-updateAddressState addr f gs =-  case addresses ^. at addr of-    Nothing -> Left (GStateUnknownAddress addr)-    Just as -> do-      newState <- f as-      return $ gs { gsAddresses = addresses & at addr .~ Just newState }-  where-    addresses = gsAddresses gs
− src/Morley/Runtime/TxData.hs 
@@ -1,19 +0,0 @@--- | 'TxData' type and associated functionality.--module Morley.Runtime.TxData-       ( TxData (..)-       ) where--import Michelson.Untyped (UntypedValue)-import Morley.Types (ExpandedUExtInstr)-import Tezos.Address (Address)-import Tezos.Core (Mutez)---- | Data associated with a particular transaction.-data TxData = TxData-  { tdSenderAddress :: !Address-  , tdParameter :: !UntypedValue-  , tdAmount :: !Mutez-  }--deriving instance Show ExpandedUExtInstr => Show TxData
− src/Morley/Test.hs 
@@ -1,65 +0,0 @@--- | Module containing some utilities for testing Michelson contracts using--- Haskell testing frameworks (hspec and QuickCheck in particular).--- It's Morley testing EDSL.--module Morley.Test-  ( -- * Importing a contract-    specWithContract-  , specWithTypedContract-  , specWithUntypedContract--  -- * Unit testing-  , ContractReturn-  , ContractPropValidator-  , contractProp-  , contractPropVal--  -- * Integrational testing-  -- ** Testing engine-  , IntegrationalValidator-  , SuccessValidator-  , IntegrationalScenario-  , integrationalTestExpectation-  , integrationalTestProperty-  , originate-  , transfer-  , validate-  , setMaxSteps-  , setNow--  -- ** Validators-  , composeValidators-  , composeValidatorsList-  , expectAnySuccess-  , expectStorageUpdate-  , expectStorageUpdateConst-  , expectBalance-  , expectStorageConst-  , expectGasExhaustion-  , expectMichelsonFailed--  -- ** Various-  , TxData (..)-  , genesisAddress--  -- * General utilities-  , failedProp-  , succeededProp-  , qcIsLeft-  , qcIsRight--  -- * Dummy values-  , dummyContractEnv--  -- * Arbitrary data-  , minTimestamp-  , maxTimestamp-  , midTimestamp-  ) where--import Morley.Test.Dummy-import Morley.Test.Gen-import Morley.Test.Import-import Morley.Test.Integrational-import Morley.Test.Unit-import Morley.Test.Util
− src/Morley/Test/Dummy.hs 
@@ -1,58 +0,0 @@--- | Dummy data to be used in tests where it's not essential.--module Morley.Test.Dummy-  ( dummyNow-  , dummyMaxSteps-  , dummyContractEnv-  , dummyOrigination-  ) where--import Michelson.Interpret (ContractEnv(..), RemainingSteps)-import Michelson.Untyped-import Morley.Runtime.GState (genesisAddress, genesisKeyHash)-import Tezos.Core (Timestamp(..), unsafeMkMutez)---- | Dummy timestamp, can be used to specify current `NOW` value or--- maybe something else.-dummyNow :: Timestamp-dummyNow = Timestamp 100---- | Dummy value for maximal number of steps a contract can--- make. Intentionally quite large, because most likely if you use--- dummy value you don't want the interpreter to stop due to gas--- exhaustion. On the other hand, it probably still prevents the--- interpreter from working for eternity.-dummyMaxSteps :: RemainingSteps-dummyMaxSteps = 100500---- | Dummy 'ContractEnv' with some reasonable hardcoded values. You--- can override values you are interested in using record update--- syntax.-dummyContractEnv :: ContractEnv-dummyContractEnv = ContractEnv-  { ceNow = dummyNow-  , ceMaxSteps = dummyMaxSteps-  , ceBalance = unsafeMkMutez 100-  , ceContracts = mempty-  , ceSelf = genesisAddress-  , ceSource = genesisAddress-  , ceSender = genesisAddress-  , ceAmount = unsafeMkMutez 100-  }---- | 'OriginationOperation' with most data hardcoded to some--- reasonable values. Contract and initial values must be passed--- explicitly, because otherwise it hardly makes sense.-dummyOrigination-  :: UntypedValue-  -> UntypedContract-  -> OriginationOperation-dummyOrigination storage contract = OriginationOperation-  { ooManager = genesisKeyHash-  , ooDelegate = Nothing-  , ooSpendable = False-  , ooDelegatable = False-  , ooBalance = unsafeMkMutez 100-  , ooStorage = storage-  , ooContract = contract-  }
− src/Morley/Test/Gen.hs 
@@ -1,76 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}---- | Utilities for arbitrary data generation in property tests.--module Morley.Test.Gen-  ( minTimestamp-  , maxTimestamp-  , midTimestamp-  ) where--import Data.Time.Calendar (Day, addDays, diffDays)-import Data.Time.Clock (UTCTime(..))-import Data.Time.Format (defaultTimeLocale, parseTimeM)-import Test.QuickCheck (Arbitrary(..), choose)--import Michelson.Typed (CT(..), CVal(..), T(..), Val(..))-import Tezos.Core-  (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds,-  unsafeMkMutez)--instance Arbitrary (CVal 'CKeyHash) where-  arbitrary = CvKeyHash <$> arbitrary-instance Arbitrary (CVal 'CMutez) where-  arbitrary = CvMutez <$> arbitrary-instance Arbitrary (CVal 'CInt) where-  arbitrary = CvInt <$> arbitrary-instance Arbitrary (CVal a) => Arbitrary (Val instr ('Tc a)) where-  arbitrary = VC <$> arbitrary-instance Arbitrary (Val instr a) => Arbitrary (Val instr ('TList a)) where-  arbitrary = VList <$> arbitrary-instance Arbitrary (Val instr 'TUnit) where-  arbitrary = pure VUnit-instance (Arbitrary (Val instr a), Arbitrary (Val instr b))-    => Arbitrary (Val instr ('TPair a b)) where-  arbitrary = VPair ... (,) <$> arbitrary <*> arbitrary--minDay :: Day-minDay = fromMaybe (error "failed to parse day 2008-11-01") $-            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01"--maxDay :: Day-maxDay = fromMaybe (error "failed to parse day 2024-11-01") $-            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2024-11-01"--minSec :: Integer-minSec = 0--maxSec :: Integer-maxSec = 86399---- | Minimal (earliest) timestamp used for @Arbitrary (CVal 'CTimestamp)@-minTimestamp :: Timestamp-minTimestamp = timestampFromUTCTime $ UTCTime minDay (fromInteger minSec)---- | Maximal (latest) timestamp used for @Arbitrary (CVal 'CTimestamp)@-maxTimestamp :: Timestamp-maxTimestamp = timestampFromUTCTime $ UTCTime maxDay (fromInteger maxSec)---- | Median of 'minTimestamp' and 'maxTimestamp'.--- Useful for testing (exactly half of generated dates will be before and after--- this date).-midTimestamp :: Timestamp-midTimestamp = timestampFromUTCTime $-  UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay)-          (fromInteger $ (maxSec - minSec) `div` 2)--instance Arbitrary (CVal 'CTimestamp) where-  arbitrary = CvTimestamp <$> arbitrary--instance Arbitrary Mutez where-  arbitrary = unsafeMkMutez <$> choose (unMutez minBound, unMutez maxBound)--instance Arbitrary Timestamp where-  arbitrary =-    timestampFromSeconds @Int <$>-    choose (timestampToSeconds minTimestamp, timestampToSeconds maxTimestamp)
− src/Morley/Test/Import.hs 
@@ -1,107 +0,0 @@--- | Functions to import contracts to be used in tests.--module Morley.Test.Import-  ( readContract-  , specWithContract-  , specWithTypedContract-  , specWithUntypedContract-  , importContract-  , importUntypedContract-  , ImportContractError (..)-  ) where--import Control.Exception (IOException)-import Data.Typeable ((:~:)(..), TypeRep, eqT, typeRep)-import Fmt (Buildable(build), pretty, (+|), (|+), (||+))-import Test.Hspec (Spec, describe, expectationFailure, it, runIO)--import Michelson.TypeCheck (SomeContract(..), TCError)-import Michelson.Typed (Contract)-import qualified Michelson.Untyped as U-import Michelson.Untyped.Aliases (UntypedContract)-import Morley.Ext (typeCheckMorleyContract)-import Morley.Runtime (parseExpandContract, prepareContract)-import Morley.Types (ParserException(..))---- | Import contract and use it in the spec. Both versions of contract are--- passed to the callback function (untyped and typed).------ If contract's import failed, a spec with single failing expectation--- will be generated (so tests will run unexceptionally, but a failing--- result will notify about problem).-specWithContract-  :: (Typeable cp, Typeable st)-  => FilePath -> ((UntypedContract, Contract cp st) -> Spec) -> Spec-specWithContract = specWithContractImpl importContract---- | A version of 'specWithContract' which passes only the typed--- representation of the contract.-specWithTypedContract-  :: (Typeable cp, Typeable st)-  => FilePath -> (Contract cp st -> Spec) -> Spec-specWithTypedContract = specWithContractImpl (fmap snd . importContract)--specWithUntypedContract :: FilePath -> (UntypedContract -> Spec) -> Spec-specWithUntypedContract = specWithContractImpl importUntypedContract--specWithContractImpl-  :: (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec-specWithContractImpl doImport file execSpec =-  either errorSpec (describe ("Test contract " <> file) . execSpec)-    =<< runIO-          ( (Right <$> doImport file)-            `catch` (\(e :: ImportContractError) -> pure $ Left $ displayException e)-            `catch` \(e :: IOException) -> pure $ Left $ displayException e )-  where-    errorSpec = it ("Import contract " <> file) . expectationFailure--readContract-  :: forall cp st .-    (Typeable cp, Typeable st)-  => FilePath -> Text -> Either ImportContractError (UntypedContract, Contract cp st)-readContract filePath txt = do-  contract <- first ICEParse $ parseExpandContract (Just filePath) txt-  SomeContract (instr :: Contract cp' st') _ _-    <- first ICETypeCheck $ typeCheckMorleyContract contract-  case (eqT @cp @cp', eqT @st @st') of-    (Just Refl, Just Refl) -> pure (contract, instr)-    (Nothing, _) -> Left $-      ICEUnexpectedParamType (U.para contract) (typeRep (Proxy @cp))-    _ -> Left (ICEUnexpectedStorageType (U.stor contract) (typeRep (Proxy @st)))---- | Import contract from a given file path.------ This function reads file, parses and type checks contract.------ This function may throw 'IOException' and 'ImportContractError'.-importContract-  :: forall cp st .-    (Typeable cp, Typeable st)-  => FilePath -> IO (UntypedContract, Contract cp st)-importContract file = either throwM pure =<< readContract file <$> readFile file--importUntypedContract :: FilePath -> IO UntypedContract-importUntypedContract = prepareContract . Just---- | Error type for 'importContract' function.-data ImportContractError-  = ICEUnexpectedParamType !U.Type !TypeRep-  | ICEUnexpectedStorageType !U.Type !TypeRep-  | ICEParse !ParserException-  | ICETypeCheck !TCError-  deriving Show--instance Buildable ImportContractError where-  build =-    \case-      ICEUnexpectedParamType actual expected ->-        "Unexpected parameter type: " +| actual |+-        ", expected: " +| expected ||+ ""-      ICEUnexpectedStorageType actual expected ->-        "Unexpected storage type: " +| actual |+-        ", expected: " +| expected ||+ ""-      ICEParse e -> "Failed to parse the contract: " +| e |+ ""-      ICETypeCheck e -> "The contract is ill-typed: " +| e |+ ""--instance Exception ImportContractError where-  displayException = pretty
− src/Morley/Test/Integrational.hs 
@@ -1,286 +0,0 @@--- | Utilities for integrational testing.--- Example tests can be found in the 'morley-test' test suite.--module Morley.Test.Integrational-  (-    -- * Re-exports-    TxData (..)-  , genesisAddress--  -- * Testing engine-  , IntegrationalValidator-  , SuccessValidator-  , IntegrationalScenario-  , integrationalTestExpectation-  , integrationalTestProperty-  , originate-  , transfer-  , validate-  , setMaxSteps-  , setNow--  -- * Validators-  , composeValidators-  , composeValidatorsList-  , expectAnySuccess-  , expectStorageUpdate-  , expectStorageUpdateConst-  , expectBalance-  , expectStorageConst-  , expectGasExhaustion-  , expectMichelsonFailed-  ) where--import Control.Lens (assign, at, makeLenses, (.=), (<>=))-import Control.Monad.Except (Except, runExcept, throwError)-import qualified Data.List as List-import Fmt (blockListF, pretty, (+|), (|+))-import Test.Hspec (Expectation, expectationFailure)-import Test.QuickCheck (Property)--import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps)-import Michelson.Untyped-  (OriginationOperation(..), UntypedContract, UntypedValue, mkContractAddress)-import Morley.Runtime (InterpreterError(..), InterpreterOp(..), InterpreterRes(..), interpreterPure)-import Morley.Runtime.GState-import Morley.Runtime.TxData-import Morley.Test.Dummy-import Morley.Test.Util (failedProp, succeededProp)-import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp)--------------------------------------------------------------------------------- Some internals (they are here because TH makes our very existence much harder)-------------------------------------------------------------------------------data InternalState = InternalState-  { _isMaxSteps :: !RemainingSteps-  , _isNow :: !Timestamp-  , _isGState :: !GState-  , _isOperations :: ![InterpreterOp]-  -- ^ Operations to be interpreted when 'TOValidate' is encountered.-  }--makeLenses ''InternalState--------------------------------------------------------------------------------- Interface--------------------------------------------------------------------------------- | Validator for integrational testing.--- If an error is expected, it should be 'Left' with validator for errors.--- Otherwise it should check final global state and its updates.-type IntegrationalValidator = Either (InterpreterError -> Bool) SuccessValidator---- | Validator for integrational testing that expects successful execution.-type SuccessValidator = (GState -> [GStateUpdate] -> Either Text ())---- | A monad inside which integrational tests can be described using--- do-notation.-type IntegrationalScenarioM = StateT InternalState (Except Text)---- | A dummy data type that ensures that `validate` is called in the--- end of each scenario. It is intentionally not exported.-data Validated = Validated--type IntegrationalScenario = IntegrationalScenarioM Validated---- | Integrational test that executes given operations and validates--- them using given validator. It can fail using 'Expectation'--- capability.--- It starts with 'initGState' and some reasonable dummy values for--- gas limit and current timestamp. You can update blockchain state--- by performing some operations.-integrationalTestExpectation :: IntegrationalScenario -> Expectation-integrationalTestExpectation =-  integrationalTest (maybe pass (expectationFailure . toString))---- | Integrational test similar to 'integrationalTestExpectation'.--- It can fail using 'Property' capability.--- It can be used with QuickCheck's @forAll@ to make a--- property-based test with arbitrary data.-integrationalTestProperty :: IntegrationalScenario -> Property-integrationalTestProperty = integrationalTest (maybe succeededProp failedProp)---- | Originate a contract with given initial storage and balance. Its--- address is returned.-originate ::-  UntypedContract -> UntypedValue -> Mutez -> IntegrationalScenarioM Address-originate contract value balance =-  mkContractAddress origination <$ putOperation originateOp-  where-    origination = (dummyOrigination value contract) {ooBalance = balance}-    originateOp = OriginateOp origination---- | Transfer tokens to given address.-transfer :: TxData -> Address -> IntegrationalScenarioM ()-transfer txData destination =-  putOperation (TransferOp destination txData)---- | Execute all operations that were added to the scenarion since--- last 'validate' call. If validator fails, the execution will be aborted.-validate :: IntegrationalValidator -> IntegrationalScenario-validate validator = Validated <$ do-  now <- use isNow-  maxSteps <- use isMaxSteps-  gState <- use isGState-  ops <- use isOperations-  mUpdatedGState <--    lift $ validateResult validator $ interpreterPure now maxSteps gState ops-  isOperations .= mempty-  whenJust mUpdatedGState $ \newGState -> isGState .= newGState---- | Make all further interpreter calls (which are triggered by the--- 'validate' function) use given timestamp as the current one.-setNow :: Timestamp -> IntegrationalScenarioM ()-setNow = assign isNow---- | Make all further interpreter calls (which are triggered by the--- 'validate' function) use given gas limit.-setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()-setMaxSteps = assign isMaxSteps--putOperation :: InterpreterOp -> IntegrationalScenarioM ()-putOperation op = isOperations <>= one op--------------------------------------------------------------------------------- Validators to be used within 'IntegrationalValidator'--------------------------------------------------------------------------------- | 'SuccessValidator' that always passes.-expectAnySuccess :: SuccessValidator-expectAnySuccess _ _ = pass---- | Check that storage value is updated for given address. Takes a--- predicate that is used to check the value.------ It works even if updates are not filtered (i. e. a value can be--- updated more than once).-expectStorageUpdate ::-     Address-  -> (UntypedValue -> Either Text ())-  -> SuccessValidator-expectStorageUpdate addr predicate _ updates =-  case List.find checkAddr (reverse updates) of-    Nothing -> Left $ "Storage of " +| addr |+ " is not updated"-    Just (GSSetStorageValue _ val) ->-      first (("Storage of " +| addr |+ "is updated incorrectly: ") <>) $-      predicate val-    -- 'checkAddr' ensures that only 'GSSetStorageValue' can be found-    Just _ -> error "expectStorageUpdate: internal error"-  where-    checkAddr (GSSetStorageValue addr' _) = addr' == addr-    checkAddr _ = False---- | Like 'expectStorageUpdate', but expects a constant.-expectStorageUpdateConst ::-     Address-  -> UntypedValue-  -> SuccessValidator-expectStorageUpdateConst addr expected =-  expectStorageUpdate addr predicate-  where-    predicate val-      | val == expected = pass-      | otherwise = Left $ "expected " +| expected |+ ""---- | Check that eventually address has some particular storage value.-expectStorageConst :: Address -> UntypedValue -> SuccessValidator-expectStorageConst addr expected gs _ =-  case gsAddresses gs ^. at addr of-    Just (ASContract cs)-      | csStorage cs == expected -> pass-      | otherwise ->-        Left $ intro +|  "its storage is " +| csStorage cs |+ ""-    Just (ASSimple {}) ->-      Left $ intro +| "it's a simple address"-    Nothing -> Left $ intro +| "it's unknown"-  where-    intro = "Expected " +| addr |+ " to have storage " +| expected |+ ", but "---- | Check that eventually address has some particular balance.-expectBalance :: Address -> Mutez -> SuccessValidator-expectBalance addr balance gs _ =-  case gsAddresses gs ^. at addr of-    Nothing ->-      Left $-      "Expected " +| addr |+ " to have balance " +| balance |+-      ", but it's unknown"-    Just (asBalance -> realBalance)-      | realBalance == balance -> pass-      | otherwise ->-        Left $-        "Expected " +| addr |+ " to have balance " +| balance |+-        ", but its balance is " +| realBalance |+ ""---- | Compose two success validators.------ For example:------ expectBalance bal addr `composeValidators`--- expectStorageUpdateConst addr2 ValueUnit-composeValidators ::-     SuccessValidator-  -> SuccessValidator-  -> SuccessValidator-composeValidators val1 val2 gState updates =-  val1 gState updates >> val2 gState updates---- | Compose a list of success validators.-composeValidatorsList :: [SuccessValidator] -> SuccessValidator-composeValidatorsList = foldl' composeValidators expectAnySuccess---- | Check that interpreter failed due to gas exhaustion.-expectGasExhaustion :: InterpreterError -> Bool-expectGasExhaustion =-  \case-    IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True-    _ -> False---- | Expect that interpretation of contract with given address ended--- with [FAILED].-expectMichelsonFailed :: Address -> InterpreterError -> Bool-expectMichelsonFailed addr =-  \case-    IEInterpreterFailed failedAddr (RuntimeFailure {}) -> addr == failedAddr-    _ -> False--------------------------------------------------------------------------------- Implementation of the testing engine-------------------------------------------------------------------------------initIS :: InternalState-initIS = InternalState-  { _isNow = dummyNow-  , _isMaxSteps = dummyMaxSteps-  , _isGState = initGState-  , _isOperations = mempty-  }--integrationalTest ::-     (Maybe Text -> res)-  -> IntegrationalScenario-  -> res-integrationalTest howToFail scenario =-  howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)--validateResult ::-     IntegrationalValidator-  -> Either InterpreterError InterpreterRes-  -> Except Text (Maybe GState)-validateResult validator result =-  case (validator, result) of-    (Left validateError, Left err)-      | validateError err -> pure Nothing-    (_, Left err) ->-      doFail $ "Unexpected interpreter error: " <> pretty err-    (Left _, Right _) ->-      doFail $ "Interpreter unexpectedly didn't fail"-    (Right validateUpdates, Right ir)-      | Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) ->-        doFail $-        "Updates are incorrect: " +| bad |+ ". Updates are: \n" +|-        blockListF (_irUpdates ir) |+ ""-      | otherwise -> pure $ Just $ _irGState ir-  where-    doFail = throwError
− src/Morley/Test/Unit.hs 
@@ -1,53 +0,0 @@--- | Utility functions for unit testing.--module Morley.Test.Unit-  ( ContractReturn-  , ContractPropValidator-  , contractProp-  , contractPropVal-  ) where--import Michelson.Interpret (ContractEnv, ContractReturn)-import Michelson.Typed (Contract, Instr, ToT, ToVal(..), Val(..))-import Morley.Ext (interpretMorley)-import Morley.Types (MorleyLogs)---- | Type for contract execution validation.------ It's a function which is supplied with contract execution output--- (failure or new storage with operation list).------ Function returns a property which type is designated by type variable @prop@--- and might be 'Test.QuickCheck.Property' or 'Test.Hspec.Expectation'--- or anything else relevant.-type ContractPropValidator st prop = ContractReturn MorleyLogs st -> prop---- | Contract's property tester against given input.--- Takes contract environment, initial storage and parameter,--- interprets contract on this input and invokes validation function.-contractProp-  :: ( ToVal param, ToVal storage-     , ToT param ~ cp, ToT storage ~ st-     , Typeable cp, Typeable st-     )-  => Contract cp st-  -> ContractPropValidator st prop-  -> ContractEnv-  -> param-  -> storage-  -> prop-contractProp instr check env param initSt =-  contractPropVal instr check env (toVal param) (toVal initSt)---- | Version of 'contractProp' which takes 'Val' as arguments instead--- of regular Haskell values.-contractPropVal-  :: (Typeable cp, Typeable st)-  => Contract cp st-  -> ContractPropValidator st prop-  -> ContractEnv-  -> Val Instr cp-  -> Val Instr st-  -> prop-contractPropVal instr check env param initSt =-  check $ interpretMorley instr param initSt env
− src/Morley/Test/Util.hs 
@@ -1,33 +0,0 @@--- | Testing utility functions used by testing framework itself or--- intended to be used by test writers.--module Morley.Test.Util-  ( failedProp-  , succeededProp-  , qcIsLeft-  , qcIsRight-  ) where--import Test.QuickCheck.Property (Property, Result(..), failed, property)--------------------------------------------------------------------------------- Property--------------------------------------------------------------------------------- | A 'Property' that always failes with given message.-failedProp :: Text -> Property-failedProp r = property $ failed { reason = toString r }---- | A 'Property' that always succeeds.-succeededProp :: Property-succeededProp = property True---- | The 'Property' holds on `Left a`.-qcIsLeft :: Show b => Either a b -> Property-qcIsLeft (Left _)  = property True-qcIsLeft (Right x) = failedProp $ "expected Left, got Right (" <> show x <> ")"---- | The 'Property' holds on `Right b`.-qcIsRight :: Show a => Either a b -> Property-qcIsRight (Right _) = property True-qcIsRight (Left x)  = failedProp $ "expected Right, got Left (" <> show x <> ")"
− src/Morley/Types.hs 
@@ -1,432 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--- pva701: ^ this is needed for Buildable Instr.--- I couldn't define it in Utyped.Instr--- because GHC doesn't know what particular type would be ExtU--- and generates an error about overlapping instances,--- when I try to use genericF.--- Also it's not possible to implement it using deriving instances--- because InstrAbstract isn't newtype.-{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}--module Morley.Types-  (-   -- * Rexported from Michelson.Types-    Parameter-  , Storage-  , Contract (..)-  , Value (..)-  , Elt (..)-  , InstrAbstract (..)-  , Instr-  , Op (..)-  , TypeAnn-  , FieldAnn-  , VarAnn-  , ann-  , noAnn-  , Type (..)-  , Comparable (..)-  , T (..)-  , CT (..)-  , Annotation (..)-  , InternalByteString(..)-  , unInternalByteString--  -- Parser types-  , CustomParserException (..)-  , Parser-  , Parsec-  , ParseErrorBundle-  , ParserException (..)-  , LetEnv (..)-  , noLetEnv--  , UExtInstrAbstract(..)--  -- * Morley Parsed instruction types-  , ParsedInstr-  , ParsedOp (..)-  , ParsedUTestAssert-  , ParsedUExtInstr--  -- * Morley Expanded instruction types-  , ExpandedInstr-  , ExpandedOp (..)-  , ExpandedUExtInstr--  -- * Michelson Instructions and Instruction Macros-  , PairStruct (..)-  , CadrStruct (..)-  , Macro (..)--  -- * Morley Instructions-  , ExtInstr(..)-  , TestAssert (..)-  , UTestAssert (..)-  , PrintComment (..)-  , StackTypePattern (..)-  , StackRef(..)--  , MorleyLogs (..)-  , noMorleyLogs-  --  * Let-block-  , StackFn(..)-  , Var (..)-  , TyVar (..)-  , varSet-  , LetMacro (..)-  , LetValue (..)-  , LetType (..)-  ) where---import Data.Aeson.TH (defaultOptions, deriveJSON)-import Data.Data (Data(..))-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Text as T-import Fmt (Buildable(build), Builder, genericF, listF, (+|), (|+))-import Text.Megaparsec (ParseErrorBundle, Parsec, ShowErrorComponent(..), errorBundlePretty)-import qualified Text.PrettyPrint.Leijen.Text as PP (empty)-import qualified Text.Show (show)--import Michelson.EqParam (eqParam2)-import Michelson.Printer (RenderDoc(..))-import Michelson.Typed (instrToOps)-import qualified Michelson.Typed as T-import Michelson.Untyped-  (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), ExpandedInstr, ExpandedOp(..),-  ExtU, FieldAnn, Instr, InstrAbstract(..), InternalByteString(..), Op(..), Parameter, Storage,-  T(..), Type(..), TypeAnn, Value(..), VarAnn, ann, noAnn, unInternalByteString)-import Morley.Default (Default(..))------------------------------------------ Types for the parser----------------------------------------data CustomParserException-  = UnknownTypeException-  | OddNumberBytesException-  | UnexpectedLineBreak-  deriving (Eq, Data, Ord, Show)--instance ShowErrorComponent CustomParserException where-  showErrorComponent UnknownTypeException = "unknown type"-  showErrorComponent OddNumberBytesException = "odd number bytes"-  showErrorComponent UnexpectedLineBreak = "unexpected linebreak"--type Parser = ReaderT LetEnv (Parsec CustomParserException T.Text)--instance Default a => Default (Parser a) where-  def = pure def--data ParserException =-  ParserException (ParseErrorBundle T.Text CustomParserException)--instance Show ParserException where-  show (ParserException bundle) = errorBundlePretty bundle--instance Exception ParserException where-  displayException (ParserException bundle) = errorBundlePretty bundle--instance Buildable ParserException where-  build = build @String . show---- | The environment containing lets from the let-block-data LetEnv = LetEnv-  { letMacros :: Map Text LetMacro-  , letValues :: Map Text LetValue-  , letTypes  :: Map Text LetType-  } deriving (Show, Eq)--noLetEnv :: LetEnv-noLetEnv = LetEnv Map.empty Map.empty Map.empty------------------------------------------ Types produced by parser------------------------------------------ TODO Move this to Morley.Untyped--- | Implementation-specific instructions embedded in a @NOP@ primitive, which--- mark a specific point during a contract's typechecking or execution.------ These instructions are not allowed to modify the contract's stack, but may--- impose additional constraints that can cause a contract to report errors in--- type-checking or testing.------ Additionaly, some implementation-specific language features such as--- type-checking of @LetMacro@s are implemented using this mechanism--- (specifically @FN@ and @FN_END@).-data UExtInstrAbstract op =-    STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern-  | FN T.Text StackFn          -- ^ Begin a typed stack function (push a @TcExtFrame@)-  | FN_END                     -- ^ End a stack function (pop a @TcExtFrame@)-  | UTEST_ASSERT (UTestAssert op)   -- ^ Copy the current stack and run an inline assertion on it-  | UPRINT PrintComment         -- ^ Print a comment with optional embedded @StackRef@s-  deriving (Eq, Show, Data, Generic, Functor)--instance Buildable op => Buildable (UExtInstrAbstract op) where-  build = genericF---- TODO replace ParsedOp in ExpandedUExtInstr with op--- to reflect Parsed, Expanded and Flattened phase--type instance ExtU InstrAbstract = UExtInstrAbstract-type instance T.ExtT T.Instr = ExtInstr-------------------------------------------------------type ParsedUTestAssert = UTestAssert ParsedOp--type ParsedUExtInstr = UExtInstrAbstract ParsedOp--type ParsedInstr = InstrAbstract ParsedOp---- | Unexpanded instructions produced directly by the @ops@ parser, which--- contains primitive Michelson Instructions, inline-able macros and sequences-data ParsedOp-  = Prim ParsedInstr -- ^ Primitive Michelson instruction-  | Mac Macro        -- ^ Built-in Michelson macro defined by the specification-  | LMac LetMacro    -- ^ User-defined macro with instructions to be inlined-  | Seq [ParsedOp]   -- ^ A sequence of instructions-  deriving (Eq, Show, Data, Generic)---- dummy value-instance RenderDoc ParsedOp where-  renderDoc _ = PP.empty--instance Buildable ParsedOp where-  build (Prim parseInstr) = "<Prim: "+|parseInstr|+">"-  build (Mac macro)       = "<Mac: "+|macro|+">"-  build (LMac letMacro)   = "<LMac: "+|letMacro|+">"-  build (Seq parsedOps)   = "<Seq: "+|parsedOps|+">"--type ExpandedUExtInstr = UExtInstrAbstract ExpandedOp-------------------------------------------------------data TestAssert where-  TestAssert-    :: (Typeable inp, Typeable out)-    => T.Text-    -> PrintComment-    -> T.Instr inp ('T.Tc 'CBool ': out)-    -> TestAssert--deriving instance Show TestAssert--instance Eq TestAssert where-  TestAssert   name1 pattern1 instr1-    ==-    TestAssert name2 pattern2 instr2-    = and-    [ name1 == name2-    , pattern1 == pattern2-    , instr1 `eqParam2` instr2-    ]--data ExtInstr-  = TEST_ASSERT TestAssert-  | PRINT PrintComment-  deriving (Show, Eq)--instance T.Conversible ExtInstr (UExtInstrAbstract ExpandedOp) where-  convert (PRINT pc) = UPRINT pc-  convert (TEST_ASSERT (TestAssert nm pc i)) =-    UTEST_ASSERT $ UTestAssert nm pc (instrToOps i)--------------------------------------------------------- | Morley interpreter state-newtype MorleyLogs = MorleyLogs-  { unMorleyLogs :: [T.Text]-  } deriving stock (Eq, Show)-    deriving newtype (Default, Buildable)--noMorleyLogs :: MorleyLogs-noMorleyLogs = MorleyLogs []-------------------------------------------------------data PairStruct-  = F (VarAnn, FieldAnn)-  | P PairStruct PairStruct-  deriving (Eq, Show, Data, Generic)--instance Buildable PairStruct where-  build = genericF--data CadrStruct-  = A-  | D-  deriving (Eq, Show, Data, Generic)--instance Buildable CadrStruct where-  build = genericF---- | Built-in Michelson Macros defined by the specification-data Macro-  = CMP ParsedInstr VarAnn-  | IFX ParsedInstr [ParsedOp] [ParsedOp]-  | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]-  | FAIL-  | PAPAIR PairStruct TypeAnn VarAnn-  | UNPAIR PairStruct-  | CADR [CadrStruct] VarAnn FieldAnn-  | SET_CADR [CadrStruct] VarAnn FieldAnn-  | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]-  | DIIP Integer [ParsedOp]-  | DUUP Integer VarAnn-  | ASSERT-  | ASSERTX ParsedInstr-  | ASSERT_CMP ParsedInstr-  | ASSERT_NONE-  | ASSERT_SOME-  | ASSERT_LEFT-  | ASSERT_RIGHT-  | IF_SOME [ParsedOp] [ParsedOp]-  deriving (Eq, Show, Data, Generic)--instance Buildable Macro where-  build (CMP parsedInstr carAnn) = "<CMP: "+|parsedInstr|+", "+|carAnn|+">"-  build (IFX parsedInstr parsedOps1 parsedOps2) = "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"-  build (IFCMP parsedInstr varAnn parsedOps1 parsedOps2) = "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"-  build FAIL = "FAIL"-  build (PAPAIR pairStruct typeAnn varAnn) = "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"-  build (UNPAIR pairStruct) = "<UNPAIR: "+|pairStruct|+">"-  build (CADR cadrStructs varAnn fieldAnn) = "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-  build (SET_CADR cadrStructs varAnn fieldAnn) = "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-  build (MAP_CADR cadrStructs varAnn fieldAnn parsedOps) = "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"-  build (DIIP integer parsedOps) = "<DIIP: "+|integer|+", "+|parsedOps|+">"-  build (DUUP integer varAnn) = "<DUUP: "+|integer|+", "+|varAnn|+">"-  build ASSERT = "ASSERT"-  build (ASSERTX parsedInstr) = "<ASSERTX: "+|parsedInstr|+">"-  build (ASSERT_CMP parsedInstr) = "<ASSERT_CMP: "+|parsedInstr|+">"-  build ASSERT_NONE  = "ASSERT_NONE"-  build ASSERT_SOME  = "ASSERT_SOME"-  build ASSERT_LEFT  = "ASSERT_LEFT"-  build ASSERT_RIGHT = "ASSERT_RIGHT"-  build (IF_SOME parsedOps1 parsedOps2) = "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"--------------------------------------------------------- | A reference into the stack-newtype StackRef = StackRef Integer-  deriving (Eq, Show, Data, Generic)--instance Buildable StackRef where-  build (StackRef i) = "%[" <> build i <> "]"--newtype Var = Var T.Text deriving (Eq, Show, Ord, Data, Generic)--instance Buildable Var where-  build = genericF---- | A type-variable or a type-constant-data TyVar =-    VarID Var-  | TyCon Type-  deriving (Eq, Show, Data, Generic)--instance Buildable TyVar where-  build = genericF---- | A stack pattern-match-data StackTypePattern- = StkEmpty- | StkRest- | StkCons TyVar StackTypePattern-  deriving (Eq, Show, Data, Generic)---- | Convert 'StackTypePattern' to a list of types. Also returns--- 'Bool' which is 'True' if the pattern is a fixed list of types and--- 'False' if it's a pattern match on the head of the stack.-stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)-stackTypePatternToList StkEmpty = ([], True)-stackTypePatternToList StkRest = ([], False)-stackTypePatternToList (StkCons t pat) =-  first (t :) $ stackTypePatternToList pat--instance Buildable StackTypePattern where-  build = listF . pairToList . stackTypePatternToList-    where-      pairToList :: ([TyVar], Bool) -> [Builder]-      pairToList (types, fixed)-        | fixed = map build types-        | otherwise = map build types ++ ["..."]---- | A stack function that expresses the type signature of a @LetMacro@-data StackFn = StackFn-  { quantifiedVars :: Maybe (Set Var)-  , inPattern :: StackTypePattern-  , outPattern :: StackTypePattern-  } deriving (Eq, Show, Data, Generic)--instance Buildable StackFn where-  build = genericF---- | Get the set of variables in a stack pattern-varSet :: StackTypePattern -> Set Var-varSet StkEmpty = Set.empty-varSet StkRest = Set.empty-varSet (StkCons (VarID v) stk) = v `Set.insert` (varSet stk)-varSet (StkCons _ stk) = varSet stk---- | A programmer-defined macro-data LetMacro = LetMacro-  { lmName :: T.Text-  , lmSig :: StackFn-  , lmExpr :: [ParsedOp]-  } deriving (Eq, Show, Data, Generic)--instance Buildable LetMacro where-  build = genericF---- | A programmer-defined constant-data LetValue = LetValue-  { lvName :: T.Text-  , lvSig :: Type-  , lvVal :: (Value ParsedOp)-  } deriving (Eq, Show)---- | A programmer-defined type-synonym-data LetType = LetType-  { ltName :: T.Text-  , ltSig :: Type-  } deriving (Eq, Show)---- A print format with references into the stack-newtype PrintComment = PrintComment-  { unPrintComment :: [Either T.Text StackRef]-  } deriving (Eq, Show, Data, Generic)--instance Buildable PrintComment where-  build = foldMap (either build build) . unPrintComment---- An inline test assertion-data UTestAssert op = UTestAssert-  { tassName :: T.Text-  , tassComment :: PrintComment-  , tassInstrs :: [op]-  } deriving (Eq, Show, Functor, Data, Generic)--instance Buildable code => Buildable (UTestAssert code) where-  build = genericF--deriveJSON defaultOptions ''ParsedOp-deriveJSON defaultOptions ''UExtInstrAbstract-deriveJSON defaultOptions ''PrintComment-deriveJSON defaultOptions ''StackTypePattern-deriveJSON defaultOptions ''StackRef-deriveJSON defaultOptions ''StackFn-deriveJSON defaultOptions ''Var-deriveJSON defaultOptions ''TyVar-deriveJSON defaultOptions ''LetMacro-deriveJSON defaultOptions ''LetValue-deriveJSON defaultOptions ''LetType-deriveJSON defaultOptions ''UTestAssert-deriveJSON defaultOptions ''PairStruct-deriveJSON defaultOptions ''CadrStruct-deriveJSON defaultOptions ''Macro
src/Tezos/Address.hs view
@@ -7,6 +7,7 @@    -- * Formatting   , formatAddress+  , mformatAddress   , parseAddress   , unsafeParseAddress   ) where@@ -20,6 +21,7 @@ import qualified Formatting.Buildable as Buildable import Test.QuickCheck (Arbitrary(..), oneof, vector) +import Michelson.Text import Tezos.Crypto  -- | Data type corresponding to address structure in Tezos.@@ -60,6 +62,9 @@   \case     KeyAddress h -> formatKeyHash h     ContractAddress bs -> encodeBase58Check (contractAddressPrefix <> bs)++mformatAddress :: Address -> MText+mformatAddress = mkMTextUnsafe . formatAddress  instance Buildable.Buildable Address where   build = Buildable.build . formatAddress
src/Tezos/Core.hs view
@@ -8,6 +8,7 @@     Mutez (unMutez)   , mkMutez   , unsafeMkMutez+  , toMutez   , addMutez   , unsafeAddMutez   , subMutez@@ -65,6 +66,19 @@   fromMaybe (error $ "mkMutez: overflow (" <> show n <> ")") (mkMutez n) {-# INLINE unsafeMkMutez #-} +-- | Safely create 'Mutez'.+--+-- This is recommended way to create @Mutez@ from a numeric literal;+-- you can't construct all valid @Mutez@ values using this function+-- but for small values it works neat.+--+-- Warnings displayed when trying to construct invalid 'Natural' or 'Word'+-- literal are hardcoded for these types in GHC implementation, so we can only+-- exploit these existing rules.+toMutez :: Word32 -> Mutez+toMutez = unsafeMkMutez . fromIntegral+{-# INLINE toMutez #-}+ -- | Addition of 'Mutez' values. Returns 'Nothing' in case of overflow. addMutez :: Mutez -> Mutez -> Maybe Mutez addMutez (unMutez -> a) (unMutez -> b) =@@ -107,10 +121,10 @@ divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez) divModMutezInt (toInteger . unMutez -> a) (toInteger -> b)   | b <= 0 = Nothing-  | otherwise = Just $ bimap toMutez toMutez (a `divMod` b)+  | otherwise = Just $ bimap toMutez' toMutez' (a `divMod` b)   where-    toMutez :: Integer -> Mutez-    toMutez = Mutez . fromInteger+    toMutez' :: Integer -> Mutez+    toMutez' = Mutez . fromInteger  ---------------------------------------------------------------------------- -- Timestamp
src/Tezos/Crypto.hs view
@@ -2,21 +2,27 @@  module Tezos.Crypto   ( -- * Cryptographic primitive types-    PublicKey+    PublicKey (..)   , SecretKey-  , Signature+  , Signature (..)   , KeyHash (..)+  , detSecretKey   , toPublic    -- * Formatting   , CryptoParseError (..)   , formatPublicKey+  , mformatPublicKey   , parsePublicKey+  , mkPublicKey   , formatSecretKey   , parseSecretKey   , formatSignature+  , mformatSignature   , parseSignature+  , mkSignature   , formatKeyHash+  , mformatKeyHash   , parseKeyHash    -- * Signing@@ -37,7 +43,7 @@   , decodeBase58CheckWithPrefix   ) where -import Crypto.Error (CryptoError, CryptoFailable, eitherCryptoError)+import Crypto.Error (CryptoError, CryptoFailable(..), eitherCryptoError) import Crypto.Hash (Blake2b_160, Blake2b_256, Digest, SHA256, SHA512, hash) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.Ed25519 as Ed25519@@ -45,6 +51,7 @@ import Data.Aeson (FromJSON(..), ToJSON(..)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encoding as Aeson+import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.ByteString.Base58 as Base58@@ -53,6 +60,8 @@ import qualified Formatting.Buildable as Buildable import Test.QuickCheck (Arbitrary(..), vector) +import Michelson.Text+ ---------------------------------------------------------------------------- -- Types, instances, conversions ----------------------------------------------------------------------------@@ -70,12 +79,15 @@   { unSecretKey :: Ed25519.SecretKey   } deriving (Show, Eq) +-- | Deterministicaly generate a secret key from seed.+detSecretKey :: ByteString -> SecretKey+detSecretKey seed =+  let chachaSeed = drgNewSeed . seedFromInteger . os2ip $ seed+      (sk, _) = withDRG chachaSeed Ed25519.generateSecretKey+  in SecretKey sk+ instance Arbitrary SecretKey where-  arbitrary = do-    seed <- BS.pack <$> vector 32-    let chachaSeed = drgNewSeed . seedFromInteger . os2ip $ seed-        (sk, _) = withDRG chachaSeed Ed25519.generateSecretKey-    return (SecretKey sk)+  arbitrary = detSecretKey . BS.pack <$> vector 32  -- | Create a public key from a secret key. toPublic :: SecretKey -> PublicKey@@ -143,12 +155,21 @@ formatPublicKey :: PublicKey -> Text formatPublicKey = formatImpl publicKeyTag . unPublicKey +mformatPublicKey :: PublicKey -> MText+mformatPublicKey = mkMTextUnsafe . formatPublicKey+ instance Buildable.Buildable PublicKey where   build = Buildable.build . formatPublicKey  parsePublicKey :: Text -> Either CryptoParseError PublicKey parsePublicKey = parseImpl publicKeyTag Ed25519.publicKey +mkPublicKey :: ByteArrayAccess ba => ba -> Either Text PublicKey+mkPublicKey ba =+  case Ed25519.publicKey ba of+    CryptoPassed k -> Right (PublicKey k)+    CryptoFailed e -> Left (show e)+ formatSecretKey :: SecretKey -> Text formatSecretKey = formatImpl secretKeyTag . unSecretKey @@ -161,14 +182,26 @@ formatSignature :: Signature -> Text formatSignature = formatImpl signatureTag . unSignature +mformatSignature :: Signature -> MText+mformatSignature = mkMTextUnsafe . formatSignature+ instance Buildable.Buildable Signature where   build = Buildable.build . formatSignature  parseSignature :: Text -> Either CryptoParseError Signature parseSignature = parseImpl signatureTag Ed25519.signature +mkSignature :: ByteArrayAccess ba => ba -> Either Text Signature+mkSignature ba =+  case Ed25519.signature ba of+    CryptoPassed s -> Right (Signature s)+    CryptoFailed e -> Left (show e)+ formatKeyHash :: KeyHash -> Text formatKeyHash = formatImpl keyHashTag . unKeyHash++mformatKeyHash :: KeyHash -> MText+mformatKeyHash = mkMTextUnsafe . formatKeyHash  instance Buildable.Buildable KeyHash where   build = Buildable.build . formatKeyHash
+ src/Util/Alternative.hs view
@@ -0,0 +1,13 @@+-- | Utilities related to 'Alternative'.++module Util.Alternative+  ( someNE+  ) where++import qualified Data.List.NonEmpty as NE++-- | This function is the same as 'some' except that it returns+-- 'NonEmpty', because 'some' is guaranteed to return non-empty list,+-- but it's not captured in types.+someNE :: Alternative f => f a -> f (NonEmpty a)+someNE = fmap NE.fromList . some
+ src/Util/Default.hs view
@@ -0,0 +1,21 @@+module Util.Default+  ( permute2Def , permute3Def+  , Default (..)+  ) where++import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)+import Data.Default (Default, def)++{- Permutation Parsers -}++permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a,b)+permute2Def a b = runPermutation $+  (,) <$> toPermutationWithDefault def a+      <*> toPermutationWithDefault def b++permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) =>+                f a -> f b -> f c -> f (a,b,c)+permute3Def a b c = runPermutation $+  (,,) <$> toPermutationWithDefault def a+       <*> toPermutationWithDefault def b+       <*> toPermutationWithDefault def c
+ src/Util/Generic.hs view
@@ -0,0 +1,30 @@+-- | Generic-related utils.+module Util.Generic+  ( mkGenericTree+  , mkGenericTreeVec+  ) where++import Control.Exception (assert)+import qualified Data.Vector as V++-- | Rebuild a list into a binary tree of exactly the same form which+-- 'Data.Generic' uses to represent datatypes.+--+-- Along with the original list you have to provide constructor for intermediate+-- nodes - it accepts zero-based index of the leftmost element of the right tree+-- and merged trees themselves.+mkGenericTree :: (Int -> a -> a -> a) -> NonEmpty a -> a+mkGenericTree mkNode = mkGenericTreeVec id mkNode . V.fromList . toList++mkGenericTreeVec :: HasCallStack => (a -> b) -> (Int -> b -> b -> b) -> V.Vector a -> b+mkGenericTreeVec mkLeaf mkNode vector+  | V.null vector = error "Empty vector"+  | otherwise = mkTreeDo 0 vector+  where+    mkTreeDo idxBase es+      | V.length es == 1 = mkLeaf $ V.head es+      | otherwise = assert (V.length es > 1) $+          let mid = V.length es `div` 2+              mid' = idxBase + mid+              (h, t) = V.splitAt mid es+          in mkNode mid' (mkTreeDo idxBase h) (mkTreeDo mid' t)
+ src/Util/IO.hs view
@@ -0,0 +1,42 @@+module Util.IO+  ( readFileUtf8+  , writeFileUtf8+  , withEncoding+  , hSetTranslit+  ) where++import Data.Text.IO (hGetContents)+import GHC.IO.Encoding (textEncodingName)+import System.IO (TextEncoding, hGetEncoding, hSetBinaryMode, hSetEncoding, mkTextEncoding, utf8)++readFileUtf8 :: FilePath -> IO Text+readFileUtf8 name =+  openFile name ReadMode >>= \h -> hSetEncoding h utf8 >> hGetContents h++writeFileUtf8 :: Print text => FilePath -> text -> IO ()+writeFileUtf8 name txt =+  withFile name WriteMode $ \h -> hSetEncoding h utf8 >> hPutStr h txt++withEncoding :: Handle -> TextEncoding -> IO () -> IO ()+withEncoding handle encoding action = do+  mbInitialEncoding <- hGetEncoding handle+  bracket+    (hSetEncoding handle encoding)+    (\_ -> maybe (hSetBinaryMode handle True) (hSetEncoding handle) mbInitialEncoding)+    (\_ -> action)++-- This function was copied (with slight modifications) from+-- <https://gitlab.haskell.org/ghc/ghc/blob/7105fb66a7bacf822f7f23028136f89ff5737d0e/libraries/ghc-boot/GHC/HandleEncoding.hs>+--+-- © 2002 The University Court of the University of Glasgow+-- (original license: LicenseRef-BSD-3-Clause-TheUniversityCourtOfTheUniversityOfGlasgow)+-- | Change the character encoding of the given Handle to transliterate+-- on unsupported characters instead of throwing an exception.+hSetTranslit :: Handle -> IO ()+hSetTranslit h = do+    menc <- hGetEncoding h+    case fmap textEncodingName menc of+        Just name | '/' `notElem` name -> do+            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"+            hSetEncoding h enc'+        _ -> pass
+ src/Util/Instances.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Missing instances from libraries.+module Util.Instances () where++import Data.Default (Default(..))+import Fmt (Buildable(..))++instance Default Natural where+  def = 0++instance Buildable Natural where+  build = build @Integer . fromIntegral
+ src/Util/Lens.hs view
@@ -0,0 +1,9 @@+module Util.Lens+  ( postfixLFields+  ) where++import Control.Lens (LensRules, lensField, lensRules, mappingNamer)++-- | For datatype with "myNyan" field it will create "myNyanL" lens.+postfixLFields :: LensRules+postfixLFields = lensRules & lensField .~ mappingNamer (\s -> [s++"L"])
+ src/Util/Named.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Additional functionality for 'named' package.+module Util.Named+  ( (.!)+  , (.?)+  , (<.!>)+  , (<.?>)+  , NamedInner+  ) where++import Control.Lens (Wrapped(..), iso)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Named (Name, NamedF(..))+import qualified Text.Show++(.!) :: Name name -> a -> NamedF Identity a name+(.!) _ = ArgF . Identity++(.?) :: Name name -> Maybe a -> NamedF Maybe a name+(.?) _ = ArgF++(<.!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)+(<.!>) name = fmap (name .!)++(<.?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)+(<.?>) name = fmap (name .?)++type family NamedInner n where+  NamedInner (NamedF Identity a _) = a+  NamedInner (NamedF Maybe a _) = Maybe a++instance Wrapped (NamedF Identity a name) where+  type Unwrapped (NamedF Identity a name) = a+  _Wrapped' = iso (\(ArgF a) -> runIdentity a) (ArgF . Identity)++instance Wrapped (NamedF Maybe a name) where+  type Unwrapped (NamedF Maybe a name) = Maybe a+  _Wrapped' = iso (\(ArgF a) -> a) ArgF++deriving instance Eq a => Eq (NamedF Identity a name)++instance (Show a, KnownSymbol name) => Show (NamedF Identity a name) where+  show (ArgF a) = symbolVal (Proxy @name) <> " :! " <> show a
+ src/Util/Peano.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Type-nat utilities.+--+-- We take Peano numbers as base for operations because they make it+-- much easer to prove things to compiler. Their performance does not+-- seem to introduce a problem, because we use nats primarily along with+-- stack which is a linked list with similar performance characteristics.+--+-- Many of things we introduce here are covered in @type-natural@ package,+-- but unfortunatelly it does not work with GHC 8.6 at the moment of writing+-- this module. We use 'Data.Vinyl' as source of Peano @Nat@ for now.+module Util.Peano+  ( -- * General+    Peano+  , ToPeano+  , Length+  , KnownPeano (..)+  , peanoVal'+  , Sing (SZ, SS)+  , At++    -- * Morley-specific utils+  , IsLongerThan+  , LongerThan+  , RequireLongerThan+  , requiredLongerThan+  ) where++import Prelude hiding (Nat)++import Data.Singletons (Sing, SingI(..))+import qualified GHC.TypeNats as GHC (Nat)+import Unsafe.Coerce (unsafeCoerce)+import Data.Constraint (Dict (..))+import GHC.TypeLits (TypeError, ErrorMessage (..))+import Data.Type.Bool (If)+import Data.Vinyl.TypeLevel (Nat(..), RLength)+import GHC.TypeNats (type (-), type (+))++----------------------------------------------------------------------------+-- General+----------------------------------------------------------------------------++-- | A convenient alias.+--+-- We are going to use 'Peano' numbers for type-dependent logic and+-- normal 'Nat's in user API, need to distinguish them somehow.+type Peano = Nat++type family ToPeano (n :: GHC.Nat) :: Nat where+  ToPeano 0 = 'Z+  ToPeano a = 'S (ToPeano (a - 1))++type family FromPeano (n :: Nat) :: GHC.Nat where+  FromPeano 'Z = 0+  FromPeano ('S a) = 1 + FromPeano a++type family Length l where+  Length l = RLength l++class KnownPeano (n :: Nat) where+  peanoVal :: proxy n -> Natural++instance KnownPeano 'Z where+  peanoVal _ = 0+instance KnownPeano a => KnownPeano ('S a) where+  peanoVal _ = peanoVal' @a + 1++peanoVal' :: forall n. KnownPeano n => Natural+peanoVal' = peanoVal (Proxy @n)++data instance Sing (_ :: Nat) where+  SZ :: Sing 'Z+  SS :: Sing n -> Sing ('S n)++deriving instance Eq (Sing (n :: Nat))++instance SingI 'Z where+  sing = SZ+instance SingI n => SingI ('S n) where+  sing = SS (sing @n)++type family At (n :: Peano) s where+  At 'Z (x ': _) = x+  At ('S n) (_ ': xs) = At n xs+  At a '[] =+    TypeError+      ('Text "You try to access to non-existing element of the stack, n = " ':<>:+         'ShowType (FromPeano a))++----------------------------------------------------------------------------+-- Morley-specific utils+----------------------------------------------------------------------------++-- | Comparison of type-level naturals, as a function.+--+-- It is as lazy on the list argument as possible - there is no+-- need to know the whole list if the natural argument is small enough.+-- This property is important if we want to be able to extract reusable+-- parts of code which are aware only of relevant part of stack.+type family IsLongerThan (l :: [k]) (a :: Nat) :: Bool where+  IsLongerThan (_ ': _) 'Z = 'True+  IsLongerThan (_ ': xs) ('S a) = IsLongerThan xs a+  IsLongerThan '[] _ = 'False++-- | Comparison of type-level naturals, as a constraint.+type LongerThan l a = IsLongerThan l a ~ 'True++{- | Evaluates list length.++This type family is a best-effort attempt to display neat error messages+when list is known only partially.++For instance, when called on @Int ': Int ': s@, the result will be+@OfLengthWithTail 2 s@ - compare with result of simple 'Length' -+@1 + 1 + Length s@.++For concrete types this will be identical to calling @FromPeano (Length l)@.+-}+type family OfLengthWithTail (acc :: GHC.Nat) (l :: [k]) :: GHC.Nat where+  OfLengthWithTail a '[] = a+  OfLengthWithTail a (_ ': xs) = OfLengthWithTail (a + 1) xs++type LengthWithTail l = OfLengthWithTail 0 l++-- | Comparison of type-level naturals, raises human-readable compile error+-- when does not hold.+--+-- This is for in eDSL use only, GHC cannot reason about such constraint.+type family RequireLongerThan (l :: [k]) (a :: Nat) :: Constraint where+  RequireLongerThan l a =+    If (IsLongerThan l a)+       (() :: Constraint)+       (TypeError+          ('Text "Stack element #" ':<>: 'ShowType (FromPeano a) ':<>:+           'Text " is not accessible" ':$$:+           'Text "Current stack has size of only " ':<>:+           'ShowType (LengthWithTail l) ':<>:+           'Text ":" ':$$: 'ShowType l+           ))++-- | Derive 'LongerThan' from 'RequireLongerThan'.+requiredLongerThan+  :: forall l a r. (RequireLongerThan l a)+  => (LongerThan l a => r) -> r+requiredLongerThan r = do+  -- It's not clear now to proof GHC this implication so we use+  -- @unsafeCoerce@ below and also disable "-Wredundant-constraints" extension.+  case unsafeCoerce @(Dict (LongerThan '[Int] 'Z)) @(Dict (LongerThan l a)) Dict of+    Dict -> r
+ src/Util/Test/Arbitrary.hs view
@@ -0,0 +1,249 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Util.Test.Arbitrary+  ( runGen+  ) where++import Prelude hiding (EQ, GT, LT)++import Test.QuickCheck+  (Arbitrary(..), Gen, choose, elements, frequency, oneof, resize, suchThatMap, vector)+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..))+import Test.QuickCheck.Gen (unGen)+import Test.QuickCheck.Instances.ByteString ()+import Test.QuickCheck.Instances.Natural ()+import Test.QuickCheck.Instances.Semigroup ()+import Test.QuickCheck.Instances.Text ()+import Test.QuickCheck.Random (mkQCGen)++import Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..))+import Michelson.Test ()+import Michelson.Untyped+  (Annotation(..), CT(..), Comparable(..), Contract'(..), Elt(..), ExpandedExtInstr,+  ExpandedOp(..), ExtInstrAbstract(..), FieldAnn, InstrAbstract(..), InternalByteString(..),+  StackTypePattern(..), T(..), TyVar(..), Type(..), TypeAnn, Value'(..), Var(..), VarAnn)+import Tezos.Core (Mutez(..))++instance Arbitrary InternalByteString where+  arbitrary = InternalByteString <$> arbitrary++instance Arbitrary Var where+  arbitrary = Var <$> arbitrary++instance Arbitrary TyVar where+  arbitrary = oneof [VarID <$> arbitrary, TyCon <$> arbitrary]++instance Arbitrary StackTypePattern where+  arbitrary = oneof [pure StkEmpty, pure StkRest, StkCons <$> arbitrary <*> arbitrary]++-- TODO extend Arbitrary ExpandedExtInstr with other constructors+instance Arbitrary ExpandedExtInstr where+  arbitrary = oneof [STACKTYPE <$> arbitrary]++instance ToADTArbitrary Pos+instance Arbitrary Pos where+  arbitrary = Pos <$> arbitrary++instance ToADTArbitrary SrcPos+instance Arbitrary SrcPos where+  arbitrary = liftA2 SrcPos arbitrary arbitrary++instance ToADTArbitrary LetName+instance Arbitrary LetName where+  arbitrary = LetName <$> resize 3 arbitrary++instance ToADTArbitrary InstrCallStack+instance Arbitrary InstrCallStack where+  arbitrary = liftA2 InstrCallStack genName arbitrary+    where+    genName = frequency [(80, pure []), (18, vector 1), (2, vector 2)]++instance ToADTArbitrary ExpandedOp+instance Arbitrary ExpandedOp where+  arbitrary = liftA2 WithSrcEx arbitrary (PrimEx <$> arbitrary)++instance ToADTArbitrary Mutez++-- TODO: why not to merge these three?+instance ToADTArbitrary TypeAnn+instance Arbitrary TypeAnn where+  arbitrary = Annotation <$> resize 5 arbitrary++instance ToADTArbitrary FieldAnn+instance Arbitrary FieldAnn where+  arbitrary = Annotation <$> resize 5 arbitrary++instance ToADTArbitrary VarAnn+instance Arbitrary VarAnn where+  arbitrary = Annotation <$> resize 5 arbitrary++smallSize :: Gen Int+smallSize = choose (0, 3)++smallList :: Arbitrary a => Gen [a]+smallList = smallSize >>= vector++smallList1 :: Arbitrary a => Gen (NonEmpty a)+smallList1 = smallList `suchThatMap` nonEmpty++instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Contract' op)+instance (Arbitrary op) => Arbitrary (Contract' op) where+  arbitrary = Contract <$> arbitrary <*> arbitrary <*> smallList++instance (Arbitrary op, ToADTArbitrary op, Arbitrary (ExtInstrAbstract op)) => ToADTArbitrary (InstrAbstract op)+instance (Arbitrary op, Arbitrary (ExtInstrAbstract op)) => Arbitrary (InstrAbstract op) where+  arbitrary =+    oneof+      [ EXT <$> arbitrary+      , pure DROP+      , DUP <$> arbitrary+      , pure SWAP+      , PUSH <$> arbitrary <*> arbitrary <*> arbitrary+      , SOME <$> arbitrary <*> arbitrary <*> arbitrary+      , NONE <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , UNIT <$> arbitrary <*> arbitrary+      , IF_NONE <$> smallList <*> smallList+      , PAIR <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , CAR <$> arbitrary <*> arbitrary+      , CDR <$> arbitrary <*> arbitrary+      , LEFT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , RIGHT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , IF_LEFT <$> smallList <*> smallList+      , NIL <$> arbitrary <*> arbitrary <*> arbitrary+      , CONS <$> arbitrary+      , IF_CONS <$> smallList <*> smallList+      , SIZE <$> arbitrary+      , EMPTY_SET <$> arbitrary <*> arbitrary <*> arbitrary+      , EMPTY_MAP <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , MAP <$> arbitrary <*> smallList+      , ITER <$> smallList+      , MEM <$> arbitrary+      , GET <$> arbitrary+      , pure UPDATE+      , IF <$> smallList <*> smallList+      , LOOP <$> smallList+      , LOOP_LEFT <$> smallList+      , LAMBDA <$> arbitrary <*> arbitrary <*> arbitrary <*> smallList+      , EXEC <$> arbitrary+      , DIP <$> smallList+      , pure FAILWITH+      , CAST <$> arbitrary <*> arbitrary+      , RENAME <$> arbitrary+      , PACK <$> arbitrary+      , UNPACK <$> arbitrary <*> arbitrary+      , CONCAT <$> arbitrary+      , SLICE <$> arbitrary+      , ISNAT <$> arbitrary+      , ADD <$> arbitrary+      , SUB <$> arbitrary+      , MUL <$> arbitrary+      , EDIV <$> arbitrary+      , ABS <$> arbitrary+      , pure NEG+      , LSL <$> arbitrary+      , LSR <$> arbitrary+      , OR <$> arbitrary+      , AND <$> arbitrary+      , XOR <$> arbitrary+      , NOT <$> arbitrary+      , COMPARE <$> arbitrary+      , EQ <$> arbitrary+      , NEQ <$> arbitrary+      , LT <$> arbitrary+      , GT <$> arbitrary+      , LE <$> arbitrary+      , GE <$> arbitrary+      , INT <$> arbitrary+      , SELF <$> arbitrary+      , CONTRACT <$> arbitrary <*> arbitrary+      , TRANSFER_TOKENS <$> arbitrary+      , SET_DELEGATE <$> arbitrary+      , CREATE_ACCOUNT <$> arbitrary <*> arbitrary+      , CREATE_CONTRACT <$> arbitrary <*> arbitrary <*> arbitrary+      , IMPLICIT_ACCOUNT <$> arbitrary+      , NOW <$> arbitrary+      , AMOUNT <$> arbitrary+      , BALANCE <$> arbitrary+      , CHECK_SIGNATURE <$> arbitrary+      , SHA256 <$> arbitrary+      , SHA512 <$> arbitrary+      , BLAKE2B <$> arbitrary+      , HASH_KEY <$> arbitrary+      , STEPS_TO_QUOTA <$> arbitrary+      , SOURCE <$> arbitrary+      , SENDER <$> arbitrary+      , ADDRESS <$> arbitrary+      ]++instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Value' op)+instance (Arbitrary op) => Arbitrary (Value' op) where+  arbitrary =+    oneof+      [ ValueInt <$> arbitrary+      , ValueString <$> arbitrary+      , ValueBytes <$> arbitrary+      , pure ValueUnit+      , pure ValueTrue+      , pure ValueFalse+      , ValuePair <$> arbitrary <*> arbitrary+      , ValueLeft <$> arbitrary+      , ValueRight <$> arbitrary+      , ValueSome <$> arbitrary+      , pure ValueNone+      , pure ValueNil+      , ValueSeq <$> smallList1+      , ValueMap <$> smallList1+      , ValueLambda <$> smallList1+      ]++instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Elt op)+instance (Arbitrary op) => Arbitrary (Elt op) where+  arbitrary = Elt <$> arbitrary <*> arbitrary++instance ToADTArbitrary Type+instance Arbitrary Type where+  arbitrary = Type <$> arbitrary <*> arbitrary++-- | @getRareT k@ generates 'T' producing anything big once per @1 / (k + 1)@+-- invocation.+genRareType :: Word -> Gen Type+genRareType k = Type <$> genRareT k <*> arbitrary++instance ToADTArbitrary T+instance Arbitrary T where+  arbitrary =+    oneof+      [ Tc <$> arbitrary+      , pure TKey+      , pure TUnit+      , pure TSignature+      , TOption <$> arbitrary <*> arbitrary+      , TList <$> arbitrary+      , TSet <$> arbitrary+      , pure TOperation+      , TContract <$> arbitrary+      , TPair <$> arbitrary <*> arbitrary <*> genRareType 5 <*> genRareType 5+      , TOr <$> arbitrary <*> arbitrary <*> genRareType 5 <*> genRareType 5+      , TLambda <$> genRareType 5 <*> genRareType 5+      , TMap <$> arbitrary <*> arbitrary+      , TBigMap <$> arbitrary <*> arbitrary+      ]++-- | @getRareT k@ generates 'Type' producing anything big once per @1 / (k + 1)@+-- invocation.+--+-- Useful to avoid exponensial growth.+genRareT :: Word -> Gen T+genRareT k = frequency [(1, arbitrary), (fromIntegral k, pure TUnit)]++instance ToADTArbitrary CT+instance Arbitrary CT where+  arbitrary =  elements [minBound .. maxBound]++instance ToADTArbitrary Comparable+instance Arbitrary Comparable where+  arbitrary = Comparable <$> arbitrary <*> arbitrary++-- | Run given generator deterministically.+runGen :: Int -> Gen a -> a+runGen seed gen = unGen gen (mkQCGen seed) 10
+ src/Util/Test/Ingredients.hs view
@@ -0,0 +1,14 @@+-- | Ingridients that we use in our test suite.++module Util.Test.Ingredients+  ( ourIngredients+  ) where++import Test.Tasty (defaultIngredients)+import Test.Tasty.Ingredients (Ingredient)+import Test.Tasty.Runners.AntXML (antXMLRunner)++-- | This is the default set of ingredients extended with the+-- 'antXMLRunner' which is used to generate xml reports for CI.+ourIngredients :: [Ingredient]+ourIngredients = antXMLRunner:defaultIngredients
+ src/Util/Type.hs view
@@ -0,0 +1,9 @@+-- | General type utilities.+module Util.Type+  ( IsElem+  ) where++type family IsElem (a :: k) (l :: [k]) :: Bool where+  IsElem _ '[] = 'False+  IsElem a (a ': _) = 'True+  IsElem a (_ ': as) = IsElem a as
+ src/Util/TypeTuple.hs view
@@ -0,0 +1,7 @@+-- | Conversions between tuples and list-like types.+module Util.TypeTuple+  ( RecFromTuple (..)+  ) where++import Util.TypeTuple.Class+import Util.TypeTuple.Instances ()
+ src/Util/TypeTuple/Class.hs view
@@ -0,0 +1,15 @@+module Util.TypeTuple.Class+  ( RecFromTuple (..)+  ) where++import qualified Data.Kind as Kind++-- | Building a record from tuple.+--+-- It differs from similar typeclass in 'Data.Vinyl.FromTuple' module in that+-- it allows type inference outside-in - knowing desired 'Rec' you know which+-- tuple should be provided - this improves error messages when constructing+-- concrete 'Rec' objects.+class RecFromTuple r where+  type IsoRecTuple r :: Kind.Type+  recFromTuple :: IsoRecTuple r -> r
+ src/Util/TypeTuple/Instances.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Util.TypeTuple.Instances () where++import Util.TypeTuple.TH++concatMapM deriveRecFromTuple [0..15]
+ src/Util/TypeTuple/TH.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Template haskell generator for 'RecFromTuple', in a separate module+-- because of staging restrictions.+module Util.TypeTuple.TH+  ( deriveRecFromTuple+  ) where++import qualified Data.Kind as Kind+import Data.Vinyl.Core (Rec(..))+import qualified Language.Haskell.TH as TH++import Util.TypeTuple.Class++-- | Produce 'RecFromTuple' instance for tuple of the given length.+deriveRecFromTuple :: Word -> TH.Q [TH.Dec]+deriveRecFromTuple (fromIntegral -> n) = do+  fVar <- TH.VarT <$> TH.newName "f"+  tyVars <- replicateM n $ TH.VarT <$> TH.newName "x"++  let consTy ty lty = TH.promotedConsT `TH.appT` pure ty `TH.appT` lty+  let tyList = foldr consTy TH.promotedNilT tyVars++  let tupleConsTy acc ty = acc `TH.appT` (pure fVar `TH.appT` pure ty)+  let tyTuple = foldl tupleConsTy (TH.tupleT n) tyVars++  vars <- replicateM n $ TH.newName "a"+  let tyPat = pure . TH.TupP $ map TH.VarP vars++  let consRec var acc = [e|(:&)|] `TH.appE` TH.varE var `TH.appE` acc+  let recRes = foldr consRec [e|RNil|] vars++  [d| instance RecFromTuple (Rec ($(pure fVar) :: u -> Kind.Type) $tyList) where+        type IsoRecTuple (Rec $(pure fVar) $tyList) = $tyTuple+        recFromTuple $tyPat = $recRes+    |]
+ test/Main.hs view
@@ -0,0 +1,12 @@+module Main+  ( main+  ) where++import Test.Tasty (defaultMainWithIngredients)++import Util.Test.Ingredients (ourIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= defaultMainWithIngredients ourIngredients
− test/Spec.hs 
@@ -1,35 +0,0 @@-module Main-  ( main-  ) where--import Test.Hspec (hspec)--import qualified Test.CValConversion as CVal-import qualified Test.Interpreter as Interpreter-import qualified Test.Macro as Macro-import qualified Test.Morley.Runtime as Morley.Runtime-import qualified Test.Ext as Ext-import qualified Test.Parser as Parser-import qualified Test.Printer.Michelson as Printer.Michelson-import qualified Test.Serialization.Aeson as Serialization.Aeson-import qualified Test.Tezos.Address as Tezos.Address-import qualified Test.Tezos.Crypto as Tezos.Crypto-import qualified Test.Typecheck as Typecheck-import qualified Test.ValConversion as Val--main :: IO ()-main = hspec $ do-  Parser.spec-  Macro.spec-  Typecheck.typeCheckSpec-  Ext.typeCheckHandlerSpec-  Ext.interpretHandlerSpec-  Interpreter.spec-  Tezos.Crypto.spec-  Tezos.Address.spec-  Morley.Runtime.spec-  Serialization.Aeson.spec-  Interpreter.spec-  Val.spec-  CVal.spec-  Printer.Michelson.spec
− test/Test/Arbitrary.hs 
@@ -1,254 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--module Test.Arbitrary () where--import Prelude hiding (EQ, GT, LT)--import qualified Data.Text as T-import qualified Data.Text.Encoding as T--import Test.QuickCheck (Arbitrary(..), Gen, choose, elements, listOf, oneof, suchThatMap, vector)-import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..))-import Test.QuickCheck.Instances.Semigroup ()-import Test.QuickCheck.Instances.Text ()--import Michelson.Untyped-  (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), FieldAnn, InstrAbstract(..),-  InternalByteString(..), ExpandedOp (..), T(..), Type(..), TypeAnn, Value(..), VarAnn)-import Morley.Test ()-import Morley.Types (StackTypePattern(..), TyVar(..), ExpandedUExtInstr, UExtInstrAbstract(..), Var(..))-import Tezos.Core (Mutez(..))--instance Arbitrary InternalByteString where-  arbitrary = InternalByteString . T.encodeUtf8 . T.pack <$> listOf arbitrary--instance Arbitrary Var where-  arbitrary = Var <$> arbitrary--instance Arbitrary TyVar where-  arbitrary = oneof [VarID <$> arbitrary, TyCon <$> arbitrary]--instance Arbitrary StackTypePattern where-  arbitrary = oneof [pure StkEmpty, pure StkRest, StkCons <$> arbitrary <*> arbitrary]---- TODO extend Arbitrary ExpandedUExtInstr with other constructors-instance Arbitrary ExpandedUExtInstr where-  arbitrary = oneof [STACKTYPE <$> arbitrary]--instance ToADTArbitrary ExpandedOp-instance Arbitrary ExpandedOp where-  arbitrary = PrimEx <$> arbitrary--instance ToADTArbitrary Mutez--instance ToADTArbitrary TypeAnn-instance Arbitrary TypeAnn where-  arbitrary = Annotation <$> arbitrary--instance ToADTArbitrary FieldAnn-instance Arbitrary FieldAnn where-  arbitrary = Annotation <$> arbitrary--instance ToADTArbitrary VarAnn-instance Arbitrary VarAnn where-  arbitrary = Annotation <$> arbitrary--smallSize :: Gen Int-smallSize = choose (0, 3)--smallList :: Arbitrary a => Gen [a]-smallList = smallSize >>= vector--smallList1 :: Arbitrary a => Gen (NonEmpty a)-smallList1 = smallList `suchThatMap` nonEmpty--instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Contract op)-instance (Arbitrary op) => Arbitrary (Contract op) where-  arbitrary = Contract <$> arbitrary <*> arbitrary <*> arbitrary--instance (Arbitrary op, ToADTArbitrary op, Arbitrary (UExtInstrAbstract op)) => ToADTArbitrary (InstrAbstract op)-instance (Arbitrary op, Arbitrary (UExtInstrAbstract op)) => Arbitrary (InstrAbstract op) where-  arbitrary =-    oneof-      [ EXT <$> arbitrary-      , pure DROP-      , DUP <$> arbitrary-      , pure SWAP-      , PUSH <$> arbitrary <*> arbitrary <*> arbitrary-      , SOME <$> arbitrary <*> arbitrary <*> arbitrary-      , NONE <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , UNIT <$> arbitrary <*> arbitrary-      , (do size1 <- smallSize-            size2 <- smallSize-            l1 <- vector size1-            l2 <- vector size2-            pure $ IF_NONE l1 l2-        )-      , PAIR <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , CAR <$> arbitrary <*> arbitrary-      , CDR <$> arbitrary <*> arbitrary-      , LEFT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , RIGHT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , (do size1 <- smallSize-            size2 <- smallSize-            l1 <- vector size1-            l2 <- vector size2-            pure $ IF_LEFT l1 l2-        )-      , (do size1 <- smallSize-            size2 <- smallSize-            l1 <- vector size1-            l2 <- vector size2-            pure $ IF_RIGHT l1 l2-        )-      , NIL <$> arbitrary <*> arbitrary <*> arbitrary-      , CONS <$> arbitrary-      , (do size1 <- smallSize-            size2 <- smallSize-            l1 <- vector size1-            l2 <- vector size2-            pure $ IF_CONS l1 l2-        )-      , SIZE <$> arbitrary-      , EMPTY_SET <$> arbitrary <*> arbitrary <*> arbitrary-      , EMPTY_MAP <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , (do size1 <- smallSize-            l1 <- vector size1-            MAP <$> arbitrary <*> pure l1-        )-      , (do size1 <- smallSize-            l1 <- vector size1-            pure $ ITER l1-        )-      , MEM <$> arbitrary-      , GET <$> arbitrary-      , pure UPDATE-      , (do size1 <- smallSize-            size2 <- smallSize-            l1 <- vector size1-            l2 <- vector size2-            pure $ IF l1 l2-        )-      , (do size1 <- smallSize-            l1 <- vector size1-            pure $ LOOP l1-        )-      , (do size1 <- smallSize-            l1 <- vector size1-            pure $ LOOP_LEFT l1-        )-      , (do size1 <- smallSize-            l1 <- vector size1-            LAMBDA <$> arbitrary <*> arbitrary <*> arbitrary <*> pure l1-        )-      , EXEC <$> arbitrary-      , (do size1 <- smallSize-            l1 <- vector size1-            pure $ DIP l1-        )-      , pure FAILWITH-      , CAST <$> arbitrary <*> arbitrary-      , RENAME <$> arbitrary-      , PACK <$> arbitrary-      , UNPACK <$> arbitrary <*> arbitrary-      , CONCAT <$> arbitrary-      , SLICE <$> arbitrary-      , ISNAT <$> arbitrary-      , ADD <$> arbitrary-      , SUB <$> arbitrary-      , MUL <$> arbitrary-      , EDIV <$> arbitrary-      , ABS <$> arbitrary-      , pure NEG-      , LSL <$> arbitrary-      , LSR <$> arbitrary-      , OR <$> arbitrary-      , AND <$> arbitrary-      , XOR <$> arbitrary-      , NOT <$> arbitrary-      , COMPARE <$> arbitrary-      , EQ <$> arbitrary-      , NEQ <$> arbitrary-      , LT <$> arbitrary-      , GT <$> arbitrary-      , LE <$> arbitrary-      , GE <$> arbitrary-      , INT <$> arbitrary-      , SELF <$> arbitrary-      , CONTRACT <$> arbitrary <*> arbitrary-      , TRANSFER_TOKENS <$> arbitrary-      , SET_DELEGATE <$> arbitrary-      , CREATE_ACCOUNT <$> arbitrary <*> arbitrary-      , CREATE_CONTRACT <$> arbitrary <*> arbitrary-      , CREATE_CONTRACT2 <$> arbitrary <*> arbitrary <*> arbitrary-      , IMPLICIT_ACCOUNT <$> arbitrary-      , NOW <$> arbitrary-      , AMOUNT <$> arbitrary-      , BALANCE <$> arbitrary-      , CHECK_SIGNATURE <$> arbitrary-      , SHA256 <$> arbitrary-      , SHA512 <$> arbitrary-      , BLAKE2B <$> arbitrary-      , HASH_KEY <$> arbitrary-      , STEPS_TO_QUOTA <$> arbitrary-      , SOURCE <$> arbitrary-      , SENDER <$> arbitrary-      , ADDRESS <$> arbitrary-      ]--instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Value op)-instance (Arbitrary op) => Arbitrary (Value op) where-  arbitrary =-    oneof-      [ ValueInt <$> arbitrary-      , ValueString <$> arbitrary-      , ValueBytes <$> arbitrary-      , pure ValueUnit-      , pure ValueTrue-      , pure ValueFalse-      , ValuePair <$> arbitrary <*> arbitrary-      , ValueLeft <$> arbitrary-      , ValueRight <$> arbitrary-      , ValueSome <$> arbitrary-      , pure ValueNone-      , pure ValueNil-      , ValueSeq <$> smallList1-      , ValueMap <$> smallList1-      , ValueLambda <$> smallList1-      ]--instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Elt op)-instance (Arbitrary op) => Arbitrary (Elt op) where-  arbitrary = Elt <$> arbitrary <*> arbitrary--instance ToADTArbitrary Type-instance Arbitrary Type where-  arbitrary = Type <$> arbitrary <*> arbitrary--instance ToADTArbitrary T-instance Arbitrary T where-  arbitrary =-    oneof-      [ Tc <$> arbitrary-      , pure TKey-      , pure TUnit-      , pure TSignature-      , TOption <$> arbitrary <*> arbitrary-      , TList <$> arbitrary-      , TSet <$> arbitrary-      , pure TOperation-      , TContract <$> arbitrary-      , TPair <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , TOr <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-      , TLambda <$> arbitrary <*> arbitrary-      , TMap <$> arbitrary <*> arbitrary-      , TBigMap <$> arbitrary <*> arbitrary-      ]--instance ToADTArbitrary CT-instance Arbitrary CT where-  arbitrary =  elements [minBound .. maxBound]--instance ToADTArbitrary Comparable-instance Arbitrary Comparable where-  arbitrary = Comparable <$> arbitrary <*> arbitrary
test/Test/CValConversion.hs view
@@ -1,32 +1,34 @@ -- | Testing of toCVal / fromCVal conversions  module Test.CValConversion-  ( spec+  ( unit_toCVal+  , unit_fromCVal+  , test_Roundtrip   ) where -import Test.Hspec (Spec, describe, it, shouldBe)-import Test.Hspec.QuickCheck (prop)+import Test.Hspec.Expectations (Expectation, shouldBe)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty, (===)) -import Michelson.Typed (CVal(..), fromCVal, toCVal)+import Michelson.Typed (CValue(..), fromCVal, toCVal)+import Michelson.Text --- | Spec to test toCVal / fromCVal conversions.-spec :: Spec-spec = do-  describe "ToCVal / FromCVal tests" $ do-    it "ToCVal / FromCVal manual tests" $ do-      toCVal @Int 10 `shouldBe` CvInt 10-      toCVal @Integer 10 `shouldBe` CvInt 10-      toCVal @Integer (-10) `shouldBe` CvInt (-10)-      toCVal @Word64 10 `shouldBe` CvNat 10-      toCVal @Natural 10 `shouldBe` CvNat 10-      toCVal @Text "abc" `shouldBe` CvString "abc"-      toCVal True `shouldBe` CvBool True-      fromCVal (CvInt 10) `shouldBe` (10 :: Integer)-      fromCVal (CvString "abc") `shouldBe` ("abc" :: Text)-      fromCVal (CvBool True) `shouldBe` True+unit_toCVal :: Expectation+unit_toCVal = do+  toCVal @Integer 10 `shouldBe` CvInt 10+  toCVal @Integer (-10) `shouldBe` CvInt (-10)+  toCVal @Natural 10 `shouldBe` CvNat 10+  toCVal [mt|abc|] `shouldBe` CvString [mt|abc|]+  toCVal True `shouldBe` CvBool True -    describe "ToCVal / FromCVal property tests" $ do-      prop "ToCVal / FromCVal: Integer"-        $ \v -> fromCVal (toCVal @Integer v) == v-      prop "ToCVal / FromCVal: Bool"-        $ \v -> fromCVal (toCVal @Bool v) == v+unit_fromCVal :: Expectation+unit_fromCVal = do+  fromCVal (CvInt 10) `shouldBe` (10 :: Integer)+  fromCVal (CvString [mt|abc|]) `shouldBe` [mt|abc|]+  fromCVal (CvBool True) `shouldBe` True++test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ testProperty "Integer" $ \v -> fromCVal (toCVal @Integer v) === v+  , testProperty "Bool" $ \v -> fromCVal (toCVal @Bool v) === v+  ]
test/Test/Ext.hs view
@@ -1,52 +1,61 @@ module Test.Ext-  ( typeCheckHandlerSpec-  , interpretHandlerSpec+  ( spec_Ext_Intepreter+  , test_STACKTYPE   ) where -import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldSatisfy)+import Data.Default (def)+import Test.Hspec (Spec, describe, it, shouldSatisfy)+import Test.HUnit (Assertion, assertFailure)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase) -import Michelson.Interpret (InterpreterState(..))-import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheckT)-import Michelson.Typed (CVal(..), Instr, Val(..), extractNotes, fromUType, withSomeSingT)+import Michelson.Interpret (InterpreterState(..), MorleyLogs(..), interpret)+import Michelson.Test (specWithTypedContract)+import Michelson.Test.Dummy (dummyContractEnv)+import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheck, typeCheckExt, typeCheckList)+import Michelson.Typed (CValue(..), extractNotes, fromUType, withSomeSingT) import qualified Michelson.Typed as T-import Michelson.Untyped (CT(..), T(..), Type(..), ann, noAnn)-import Morley.Ext (interpretMorley, typeCheckHandler)-import Morley.Test (specWithTypedContract)-import Morley.Test.Dummy (dummyContractEnv)-import Morley.Types-  (MorleyLogs(..), StackTypePattern(..), TyVar(..), ExpandedUExtInstr, UExtInstrAbstract(..))+import Michelson.Untyped+  (CT(..), ExpandedExtInstr, ExtInstrAbstract(..), StackTypePattern(..), T(..), TyVar(..),+  Type(..), ann, noAnn) -interpretHandlerSpec :: Spec-interpretHandlerSpec = describe "interpretHandler PRINT/TEST_ASSERT tests" $-  specWithTypedContract "contracts/testassert_square.tz" $ \c -> do-    it "TEST_ASSERT assertion passed" $ do-      runTest True c 100 100-      runTest True c 1 1-    it "TEST_ASSERT assertion failed" $ do-      runTest False c 0 100-      runTest False c -1 -2+spec_Ext_Intepreter :: Spec+spec_Ext_Intepreter = describe "PRINT/TEST_ASSERT tests" $ do+  specWithTypedContract "contracts/testassert_square.mtz" $+    testAssertSquareSpec+  specWithTypedContract "contracts/testassert_square2.mtz" $+    testAssertSquareSpec   where+    testAssertSquareSpec c = do+      it "TEST_ASSERT assertion passed" $ do+        runTest True c 100 100+        runTest True c 1 1+      it "TEST_ASSERT assertion failed" $ do+        runTest False c 0 100+        runTest False c -1 -2+     runTest corr contract x y = do-      let x' = VC $ CvInt x :: Val Instr ('T.Tc 'T.CInt)-      let y' = VC $ CvInt y :: Val Instr ('T.Tc 'T.CInt)-      let area' = VC $ CvInt $ x * y :: Val Instr ('T.Tc 'T.CInt)+      let x' = T.VC $ T.CvInt x :: T.Value ('T.Tc 'T.CInt)+      let y' = T.VC $ T.CvInt y :: T.Value ('T.Tc 'T.CInt)+      let area' = T.VC $ CvInt $ x * y :: T.Value ('T.Tc 'T.CInt)       let check (a, InterpreterState s _) =             if corr then isRight a && s == MorleyLogs ["Area is " <> show area']             else isLeft a && s == MorleyLogs ["Sides are " <> show x' <> " x " <> show y']-      interpretMorley contract (VPair (x', y')) VUnit dummyContractEnv `shouldSatisfy` check+      interpret contract (T.VPair (x', y')) T.VUnit dummyContractEnv `shouldSatisfy` check -typeCheckHandlerSpec :: Spec-typeCheckHandlerSpec = describe "typeCheckHandler STACKTYPE tests" $ do-  it "Correct test on [] pattern" $ runNopTest test1 True-  it "Correct test on [a, b] pattern" $ runNopTest test2 True-  it "Correct test on [a, b, ...] pattern" $ runNopTest test3 True-  it "Correct test on [a, b, ...] pattern and stack [a, b]" $ runNopTest test4 True+test_STACKTYPE :: [TestTree]+test_STACKTYPE =+  [ testCase "Correct test on [] pattern" $ runExtTest test1 True+  , testCase "Correct test on [a, b] pattern" $ runExtTest test2 True+  , testCase "Correct test on [a, b, ...] pattern" $ runExtTest test3 True+  , testCase "Correct test on [a, b, ...] pattern and stack [a, b]" $ runExtTest test4 True -  it "Failed test on [] pattern and stack [a]" $ runNopTest test5 False-  it "Failed test on [a, b] pattern and stack [a, b, c]" $ runNopTest test6 False-  it "Failed test on [a, b] pattern and stack [a]" $ runNopTest test7 False-  it "Failed test on [a, b, ...] pattern and stack [a]" $ runNopTest test8 False-  it "Failed test on [a, b] pattern and stack [a, c]" $ runNopTest test9 False+  , testCase "Failed test on [] pattern and stack [a]" $ runExtTest test5 False+  , testCase "Failed test on [a, b] pattern and stack [a, b, c]" $ runExtTest test6 False+  , testCase "Failed test on [a, b] pattern and stack [a]" $ runExtTest test7 False+  , testCase "Failed test on [a, b, ...] pattern and stack [a]" $ runExtTest test8 False+  , testCase "Failed test on [a, b] pattern and stack [a, c]" $ runExtTest test9 False+  ]   where     p2 = StkCons (TyCon t1) (StkCons (TyCon t2) StkEmpty)     p3 = StkCons (TyCon t1) (StkCons (TyCon t2) StkRest)@@ -69,14 +78,16 @@     convertToHST :: [Type] -> SomeHST     convertToHST [] = SomeHST SNil     convertToHST (t : ts) = withSomeSingT (fromUType t) $ \sing ->-      let nt = either (const $ error "unexpected trouble with extracting annotations") id (extractNotes t sing) in+      let nt = fromRight (error "unexpected trouble with extracting annotations")+                         (extractNotes t sing) in       case convertToHST ts of         SomeHST is -> SomeHST ((sing, nt, noAnn) ::& is) -    nh (ni, si) = runTypeCheckT typeCheckHandler (Type TKey noAnn) $ typeCheckHandler ni [] si+    nh (ni, si) =+      runTypeCheck (Type TKey noAnn) mempty $ usingReaderT def $ typeCheckExt typeCheckList ni si -    runNopTest :: (ExpandedUExtInstr, SomeHST) -> Bool -> Expectation-    runNopTest tcase correct = case (nh tcase, correct) of-      (Right _, False) -> expectationFailure $ "Test expected to fail but it passed"-      (Left e, True)   -> expectationFailure $ "Test expected to pass but it failed with error: " <> show e+    runExtTest :: (ExpandedExtInstr, SomeHST) -> Bool -> Assertion+    runExtTest (ui, SomeHST hst) correct = case (nh (ui, hst), correct) of+      (Right _, False) -> assertFailure $ "Test expected to fail but it passed"+      (Left e, True)   -> assertFailure $ "Test expected to pass but it failed with error: " <> show e       _                -> pass
test/Test/Interpreter.hs view
@@ -1,28 +1,35 @@+{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}+ module Test.Interpreter-  ( spec+  ( spec_Interpreter   ) where -import Fmt (pretty)+import Data.Singletons (SingI)+import Fmt (pretty, (+|), (|+)) import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Property, label, (.&&.), (===)) -import Michelson.Interpret (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps)-import Michelson.Typed (CT(..), CVal(..), Instr(..), T(..), ToT, Val(..), fromVal, toVal, ( # ))-import Morley.Ext (interpretMorley)-import Morley.Test (ContractPropValidator, contractProp, specWithTypedContract)-import Morley.Test.Dummy (dummyContractEnv)-import Morley.Test.Util (failedProp)-import Morley.Types (MorleyLogs)-import Test.Interpreter.Auction (auctionSpec)+import Lorentz (( # ))+import qualified Lorentz as L+import Michelson.Interpret+  (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps, interpret)+import Michelson.Test (ContractPropValidator, contractProp, specWithTypedContract)+import Michelson.Test.Dummy (dummyContractEnv)+import Michelson.Test.Util (failedProp)+import Michelson.Typed (CT(..), CValue(..), IsoValue(..), T(..))+import Michelson.Text+import qualified Michelson.Typed as T+import Test.Interpreter.A1.Feather (featherSpec) import Test.Interpreter.CallSelf (selfCallerSpec) import Test.Interpreter.Compare (compareSpec) import Test.Interpreter.Conditionals (conditionalsSpec)+import Test.Interpreter.ContractOp (contractOpSpec) import Test.Interpreter.EnvironmentSpec (environmentSpec) import Test.Interpreter.StringCaller (stringCallerSpec) -spec :: Spec-spec = describe "Advanced type interpreter tests" $ do+spec_Interpreter :: Spec+spec_Interpreter = do   let contractResShouldBe (res, _) expected =         case res of           Left err -> expectationFailure $ "Unexpected failure: " <> pretty err@@ -30,27 +37,27 @@    specWithTypedContract "contracts/basic5.tz" $ \contract ->     it "Basic test" $-      interpretMorley contract VUnit (toVal [1 :: Integer]) dummyContractEnv+      interpret contract T.VUnit (toVal [1 :: Integer]) dummyContractEnv         `contractResShouldBe` (toVal [13 :: Integer, 100])    specWithTypedContract "contracts/increment.tz" $ \contract ->     it "Basic test" $-      interpretMorley contract VUnit (toVal @Integer 23) dummyContractEnv+      interpret contract T.VUnit (toVal @Integer 23) dummyContractEnv         `contractResShouldBe` (toVal @Integer 24) -  specWithTypedContract "contracts/fail.tz" $ \contract ->+  specWithTypedContract "contracts/tezos_examples/fail.tz" $ \contract ->     it "Fail test" $-      interpretMorley contract VUnit VUnit dummyContractEnv+      interpret contract T.VUnit T.VUnit dummyContractEnv         `shouldSatisfy` (isLeft . fst)    specWithTypedContract "contracts/mutez_add_overflow.tz" $ \contract ->     it "Mutez add overflow test" $-      interpretMorley contract VUnit VUnit dummyContractEnv+      interpret contract T.VUnit T.VUnit dummyContractEnv         `shouldSatisfy` (isLeft . fst)    specWithTypedContract "contracts/mutez_sub_underflow.tz" $ \contract ->     it "Mutez sub underflow test" $-      interpretMorley contract VUnit VUnit dummyContractEnv+      interpret contract T.VUnit T.VUnit dummyContractEnv         `shouldSatisfy` (isLeft . fst)    specWithTypedContract "contracts/basic1.tz" $ \contract -> do@@ -58,32 +65,64 @@       contractProp @_ @[Integer] contract (validateBasic1 input)       dummyContractEnv () input -  auctionSpec+  specWithTypedContract "contracts/lsl.tz" $ \contract -> do+    it "LSL shouldn't overflow test" $+      interpret contract (toVal @Natural 5) (toVal @Natural 2) dummyContractEnv+        `contractResShouldBe` (toVal @Natural 20)+    it "LSL should overflow test" $+      interpret contract (toVal @Natural 5) (toVal @Natural 257) dummyContractEnv+        `shouldSatisfy` (isLeft . fst)++  specWithTypedContract "contracts/lsr.tz" $ \contract -> do+    it "LSR shouldn't underflow test" $+      interpret contract (toVal @Natural 30) (toVal @Natural 3) dummyContractEnv+        `contractResShouldBe` (toVal @Natural 3)+    it "LSR should underflow test" $+      interpret contract (toVal @Natural 1000) (toVal @Natural 257) dummyContractEnv+        `shouldSatisfy` (isLeft . fst)++  describe "FAILWITH" $ do+    specWithTypedContract "contracts/failwith_message.tz" $ \contract ->+      it "Failwith message test" $ do+        let msg = [mt|An error occurred.|] :: MText+        contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv msg ()++    specWithTypedContract "contracts/failwith_message2.tz" $ \contract -> do+        it "Conditional failwith message test" $ do+          let msg = [mt|An error occurred.|]+          contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv (True, msg) ()++        it "Conditional success test" $ do+          let param = (False, [mt|Err|] :: MText)+          contractProp contract validateSuccess dummyContractEnv param ()+   compareSpec   conditionalsSpec   stringCallerSpec   selfCallerSpec   environmentSpec+  contractOpSpec+  featherSpec    specWithTypedContract "contracts/steps_to_quota_test1.tz" $ \contract -> do     it "Amount of steps should reduce" $ do       validateStepsToQuotaTest-        (interpretMorley contract VUnit (VC (CvNat 0)) dummyContractEnv) 4+        (interpret contract T.VUnit (T.VC (CvNat 0)) dummyContractEnv) 4    specWithTypedContract "contracts/steps_to_quota_test2.tz" $ \contract -> do     it "Amount of steps should reduce" $ do       validateStepsToQuotaTest-        (interpretMorley contract VUnit (VC (CvNat 0)) dummyContractEnv) 8+        (interpret contract T.VUnit (T.VC (CvNat 0)) dummyContractEnv) 8    specWithTypedContract "contracts/gas_exhaustion.tz" $ \contract -> do     it "Contract should fail due to gas exhaustion" $ do-      let dummyStr = toVal @Text "x"-      case fst $ interpretMorley contract dummyStr dummyStr dummyContractEnv of+      let dummyStr = toVal [mt|x|]+      case fst $ interpret contract dummyStr dummyStr dummyContractEnv of         Right _ -> expectationFailure "expecting contract to fail"         Left MichelsonGasExhaustion -> pass         Left _ -> expectationFailure "expecting another failure reason" -  specWithTypedContract "contracts/add1_list.tz" $ \contract -> do+  specWithTypedContract "contracts/tezos_examples/add1_list.tz" $ \contract -> do     let       validate ::         [Integer] -> ContractPropValidator (ToT [Integer]) Property@@ -96,6 +135,94 @@     prop "Random check" $ \param ->       contractProp contract (validate param) dummyContractEnv param param +  it "mkStackRef does not segfault" $ do+    let contract = L.drop # L.push () # L.dup # L.printComment (L.stackRef @1)+                          # L.drop # L.nil @T.Operation # L.pair+    contractProp (L.compileLorentzContract @() contract) (isRight . fst) dummyContractEnv () ()++  specWithTypedContract "contracts/union.mtz" $ \contract -> do+    describe "Union corresponds to Haskell types properly" $ do+      let caseTest param =+            contractProp contract validateSuccess dummyContractEnv param ()++      it "Case 1" $ caseTest (Case1 3)+      it "Case 2" $ caseTest (Case2 [mt|a|])+      it "Case 3" $ caseTest (Case3 $ Just [mt|b|])+      it "Case 4" $ caseTest (Case4 $ Left [mt|b|])+      it "Case 5" $ caseTest (Case5 [[mt|q|]])++  specWithTypedContract "contracts/case.mtz" $ \contract -> do+    describe "CASE instruction" $ do+      let caseTest param expectedStorage =+            contractProp contract (validateStorageIs @MText expectedStorage)+              dummyContractEnv param [mt||]++      it "Case 1" $ caseTest (Case1 5) [mt|int|]+      it "Case 2" $ caseTest (Case2 [mt|a|]) [mt|string|]+      it "Case 3" $ caseTest (Case3 $ Just [mt|aa|]) [mt|aa|]+      it "Case 4" $ caseTest (Case4 $ Right [mt|b|]) [mt|or string string|]+      it "Case 5" $ caseTest (Case5 $ [[mt|a|], [mt|b|]]) [mt|ab|]++  specWithTypedContract "contracts/tag.mtz" $ \contract -> do+    it "TAG instruction" $+      let expected = mconcat [[mt|unit|], [mt|o|], [mt|ab|], [mt|nat|], [mt|int|]]+      in contractProp contract (validateStorageIs expected) dummyContractEnv+         () [mt||]++  specWithTypedContract "contracts/tezos_examples/split_bytes.tz" $ \contract -> do+    it "splits given byte sequence into parts" $+      let expected = ["\11", "\12", "\13"] :: [ByteString]+      in contractProp contract (validateStorageIs expected) dummyContractEnv+         ("\11\12\13" :: ByteString) ([] :: [ByteString])++  specWithTypedContract "contracts/split_string_simple.tz" $ \contract -> do+    it "applies SLICE instruction" $ do+      let+        oneTest :: Natural -> Natural -> MText -> Maybe MText -> Expectation+        oneTest o l str expected =+          contractProp contract (validateStorageIs expected) dummyContractEnv+          (o, l) (Just str)++      -- These values have been tested using alphanet.sh+      oneTest 0 0 [mt|aaa|] (Just [mt||])+      oneTest 2 0 [mt|aaa|] (Just [mt||])+      oneTest 3 0 [mt|aaa|] Nothing+      oneTest 0 5 [mt|aaa|] Nothing+      oneTest 1 2 [mt|abc|] (Just [mt|bc|])+      oneTest 1 1 [mt|abc|] (Just [mt|b|])+      oneTest 2 1 [mt|abc|] (Just [mt|c|])+      oneTest 2 2 [mt|abc|] Nothing+      oneTest 1 1 [mt|a""|] (Just [mt|"|])+      oneTest 1 2 [mt|a\n|] Nothing++  specWithTypedContract "contracts/complex_strings.tz" $ \contract ->+    prop "Complex string" $+      contractProp contract+      (validateStorageIs [mt|text: "aa" \\\n|])+      dummyContractEnv [mt|text: |] [mt||]++data Union1+  = Case1 Integer+  | Case2 MText+  | Case3 (Maybe MText)+  | Case4 (Either MText MText)+  | Case5 [MText]+  deriving stock (Generic)+  deriving anyclass (IsoValue)++validateSuccess :: ContractPropValidator st Expectation+validateSuccess (res, _) = res `shouldSatisfy` isRight++validateStorageIs+  :: IsoValue st+  => st -> ContractPropValidator (ToT st) Expectation+validateStorageIs expected (res, _) =+  case res of+    Left err ->+      expectationFailure $ "Unexpected interpretation failure: " +| err |+ ""+    Right (_ops, got) ->+      got `shouldBe` toVal expected+ validateBasic1   :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property validateBasic1 input (Right (ops, res), _) =@@ -105,35 +232,14 @@ validateBasic1 _ (Left e, _) = failedProp $ show e  validateStepsToQuotaTest ::-     ContractReturn MorleyLogs ('Tc 'CNat) -> RemainingSteps -> Expectation+     ContractReturn ('Tc 'CNat) -> RemainingSteps -> Expectation validateStepsToQuotaTest res numOfSteps =   case fst res of-    Right ([], VC (CvNat x)) ->+    Right ([], T.VC (CvNat x)) ->       (fromInteger . toInteger) x `shouldBe` ceMaxSteps dummyContractEnv - numOfSteps     _ -> expectationFailure "unexpected contract result" ------------------------ Examples------------------------- | @myInstr@ is an equivalent to Michelson code:------    PUSH int 223;---    SOME;---    IF_NONE { DUP; } { SWAP; };---    ADD;---    PUSH nat 12---    ADD;-_myInstr :: Typeable s => Instr ('Tc 'CInt : s) ('Tc 'CInt : s)-_myInstr =-  PUSH (VC $ CvInt 223) #-  SOME #-  IF_NONE DUP SWAP #-  ADD #-  PUSH (VC $ CvNat 12) #-  ADD--_myInstr2 :: Typeable a => Instr a ('TOption ('Tc 'CInt) : a)-_myInstr2 =-  PUSH (VOption $ Just $ VC $ CvInt 223) #-  Nop+validateMichelsonFailsWith+  :: (T.IsoValue v, Typeable (ToT v), SingI (ToT v))+  => v -> ContractPropValidator st Expectation+validateMichelsonFailsWith v (res, _) = res `shouldBe` Left (MichelsonFailedWith $ toVal v)
+ test/Test/Interpreter/A1/Feather.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}++-- | Tests for feathering as described in TZIP-A1.++module Test.Interpreter.A1.Feather+  ( featherSpec+  ) where++import Control.Lens (makeLenses, (%=), (+=), (-=), (.=))+import Control.Monad.Except (Except, runExcept, throwError)+import Data.Singletons (SingI)+import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, arbitrary, forAll, frequency, listOf, suchThat)+import Test.QuickCheck.Arbitrary.Generic (genericArbitrary)+import Test.QuickCheck.Instances.Natural ()++import Lorentz (View, Void_)+import qualified Lorentz as L+import Lorentz.Test+import Michelson.Interpret (MichelsonFailed(..))+import Michelson.Interpret.Pack (packValue')+import Michelson.Test+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U+import Tezos.Address+import Tezos.Core+import Tezos.Crypto+import Util.Named++data Outcome = Outcome+  { _oCounter :: !Natural+  , _oList :: ![Natural]+  , _oSum :: !Natural+  }++makeLenses ''Outcome++featherSpec :: Spec+featherSpec =+  specWithContractL "contracts/A1/counter.mtz" $ \counter ->+  specWithContractL "contracts/A1/feather.mtz" $ \feather ->+  specWithContractL "contracts/A1/caller_add.mtz" $ \callerAdd ->+  specWithContractL "contracts/A1/caller_append.mtz" $ \callerAppend ->+  specImpl counter feather callerAdd callerAppend++data CounterParameter+  = AntibumpCounter+  | BumpCounter+  | ResetCounter Natural+  | GetCount (View () Natural)+  | HashCount (Void_ () ByteString)+  deriving stock Generic+  deriving anyclass T.IsoValue+type CounterStorage = Natural++type FeatherParameter = ((), Maybe Natural)+type FeatherStorage = (Address, Maybe Address)++type CallerParameter = Either Natural ()+type CallerAddStorage = (Natural, Address)+type CallerAppendStorage = ([Natural], Address)++-- Actions that can be performed by this scenario.+data Action+  = Antibump+  -- ^ Antibump counter+  | Bump+  -- ^ Bump counter+  | Reset !Natural+  -- ^ Reset counter+  | HashCounter+  -- ^ Get counter's hash using void entry point (which implies that+  -- everything else should fail)+  | Add !Natural+  -- ^ Add a constant to caller-add+  | AddRecord+  -- ^ Add counter value to caller-add+  | Append !Natural+  -- ^ Append a constant to caller-append+  | AppendRecord+  -- ^ Append counter value to caller-append+  deriving (Show, Generic)++genAction :: Gen Action+genAction = genericArbitrary++data Fixture = Fixture+  { fActions :: ![Action]+  , fInitialCounter :: !Natural+  , fInitialList :: ![Natural]+  , fInitialSum :: !Natural+  } deriving (Show)++-- We generate 'HashCounter' with smaller probablity, because otherwise+-- tests will often stop quickly (they stop as soon as 'HashCounter'+-- occurs).+genFixture :: Gen Fixture+genFixture = do+  fActions <-+    listOf $ frequency+      [ (26, genAction `suchThat` notHashCounter)+      , (1, pure HashCounter)+      ]+  fInitialCounter <- arbitrary+  fInitialList <- arbitrary+  fInitialSum <- arbitrary+  pure Fixture {..}+  where+    notHashCounter =+      \case+        HashCounter -> False+        _ -> True++data ExpectedFail+  = NegativeCounter+  | HashCounterCalled !ByteString++expectedOutcome :: Fixture -> Either ExpectedFail Outcome+expectedOutcome Fixture {..} =+  runExcept $ execStateT (mapM_ step fActions) start+  where+    start = Outcome+      { _oCounter = fInitialCounter+      , _oList = fInitialList+      , _oSum = fInitialSum+      }+    step :: Action -> StateT Outcome (Except ExpectedFail) ()+    step = \case+      Antibump -> use oCounter >>= \case+        0 -> throwError NegativeCounter+        _ -> oCounter -= 1+      Bump -> oCounter += 1+      Reset x -> oCounter .= x+      HashCounter ->+        throwError .+        HashCounterCalled .+        sha512 .+        packValue' .+        T.toVal =<<+        use oCounter+      Add x -> oSum += x+      AddRecord -> (oSum +=) =<< use oCounter+      Append x -> oList %= (x:)+      AppendRecord -> do+        c <- use oCounter+        oList %= (c:)++specImpl ::+     (U.Contract, L.Contract CounterParameter CounterStorage)+  -> (U.Contract, L.Contract FeatherParameter FeatherStorage)+  -> (U.Contract, L.Contract CallerParameter CallerAddStorage)+  -> (U.Contract, L.Contract CallerParameter CallerAppendStorage)+  -> Spec+specImpl (_, counter) (_, feather) (_, callerAdd) (_, callerAppend) =+  prop "A mix of random actions is handled as expected" $+    forAll genFixture $ \fixture ->+      integrationalTestProperty (scenario fixture)+  where+    scenario :: Fixture -> IntegrationalScenario+    scenario fixture@Fixture {..} = do+      let+        initBalance = unsafeMkMutez 100++      counterContractAddress@(T.ContractAddr counterAddress) <-+        lOriginate counter "counter" fInitialCounter initBalance++      let+        defaultFeatherValue :: FeatherStorage+        defaultFeatherValue =+          (counterAddress, Nothing @Address)++      featherContractAddress@(T.ContractAddr featherAddress) <-+        lOriginate feather "feather" defaultFeatherValue initBalance+      cAddContractAddress <-+        lOriginate callerAdd "caller-add"+        (fInitialSum, featherAddress) initBalance+      cAppendContractAddress <-+        lOriginate callerAppend "caller-append"+        (fInitialList, featherAddress) initBalance++      let+        transfer' ::+          forall t . (T.IsoValue t, SingI (T.ToT t), T.HasNoOp (T.ToT t))+          => T.ContractAddr t -> t -> IntegrationalScenarioM ()+        transfer' addr param =+          lTransfer (#from .! genesisAddress) (#to .! addr)+                    (unsafeMkMutez 0) param++        transferToCounter :: CounterParameter -> IntegrationalScenarioM ()+        transferToCounter = transfer' counterContractAddress++        transferToAdd :: CallerParameter -> IntegrationalScenarioM ()+        transferToAdd = transfer' cAddContractAddress++        transferToAppend :: CallerParameter -> IntegrationalScenarioM ()+        transferToAppend = transfer' cAppendContractAddress++        performAction :: Action -> IntegrationalScenarioM ()+        performAction = \case+          Antibump -> transferToCounter AntibumpCounter+          Bump -> transferToCounter BumpCounter+          Reset x -> transferToCounter $ ResetCounter x+          HashCounter -> transferToCounter $ HashCount (L.mkVoid ())+          Add x -> transferToAdd $ Left x+          AddRecord -> transferToAdd $ Right ()+          Append x -> transferToAppend $ Left x+          AppendRecord -> transferToAppend $ Right ()++      mapM_ performAction fActions++      let+        checkHash :: ByteString -> MichelsonFailed -> Bool+        checkHash expectedHash = (== MichelsonFailedWith (T.toVal expectedHash))+        validator :: IntegrationalValidator+        validator = case expectedOutcome fixture of+          Left NegativeCounter ->+            Left $ expectMichelsonFailed (const True) counterAddress+          Left (HashCounterCalled expectedHash) ->+            Left $ expectMichelsonFailed (checkHash expectedHash) counterAddress+          Right (Outcome {..}) -> Right $ composeValidatorsList+            [ -- Feather must always be called twice and the second+              -- call must set its storage to its initial value.+              lExpectStorageConst featherContractAddress defaultFeatherValue+            , -- Counter, caller-add and caller-append have values+              -- according to 'Outcome'.+              lExpectStorageConst counterContractAddress _oCounter+            , lExpectStorageConst cAddContractAddress (_oSum, featherAddress)+            , lExpectStorageConst cAppendContractAddress (_oList, featherAddress)+            , -- Balances must not change+              expectBalance counterAddress initBalance+            , expectBalance featherAddress initBalance+            , lExpectBalance cAddContractAddress initBalance+            , lExpectBalance cAppendContractAddress initBalance+            ]++      validate validator
− test/Test/Interpreter/Auction.hs 
@@ -1,135 +0,0 @@--- | Module, containing spec to test auction.tz contract.------ This spec is an example of using testing capabilities of morley.-module Test.Interpreter.Auction-  ( auctionSpec-  ) where--import Test.Hspec (Spec, it, parallel, shouldSatisfy)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Property, arbitrary, choose, counterexample, (.&&.), (===))-import Test.QuickCheck.Gen (unGen)-import Test.QuickCheck.Property (expectFailure, forAll, withMaxSuccess)-import Test.QuickCheck.Random (mkQCGen)--import Michelson.Interpret (ContractEnv(..))-import Michelson.Typed (CVal(..), Operation(..), ToT, TransferTokens(..), Val(..))-import Morley.Test (ContractPropValidator, contractProp, midTimestamp, specWithTypedContract)-import Morley.Test.Dummy-import Morley.Test.Util (failedProp)-import Tezos.Address (Address(..))-import Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, unMutez, unsafeMkMutez, unsafeSubMutez)-import Tezos.Crypto (KeyHash)--type Storage = (Timestamp, (Mutez, KeyHash))-type Param = KeyHash---- | Spec to test auction.tz contract.------ This spec serves as an example on how to test contract with both unit tests--- and QuickCheck.-auctionSpec :: Spec-auctionSpec = parallel $ do-  -- Test auction.tz, everything should be fine-  specWithTypedContract "contracts/auction.tz" $ \contract -> do-    it "Bid after end of auction triggers failure" $-      contractProp contract-        (flip shouldSatisfy (isLeft . fst))-        (env { ceAmount = unsafeMkMutez 1200 })-        keyHash2-        (aBitBeforeMidTimestamp, (unsafeMkMutez 1000, keyHash1))--    prop "Random check (sparse distribution)" $ withMaxSuccess 200 $-      qcProp contract arbitrary arbitrary--    prop "Random check (dense end of auction)" $-      qcProp contract denseTime arbitrary--    prop "Random check (dense amount)" $-      qcProp contract arbitrary denseAmount--  -- Test slightly modified version of auction.tz, it must fail.-  -- This block is given purely for demonstration of that tests are smart-  -- enough to filter common mistakes.-  specWithTypedContract "contracts/auction-buggy.tz" $ \contract -> do-    prop "Random check (dense end of auction)" $-      expectFailure $ qcProp contract denseTime arbitrary--    prop "Random check (dense amount)" $-      expectFailure $ qcProp contract arbitrary denseAmount--  where-    qcProp contract eoaGen amountGen =-      forAll ((,) <$> eoaGen <*> ((,) <$> amountGen <*> arbitrary)) $-        \s p ->-          let validate = validateAuction env p s-           in contractProp contract validate env p s--    aBitBeforeMidTimestamp = midTimestamp `timestampPlusSeconds` -1-    -- ^ 1s before NOW--    denseTime = timestampPlusSeconds midTimestamp <$> choose (-4, 4)-    denseAmount = unsafeMkMutez . (midAmount +) . fromInteger <$> choose (-4, 4)--    env = dummyContractEnv-            { ceNow = midTimestamp-            , ceAmount = unsafeMkMutez midAmount-            }-    midAmount = unMutez (maxBound `unsafeSubMutez` minBound) `div` 2--keyHash1 :: KeyHash-keyHash1 = unGen arbitrary (mkQCGen 300406) 0--keyHash2 :: KeyHash-keyHash2 = unGen arbitrary (mkQCGen 142917) 0---- | This validator checks the result of auction.tz execution.------ It checks following properties:------ * Current timestamp is before end of auction--- * Amount of new bid is higher than previous one------ In case of successful execution:------ * End of auction timestamp in updated storage is unchanged--- * Amount in updated storage is equal to @AMOUNT@ of transaction--- * Key hash in updated storage is equal to contract's parameter--- * Script returned exactly one operation, @TransferTokens@, which---   returns money back to the previous bidder-validateAuction-  :: ContractEnv-  -> Param-  -> Storage-  -> ContractPropValidator (ToT Storage) Property-validateAuction env newKeyHash (endOfAuction, (amount, keyHash)) (resE, _)-  | ceNow env > endOfAuction-      = counterexample "Failure didn't trigger on end of auction" $ isLeft resE-  | ceAmount env <= amount-      = counterexample ("Failure didn't trigger on attempt to bid"-                        <> " with amount <= than previous bid") $ isLeft resE-  | Left e <- resE-      = failedProp $ "Unexpected script fail: " <> show e--  | Right (_, (VPair ( VC (CvTimestamp endOfAuction'), _))) <- resE-  , endOfAuction /= endOfAuction'-      = failedProp "End of auction timestamp of contract changed"--  | Right (_, (VPair (_, VPair (VC (CvMutez amount'), _)))) <- resE-  , amount' /= ceAmount env-      = failedProp $ "Storage updated to wrong value: new amount"-                      <> " is not equal to amount of transaction"-  | Right (_, (VPair (_, VPair (_, VC (CvKeyHash keyHash'))))) <- resE-  , keyHash' /= newKeyHash-      = failedProp $ "Storage updated to wrong value: new key hash"-                      <> " is not equal to contract's parameter"--  | Right (ops, _) <- resE-     = let counterE msg =-              counterexample $ "Invalid money back operation (" <> msg <> ")"-        in case ops of-            OpTransferTokens (TransferTokens VUnit retAmount (VContract retAddr)) : [] ->-              counterE "wrong amount" (retAmount === amount)-                .&&.-              counterE "wrong address" (KeyAddress keyHash === retAddr)-            _ -> failedProp $ "Unexpected operation list: " <> show ops
test/Test/Interpreter/CallSelf.hs view
@@ -9,13 +9,12 @@ import Test.QuickCheck (Gen, choose, forAll)  import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..))+import Michelson.Runtime.GState+import Michelson.Test (ContractPropValidator, contractProp, specWithContract)+import Michelson.Test.Dummy+import Michelson.Test.Integrational import Michelson.Typed-import Michelson.Untyped (UntypedContract)-import qualified Michelson.Untyped as Untyped-import Morley.Runtime.GState-import Morley.Test (ContractPropValidator, contractProp, specWithContract)-import Morley.Test.Dummy-import Morley.Test.Integrational+import qualified Michelson.Untyped as U import Tezos.Address (Address) import Tezos.Core (unsafeMkMutez) @@ -54,7 +53,7 @@ type Storage = 'Tc 'CNat  specImpl ::-     (UntypedContract, Contract Parameter Storage)+     (U.Contract, Contract Parameter Storage)   -> Spec specImpl (uSelfCaller, selfCaller) = modifyMaxSuccess (min 10) $ do   it ("With parameter 1 single execution consumes " <>@@ -84,15 +83,15 @@       "it fails due to gas limit if the number is large, otherwise the " <>       "storage is updated to the number of calls" -integrationalScenario :: UntypedContract -> Fixture -> IntegrationalScenario+integrationalScenario :: U.Contract -> Fixture -> IntegrationalScenario integrationalScenario uSelfCaller fixture = do   setMaxSteps (fMaxSteps fixture)-  address <- originate uSelfCaller (Untyped.ValueInt 0) (unsafeMkMutez 1)+  address <- originate uSelfCaller "self-caller" (U.ValueInt 0) (unsafeMkMutez 1)   let     txData :: TxData     txData = TxData       { tdSenderAddress = genesisAddress-      , tdParameter = Untyped.ValueInt (fromIntegral $ fParameter fixture)+      , tdParameter = U.ValueInt (fromIntegral $ fParameter fixture)       , tdAmount = minBound       }   transfer txData address@@ -102,6 +101,6 @@     validator address       | fExpectSuccess fixture =         let expectedStorage =-              Untyped.ValueInt (fromIntegral $ fParameter fixture)+              U.ValueInt (fromIntegral $ fParameter fixture)          in Right $ expectStorageUpdateConst address expectedStorage       | otherwise = Left expectGasExhaustion
test/Test/Interpreter/Compare.hs view
@@ -9,24 +9,24 @@ import Test.QuickCheck.Property (withMaxSuccess)  import Michelson.Interpret (InterpreterState, MichelsonFailed)-import Michelson.Typed (ToT, Val(..), fromVal)-import Morley.Test (contractProp, specWithTypedContract)-import Morley.Test.Dummy-import Morley.Test.Util (failedProp)-import Morley.Types (MorleyLogs)+import Michelson.Test (contractProp, specWithTypedContract)+import Michelson.Test.Dummy+import Michelson.Test.Util (failedProp)+import Michelson.Typed (ToT, fromVal)+import qualified Michelson.Typed as T import Tezos.Core (Mutez, unsafeMkMutez)  type Param = (Mutez, Mutez)-type ContractStorage instr = Val instr (ToT [Bool])-type ContractResult x instr-   = ( Either MichelsonFailed ([x], ContractStorage instr)-     , InterpreterState MorleyLogs)+type ContractStorage = T.Value (ToT [Bool])+type ContractResult x+   = ( Either MichelsonFailed ([x], ContractStorage)+     , InterpreterState)  -- | Spec to test compare.tz contract. compareSpec :: Spec compareSpec = parallel $ do -  specWithTypedContract "contracts/compare.tz" $ \contract -> do+  specWithTypedContract "contracts/tezos_examples/compare.tz" $ \contract -> do     let       contractProp' inputParam =         contractProp contract (validate (mkExpected inputParam))@@ -45,7 +45,7 @@      validate       :: [Bool]-      -> ContractResult x instr+      -> ContractResult x       -> Property     validate e (Right ([], fromVal -> l), _) = l === e     validate _ (Left _, _) = failedProp "Unexpected fail of sctipt."
test/Test/Interpreter/Conditionals.hs view
@@ -10,39 +10,40 @@ import Test.QuickCheck.Property (withMaxSuccess)  import Michelson.Interpret (InterpreterState, MichelsonFailed)-import Michelson.Typed (CVal(..), ToT, Val(..))-import Morley.Test (contractProp, specWithTypedContract)-import Morley.Test.Dummy (dummyContractEnv)-import Morley.Test.Util (failedProp, qcIsLeft, qcIsRight)-import Morley.Types (MorleyLogs)+import Michelson.Test (contractProp, specWithTypedContract)+import Michelson.Test.Dummy (dummyContractEnv)+import Michelson.Test.Util (failedProp, qcIsLeft, qcIsRight)+import Michelson.Typed (CValue(..), ToT)+import Michelson.Text+import qualified Michelson.Typed as T -type Param = Either Text (Maybe Integer)-type ContractStorage instr = Val instr (ToT Text)-type ContractResult x instr-   = ( Either MichelsonFailed ([x], ContractStorage instr)-     , InterpreterState MorleyLogs)+type Param = Either MText (Maybe Integer)+type ContractStorage = T.Value (ToT MText)+type ContractResult x+   = ( Either MichelsonFailed ([x], ContractStorage)+     , InterpreterState)  -- | Spec to test conditionals.tz contract. conditionalsSpec :: Spec conditionalsSpec = parallel $ do -  specWithTypedContract "contracts/conditionals.tz" $ \contract -> do+  specWithTypedContract "contracts/tezos_examples/conditionals.tz" $ \contract -> do     let       contractProp' inputParam =         contractProp contract (validate inputParam) dummyContractEnv inputParam-        ("storage" :: Text)+        [mt|storage|]      it "success 1 test" $-      contractProp' $ Left "abc"+      contractProp' $ Left [mt|abc|]      prop "Random check" $ withMaxSuccess 200 contractProp'   where     validate       :: Show x       => Param-      -> ContractResult x instr+      -> ContractResult x       -> Property-    validate (Left a) (Right ([], VC (CvString b)), _) = a === b+    validate (Left a) (Right ([], T.VC (CvString b)), _) = a === b     validate (Right Nothing) r = qcIsLeft $ fst r     validate (Right (Just a)) r       | a < 0 = qcIsLeft $ fst r
+ test/Test/Interpreter/ContractOp.hs view
@@ -0,0 +1,55 @@+-- | Module, containing spec to test contract_op.tz contract.+module Test.Interpreter.ContractOp+  ( contractOpSpec+  ) where++import qualified Data.Map as M+import Test.Hspec (Spec, describe, it, parallel)+import Test.QuickCheck (Property, (===))++import Michelson.Interpret (ContractEnv(..), ContractReturn)+import Michelson.Test (contractProp, dummyContractEnv, failedProp, specWithTypedContract)+import Michelson.Typed (Contract, ToT, fromVal)+import Michelson.Untyped (CT(..), T(..), Type(..), noAnn)+import Tezos.Address (Address, unsafeParseAddress)++-- | Spec to test compare.tz contract.+contractOpSpec :: Spec+contractOpSpec = parallel $ describe "CONTRACT instruction tests" $ do+  specWithTypedContract "contracts/contract_op.tz" $ \contract -> do+    it "contract not found" $+      contractProp' False [] contract++    it "contract found, expected parameter is int :q, actual is int :q" $+      contractProp' True [(addr, intQ)] contract+    it "contract found, expected parameter int :q, actual int" $+      contractProp' True [(addr, int)] contract++    it "contract found, but expected parameter is int :p, actual is int :q" $+      contractProp' False [(addr, intP)] contract+    it "contract found, but expected parameter is int :p, actual is string" $+      contractProp' False [(addr, string)] contract+  where+    intQ = Type (Tc CInt) "q"+    int = Type (Tc CInt) noAnn+    intP = Type (Tc CInt) "p"+    string = Type (Tc CString) noAnn++    addr = unsafeParseAddress "KT1WsLzQ61xtMNJHfwgCHh2RnALGgFAzeSx9"++    validate+      :: Bool+      -> ContractReturn (ToT Bool)+      -> Property+    validate ex (Right ([], fromVal -> l), _) = l === ex+    validate _ (Left _, _) = failedProp "Unexpected fail in interepreter"+    validate _ _ = failedProp "Unexpected result of script execution"++    contractProp' :: Bool -> [(Address, Type)] -> Contract (ToT Address) (ToT Bool) -> Property+    contractProp' res ctrs contract =+      contractProp+        contract+        (validate res)+        dummyContractEnv {ceContracts = M.fromList ctrs}+        addr+        False
test/Test/Interpreter/EnvironmentSpec.hs view
@@ -10,12 +10,12 @@ import Test.QuickCheck.Instances.Text ()  import Michelson.Interpret (RemainingSteps(..))+import Michelson.Runtime.GState+import Michelson.Test (specWithContract)+import Michelson.Test.Integrational import Michelson.Typed-import Michelson.Untyped (UntypedContract, UntypedValue)-import qualified Michelson.Untyped as Untyped-import Morley.Runtime.GState-import Morley.Test (specWithContract)-import Morley.Test.Integrational+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U import Tezos.Address import Tezos.Core @@ -49,15 +49,15 @@     , fAmount fixture < unsafeMkMutez 15     ] -shouldReturn :: Fixture -> UntypedValue+shouldReturn :: Fixture -> U.Value shouldReturn fixture-  | fMaxSteps fixture - consumedGas > 1000 = Untyped.ValueTrue-  | otherwise = Untyped.ValueFalse+  | fMaxSteps fixture - consumedGas > 1000 = U.ValueTrue+  | otherwise = U.ValueFalse   where     consumedGas = 19  specImpl ::-    (UntypedContract, Contract ('Tc 'CAddress) ('Tc 'CBool))+    (U.Contract, T.Contract ('Tc 'CAddress) ('Tc 'CBool))   -> Spec specImpl (uEnvironment, _environment)  = do   let scenario = integrationalScenario uEnvironment@@ -70,7 +70,7 @@       "beginning of this contract and returns whether remaining gas is " <>       "greater than 1000" -integrationalScenario :: UntypedContract -> Fixture -> IntegrationalScenario+integrationalScenario :: U.Contract -> Fixture -> IntegrationalScenario integrationalScenario contract fixture = do   -- First of all let's set desired gas limit and NOW   setNow $ fNow fixture@@ -78,7 +78,7 @@    -- Then let's originated the 'environment.tz' contract   environmentAddress <--    originate contract Untyped.ValueFalse (fBalance fixture)+    originate contract "environment" U.ValueFalse (fBalance fixture)    -- And transfer tokens to it   let@@ -87,7 +87,7 @@       | otherwise = genesisAddress     txData = TxData       { tdSenderAddress = genesisAddress-      , tdParameter = Untyped.ValueString (formatAddress param)+      , tdParameter = U.ValueString (mformatAddress param)       , tdAmount = fAmount fixture       }   transfer txData environmentAddress@@ -98,7 +98,7 @@   let     validator       | shouldExpectFailed fixture =-        Left $ expectMichelsonFailed environmentAddress+        Left $ expectMichelsonFailed (const True) environmentAddress       | otherwise =         Right $ expectStorageConst environmentAddress $ shouldReturn fixture   validate validator
test/Test/Interpreter/StringCaller.hs view
@@ -10,25 +10,26 @@ import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck.Instances.Text () +import Michelson.Runtime.GState+import Michelson.Test (specWithContract)+import Michelson.Test.Integrational import Michelson.Typed-import Michelson.Untyped (UntypedContract)-import qualified Michelson.Untyped as Untyped-import Morley.Runtime.GState-import Morley.Test (specWithContract)-import Morley.Test.Integrational+import Michelson.Text+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U import Tezos.Address import Tezos.Core  stringCallerSpec :: Spec stringCallerSpec =   parallel $-  specWithContract "contracts/stringCaller.tz" $ \stringCaller ->-  specWithContract "contracts/failOrStoreAndTransfer.tz" $ \failOrStoreAndTransfer ->+  specWithContract "contracts/string_caller.tz" $ \stringCaller ->+  specWithContract "contracts/fail_or_store_and_transfer.tz" $ \failOrStoreAndTransfer ->   specImpl stringCaller failOrStoreAndTransfer  specImpl ::-     (UntypedContract, Contract ('Tc 'CString) ('Tc 'CAddress))-  -> (UntypedContract, Contract ('Tc 'CString) ('Tc 'CString))+     (U.Contract, T.Contract ('Tc 'CString) ('Tc 'CAddress))+  -> (U.Contract, T.Contract ('Tc 'CString) ('Tc 'CString))   -> Spec specImpl (uStringCaller, _stringCaller) (uFailOrStore, _failOrStoreAndTransfer) = do   let scenario = integrationalScenario uStringCaller uFailOrStore@@ -45,9 +46,9 @@     prop (prefix <> "an arbitrary value" <> suffix) $       \str -> integrationalTestProperty (scenario str)   where-    constStr = "caller"+    constStr = [mt|caller|] -integrationalScenario :: UntypedContract -> UntypedContract -> Text -> IntegrationalScenario+integrationalScenario :: U.Contract -> U.Contract -> MText -> IntegrationalScenario integrationalScenario stringCaller failOrStoreAndTransfer str = do   let     initFailOrStoreBalance = unsafeMkMutez 900@@ -55,10 +56,10 @@    -- Originate both contracts   failOrStoreAndTransferAddress <--    originate failOrStoreAndTransfer (Untyped.ValueString "hello") initFailOrStoreBalance+    originate failOrStoreAndTransfer "failOrStoreAndTransfer" (U.ValueString [mt|hello|]) initFailOrStoreBalance   stringCallerAddress <--    originate stringCaller-    (Untyped.ValueString $ formatAddress failOrStoreAndTransferAddress)+    originate stringCaller "stringCaller"+    (U.ValueString $ mformatAddress failOrStoreAndTransferAddress)     initStringCallerBalance    -- NOW = 500, so stringCaller shouldn't fail@@ -67,7 +68,7 @@   -- Transfer 100 tokens to stringCaller, it should transfer 300 tokens   -- to failOrStoreAndTransfer   let-    newValue = Untyped.ValueString str+    newValue = untypeValue $ toVal str     txData = TxData       { tdSenderAddress = genesisAddress       , tdParameter = newValue@@ -100,13 +101,13 @@    -- This time execution should fail, because failOrStoreAndTransfer should fail   -- because its balance is greater than 1000.-  void $ validate (Left $ expectMichelsonFailed failOrStoreAndTransferAddress)+  void $ validate (Left $ expectMichelsonFailed (const True) failOrStoreAndTransferAddress)    -- We can also send tokens from failOrStoreAndTransfer to tz1 address directly   let     txDataToConst = TxData       { tdSenderAddress = failOrStoreAndTransferAddress-      , tdParameter = Untyped.ValueUnit+      , tdParameter = U.ValueUnit       , tdAmount = unsafeMkMutez 200       }   transfer txDataToConst constAddr@@ -136,7 +137,7 @@   -- Now let's set NOW to 600 and expect stringCaller to fail   setNow (timestampFromSeconds @Int 600)   transferToStringCaller-  validate (Left $ expectMichelsonFailed stringCallerAddress)+  validate (Left $ expectMichelsonFailed (const True) stringCallerAddress)  -- Address hardcoded in 'failOrStoreAndTransfer.tz'. constAddr :: Address
+ test/Test/Lorentz/Discovery.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Tests for contracts discovery.++module Test.Lorentz.Discovery+  ( test_Export_list_parse+  , test_Haskell_modules_detection+  ) where++import Test.HUnit (assertFailure, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Text.InterpolatedString.QM (qnb)+import Text.Megaparsec (errorBundlePretty, runParser)++import Lorentz.Discover++test_Export_list_parse :: [TestTree]+test_Export_list_parse =+  [ testCase "Empty" $+    [qnb| module MyModule () where+        |] `shouldParseTo` []++  , testCase "Empty spaced" $+    [qnb| module MyModule (  ) where+        |] `shouldParseTo` []++  , testCase "Contracts extracted fine" $+      [qnb| module MyModule+              ( contract_Some+              , contract_one_another+              ) where+      |]+      `shouldParseTo`+       [ ExportedContractInfo+         { eciModuleName = "MyModule"+         , eciContractDecl = ExportedContractDecl+           { ecdName = "Some"+           , ecdVar = "contract_Some"+           }+         }+       , ExportedContractInfo+         { eciModuleName = "MyModule"+         , eciContractDecl = ExportedContractDecl+           { ecdName = "one another"+           , ecdVar = "contract_one_another"+           }+         }+       ]++  , testCase "Bad export entries are ignored" $+      [qnb| module MyModule+              ( not_a_contract+              , SomeType (..)+              , SomethingElse ( Ctor, getter )+              , SomethingElse2+                 ( Ctor2  -- constructor+                 , getter2  {- getter -})+              , contract+              , contract_Some+              ) where+      |]+      `shouldParseTo`+       [ ExportedContractInfo+         { eciModuleName = "MyModule"+         , eciContractDecl = ExportedContractDecl+           { ecdName = "Some"+           , ecdVar = "contract_Some"+           }+         }+       ]++  , testCase "Annotations and comments" $+      [qnb| {-# PRAGMA #-}+            -- Comment+            -- | Description+            {- Another comment+            -}+            module MyModule+              ( contract_Some  -- Should be exported++                -- ** And these should not+              , contract+              ) where+      |]+      `shouldParseTo`+       [ ExportedContractInfo+         { eciModuleName = "MyModule"+         , eciContractDecl = ExportedContractDecl+           { ecdName = "Some"+           , ecdVar = "contract_Some"+           }+         }+       ]++  ]+  where+    shouldParseTo code exports =+      case runParser haskellExportsParser "" code of+        Left err -> assertFailure $ errorBundlePretty err+        Right x -> x @?= exports+++test_Haskell_modules_detection :: [TestTree]+test_Haskell_modules_detection =+  [ testCase "Simple module is picked" $+      isHaskellModule "Module.hs" @?= True+  , testCase "Not .hs module is ignored" $+      isHaskellModule "Module" @?= False+  , testCase "Modules with non letters are picked" $+      isHaskellModule "Module_12.hs" @?= True+  , testCase "Emacs' temporal files should be ignored" $+      isHaskellModule ".#Module.hs" @?= False+  ]
+ test/Test/Lorentz/Macro.hs view
@@ -0,0 +1,32 @@+-- | Tests for Lorentz macros.+--+-- They test logic of macros and type-level logic.  Also they serve as+-- examples of using complex macros (e. g. parameterized with+-- type-level numbers)++module Test.Lorentz.Macro+  ( unit_dropX+  , unit_elevateX+  ) where++import Prelude hiding (drop, swap)+import Test.HUnit (Assertion, (@?=))++import Lorentz++unit_dropX :: Assertion+unit_dropX = do+  dropX @0 @?= drop+  dropX @2 @?= dropX2+  where+    dropX2 :: [Integer, Bool, (), Bool] :-> [Integer, Bool, Bool]+    dropX2 = dip $ dip drop++unit_elevateX :: Assertion+unit_elevateX = do+  elevateX @0 @?= (dup # dip drop) -- current implementation is not efficient+  elevateX @1 @?= (dip dup # swap # dip (dip drop))+  elevateX @3 @?= elevateX3+  where+    elevateX3 :: [Bool, Integer, Natural, (), Bool] :-> [(), Bool, Integer, Natural, Bool]+    elevateX3 = duupX @4 # dropX @4
test/Test/Macro.hs view
@@ -1,88 +1,103 @@ module Test.Macro-  ( spec+  ( unit_PAPAIR+  , unit_UNPAIR+  , unit_CADR+  , unit_SET_CADR+  , unit_MAP_CADR+  , unit_mapLeaves+  , unit_expand+  , unit_expandValue   ) where -import Michelson.Untyped (UntypedValue)-import Morley.Macro-import Morley.Types-import Test.Hspec (Expectation, Spec, describe, it, shouldBe)+import Test.Hspec (Expectation, shouldBe) -spec :: Spec-spec = describe "Macros tests" $ do-  it "expand test" expandTest-  it "papair test" expandPapairTest-  it "unpapair test" expandUnpapairTest-  it "expandCadr test" expandCadrTest-  it "expandSetCadr test" expandSetCadrTest-  it "expandMapCadr test" expandMapCadrTest-  it "mapLeaves test" mapLeavesTest-  it "expandValue test" expandValueTest+import Michelson.ErrorPos (InstrCallStack(..), LetName(..), SrcPos, srcPos)+import Michelson.Macro+import Michelson.Untyped (ExpandedOp(..), InstrAbstract(..), Value, Value'(..), ann, noAnn) -expandPapairTest :: Expectation-expandPapairTest = do-  expandPapair pair n n `shouldBe` [Prim $ PAIR n n n n]-  expandPapair (P leaf pair) n n `shouldBe`-    [Prim $ DIP [Mac $ PAPAIR pair n n], Prim $ PAIR n n n n]-  expandList [Mac $ PAPAIR (P pair leaf) n n] `shouldBe`-    [SeqEx [PrimEx $ PAIR n n n n, PrimEx $ PAIR n n n n]]-  expandList [Mac $ PAPAIR (P pair pair) n n] `shouldBe`-    [SeqEx [PrimEx (PAIR n n n n),-             PrimEx (DIP [PrimEx (PAIR n n n n)]),-             PrimEx (PAIR n n n n)]]+defPos :: SrcPos+defPos = srcPos 1 1++defICS :: InstrCallStack+defICS = InstrCallStack [] defPos++-- TODO: it seems to me that these duplicated "where" blocks should be+-- replaced with some reasonable mini-EDSL - at least to facilitate tests+-- writing - and that would be a rather big refactoring.+-- Dunno how to deal with this duplication otherwise.+{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++unit_PAPAIR :: Expectation+unit_PAPAIR = do+  expandPapair defICS pair n n `shouldBe` [primEx $ PAIR n n n n]+  expandPapair defICS (P leaf pair) n n `shouldBe`+    [primEx $ DIP (expandMacro defICS $ PAPAIR pair n n), primEx $ PAIR n n n n]+  expandList [mac $ PAPAIR (P pair leaf) n n] `shouldBe`+    [WithSrcEx defICS $ SeqEx [primEx $ PAIR n n n n, primEx $ PAIR n n n n]]+  expandList [mac $ PAPAIR (P pair pair) n n] `shouldBe`+    [WithSrcEx defICS $ SeqEx [primEx (PAIR n n n n),+             primEx (DIP [primEx (PAIR n n n n)]),+             primEx (PAIR n n n n)]]   where+    mac = flip Mac defPos+    primEx = PrimEx     n = noAnn     leaf = F (n, n)     pair = P leaf leaf -expandUnpapairTest :: Expectation-expandUnpapairTest = do-  expandUnpapair pair `shouldBe`-    [Prim $ DUP n, Prim $ CAR n n, Prim $ DIP [Prim $ CDR n n]]-  expandList [Mac $ UNPAIR $ P leaf pair] `shouldBe`-    [SeqEx [PrimEx (DUP n),-             PrimEx (CAR n n),-             PrimEx (DIP [PrimEx (CDR n n),-                           SeqEx [PrimEx (DUP n),-                                   PrimEx (CAR n n),-                                   PrimEx (DIP [PrimEx (CDR n n)])]])]]-  expandList [Mac $ UNPAIR $ P pair leaf] `shouldBe`-    [SeqEx [PrimEx (DUP n),-             PrimEx (DIP [PrimEx (CDR n n)]),-             PrimEx (CAR n n),-             SeqEx [PrimEx (DUP n),-                     PrimEx (CAR n n),-                     PrimEx (DIP [PrimEx (CDR n n)])]]]-  expandList [Mac $ UNPAIR $ P pair pair] `shouldBe`-     [SeqEx $ one expandP ++ [PrimEx $ DIP $ one expandP] ++ one expandP]+unit_UNPAIR :: Expectation+unit_UNPAIR = do+  expandUnpapair defICS pair `shouldBe`+    [primEx $ DUP n, primEx $ CAR n n, primEx $ DIP [primEx $ CDR n n]]+  expandList [mac $ UNPAIR $ P leaf pair] `shouldBe`+    [WithSrcEx defICS $ SeqEx [primEx (DUP n),+             primEx (CAR n n),+             primEx (DIP [primEx (CDR n n),+                          primEx (DUP n),+                          primEx (CAR n n),+                          primEx (DIP [primEx (CDR n n)])])]]+  expandList [mac $ UNPAIR $ P pair leaf] `shouldBe`+    [WithSrcEx defICS $ SeqEx [primEx (DUP n),+            primEx (DIP [primEx (CDR n n)]),+            primEx (CAR n n),+            primEx (DUP n),+            primEx (CAR n n),+            primEx (DIP [primEx (CDR n n)])]]+  expandList [mac $ UNPAIR $ P pair pair] `shouldBe`+     [WithSrcEx defICS $ SeqEx $ expandP ++ [primEx $ DIP expandP] ++ expandP]   where-    expandP = SeqEx $ PrimEx <$> [DUP n, CAR n n, DIP [PrimEx $ CDR n n]]+    mac = flip Mac defPos+    primEx = PrimEx+    expandP = primEx <$> [DUP n, CAR n n, DIP [primEx $ CDR n n]]     n = noAnn     leaf = F (n, n)     pair = P leaf leaf -expandCadrTest :: Expectation-expandCadrTest = do-  expandCadr ([A]) v f `shouldBe` [Prim $ CAR v f]-  expandCadr ([D]) v f `shouldBe` [Prim $ CDR v f]-  expandCadr (A:xs) v f `shouldBe` [Prim $ CAR n n, Mac $ CADR xs v f]-  expandCadr (D:xs) v f `shouldBe` [Prim $ CDR n n, Mac $ CADR xs v f]+unit_CADR :: Expectation+unit_CADR = do+  expandCadr defICS ([A]) v f `shouldBe` [primEx $ CAR v f]+  expandCadr defICS ([D]) v f `shouldBe` [primEx $ CDR v f]+  expandCadr defICS (A:xs) v f `shouldBe` primEx (CAR n n) : expandMacro defICS (CADR xs v f)+  expandCadr defICS (D:xs) v f `shouldBe` primEx (CDR n n) : expandMacro defICS (CADR xs v f)   where+    primEx = PrimEx     v = ann "var"     f = ann "field"     n = noAnn     xs = [A, D] -expandSetCadrTest :: Expectation-expandSetCadrTest = do-  expandSetCadr [A] v f `shouldBe` Prim <$> [ DUP noAnn, CAR noAnn f, DROP+unit_SET_CADR :: Expectation+unit_SET_CADR = do+  expandSetCadr defICS [A] v f `shouldBe` primEx <$> [ DUP noAnn, CAR noAnn f, DROP                                             , CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]-  expandSetCadr [D] v f `shouldBe` Prim <$> [ DUP noAnn, CDR noAnn f, DROP+  expandSetCadr defICS [D] v f `shouldBe` primEx <$> [ DUP noAnn, CDR noAnn f, DROP                                             , CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f]-  expandSetCadr (A:xs) v f `shouldBe`-    Prim <$> [DUP noAnn, DIP [Prim carN, Mac $ SET_CADR xs noAnn f], cdrN, SWAP, pairN]-  expandSetCadr (D:xs) v f `shouldBe`-    Prim <$> [DUP noAnn, DIP [Prim cdrN, Mac $ SET_CADR xs noAnn f], carN, pairN]+  expandSetCadr defICS (A:xs) v f `shouldBe`+    primEx <$> [DUP noAnn, DIP (primEx carN : expandMacro defICS (SET_CADR xs noAnn f)), cdrN, SWAP, pairN]+  expandSetCadr defICS (D:xs) v f `shouldBe`+    primEx <$> [DUP noAnn, DIP (primEx cdrN : expandMacro defICS (SET_CADR xs noAnn f)), carN, pairN]   where+    primEx = PrimEx     v = ann "var"     f = ann "field"     xs = [A, D]@@ -90,28 +105,30 @@     cdrN = CDR noAnn noAnn     pairN = PAIR noAnn v noAnn noAnn -expandMapCadrTest :: Expectation-expandMapCadrTest = do-  expandMapCadr [A] v f ops `shouldBe`-    Prim <$> [DUP noAnn, cdrN, DIP [Prim $ CAR noAnn f, Seq ops], SWAP, pairN]-  expandMapCadr [D] v f ops `shouldBe`-    concat [Prim <$> [DUP noAnn, CDR noAnn f], [Seq ops], Prim <$> [SWAP, carN, pairN]]-  expandMapCadr (A:xs) v f ops `shouldBe`-    Prim <$> [DUP noAnn, DIP [Prim $ carN, Mac $ MAP_CADR xs noAnn f ops], cdrN, SWAP, pairN]-  expandMapCadr (D:xs) v f ops `shouldBe`-    Prim <$> [DUP noAnn, DIP [Prim $ cdrN, Mac $ MAP_CADR xs noAnn f ops], carN, pairN]+unit_MAP_CADR :: Expectation+unit_MAP_CADR = do+  expandMapCadr defICS [A] v f ops `shouldBe`+    primEx <$> [DUP noAnn, cdrN, DIP [primEx $ CAR noAnn f, SeqEx ops'], SWAP, pairN]+  expandMapCadr defICS [D] v f ops `shouldBe`+    concat [primEx <$> [DUP noAnn, CDR noAnn f], [SeqEx ops'], primEx <$> [SWAP, carN, pairN]]+  expandMapCadr defICS (A:xs) v f ops `shouldBe`+    primEx <$> [DUP noAnn, DIP (primEx carN : expandMacro defICS (MAP_CADR xs noAnn f ops)), cdrN, SWAP, pairN]+  expandMapCadr defICS (D:xs) v f ops `shouldBe`+    primEx <$> [DUP noAnn, DIP (primEx cdrN : expandMacro defICS (MAP_CADR xs noAnn f ops)), carN, pairN]   where+    primEx = PrimEx     v = ann "var"     f = ann "field"     n = noAnn     xs = [A, D]-    ops = [Prim $ DUP n]+    ops = [Prim (DUP n) defPos]+    ops' = [WithSrcEx defICS $ PrimEx (DUP n)]     carN = CAR noAnn noAnn     cdrN = CDR noAnn noAnn     pairN = PAIR noAnn v noAnn noAnn -mapLeavesTest :: Expectation-mapLeavesTest = do+unit_mapLeaves :: Expectation+unit_mapLeaves = do   mapLeaves [(v, f), (v, f)] pair `shouldBe` P (F (v, f)) (F (v, f))   mapLeaves annotations (P pair (F (n, n))) `shouldBe`     P (P (leaf "var1" "field1") (leaf "var2" "field2")) (leaf "var3" "field3")@@ -125,41 +142,49 @@     leaf v' f' = F (ann v', ann f')     pair = P (F (n, n)) (F (n, n)) -expandTest :: Expectation-expandTest = do-  expand diip `shouldBe` expandedDiip-  expand (Prim $ IF [diip] [diip]) `shouldBe` (PrimEx $ IF [expandedDiip] [expandedDiip])-  expand (Seq [diip, diip]) `shouldBe` (SeqEx $ [expandedDiip, expandedDiip])+unit_expand :: Expectation+unit_expand = do+  expand [LetName "a"] diip `shouldBe` expandedDiip+  expand [LetName "a"] (prim $ IF [diip] [diip]) `shouldBe` (primEx $ IF [expandedDiip] [expandedDiip])+  expand [LetName "a"] (Seq [diip, diip] defPos) `shouldBe` (WithSrcEx aIcs $ SeqEx $ [expandedDiip, expandedDiip])   where+    aIcs = InstrCallStack [LetName "a"] defPos+    prim = flip Prim defPos+    primEx = WithSrcEx aIcs . PrimEx+    primEx' = PrimEx+    mac = flip Mac defPos     diip :: ParsedOp-    diip = Mac (DIIP 2 [Prim SWAP])+    diip = mac (DIIP 2 [prim SWAP])     expandedDiip :: ExpandedOp-    expandedDiip = SeqEx [PrimEx (DIP [SeqEx [PrimEx (DIP [PrimEx SWAP])]])]+    expandedDiip = WithSrcEx aIcs $ SeqEx [primEx' (DIP [primEx' (DIP [primEx SWAP])])] -expandValueTest :: Expectation-expandValueTest = do+unit_expandValue :: Expectation+unit_expandValue = do   expandValue parsedPair `shouldBe` expandedPair   expandValue parsedPapair `shouldBe` expandedPapair   expandValue parsedLambdaWithMac `shouldBe` expandedLambdaWithMac   where-    parsedPair :: Value ParsedOp+    mac = flip Mac defPos+    primEx = PrimEx++    parsedPair :: Value' ParsedOp     parsedPair = ValuePair (ValueInt 5) (ValueInt 5) -    expandedPair :: UntypedValue+    expandedPair :: Value     expandedPair = ValuePair (ValueInt 5) (ValueInt 5) -    parsedPapair :: Value ParsedOp+    parsedPapair :: Value' ParsedOp     parsedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) -    expandedPapair :: UntypedValue+    expandedPapair :: Value     expandedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) -    parsedLambdaWithMac :: Value ParsedOp+    parsedLambdaWithMac :: Value' ParsedOp     parsedLambdaWithMac = ValueLambda $-      one (Mac (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn))+      one (mac (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)) -    expandedLambdaWithMac :: UntypedValue-    expandedLambdaWithMac = ValueLambda . one $ SeqEx-      [ PrimEx $ DIP [PrimEx $ PAIR noAnn noAnn noAnn noAnn]-      , PrimEx $ PAIR noAnn noAnn noAnn noAnn+    expandedLambdaWithMac :: Value+    expandedLambdaWithMac = ValueLambda . one $ WithSrcEx defICS $ SeqEx+      [ primEx $ DIP [primEx $ PAIR noAnn noAnn noAnn noAnn]+      , primEx $ PAIR noAnn noAnn noAnn noAnn       ]
+ test/Test/Michelson/Runtime.hs view
@@ -0,0 +1,151 @@+-- | Tests for Michelson.Runtime.++module Test.Michelson.Runtime+  ( test_interpreterPure+  ) where++import Control.Lens (at)+import Fmt (pretty)+import Test.Hspec.Expectations (Expectation, expectationFailure, shouldSatisfy)+import Test.HUnit (Assertion, assertFailure, (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Michelson.ErrorPos (InstrCallStack(..), Pos(..), SrcPos(..))+import Michelson.Interpret (ContractEnv(..), InterpretUntypedResult(..), interpretUntyped)+import Michelson.Runtime+import Michelson.Runtime.GState (GState(..), initGState)+import Michelson.Test.Dummy (dummyContractEnv, dummyMaxSteps, dummyNow, dummyOrigination)+import Michelson.Typed (untypeValue)+import Michelson.Text (mt)+import Michelson.Untyped+import Tezos.Address (Address(..))+import Tezos.Core (unsafeMkMutez)++test_interpreterPure :: IO [TestTree]+test_interpreterPure = do+  illTypedContract <-+    prepareContract (Just "contracts/ill-typed/sum_strings.tz")++  pure+    [ testGroup "Updates storage value of executed contract" $+      [ testCase "contract1" $ updatesStorageValue contractAux1+      , testCase "contract2" $ updatesStorageValue contractAux2+      ]+    , testCase "Fails to originate an already originated contract" failsToOriginateTwice+    , testCase "Fails to originate an ill-typed contract"+        (failsToOriginateIllTyped (ValueString [mt||]) illTypedContract)+    ]++----------------------------------------------------------------------------+-- Test code+----------------------------------------------------------------------------++-- | Data type, that containts contract and its auxiliary data.+--+-- This type is mostly used for testing purposes.+data ContractAux = ContractAux+  { caContract :: !Contract+  , caEnv :: !ContractEnv+  , caStorage :: !Value+  , caParameter :: !Value+  }++updatesStorageValue :: ContractAux -> Assertion+updatesStorageValue ca = either (assertFailure . pretty) handleResult $ do+  let+    contract = caContract ca+    ce = caEnv ca+    origination = (dummyOrigination (caStorage ca) contract)+      { ooBalance = ceBalance ce+      }+    addr = mkContractAddress origination+    txData = TxData+      { tdSenderAddress = ceSender ce+      , tdParameter = caParameter ca+      , tdAmount = unsafeMkMutez 100+      }+    interpreterOps =+      [ OriginateOp origination+      , TransferOp addr txData+      ]+  (addr,) <$> interpreterPure dummyNow dummyMaxSteps initGState interpreterOps+  where+    toNewStorage :: InterpretUntypedResult -> Value+    toNewStorage InterpretUntypedResult {..} = untypeValue iurNewStorage++    handleResult :: (Address, InterpreterRes) -> Assertion+    handleResult (addr, ir) = do+      expectedValue <-+        either (assertFailure . pretty) (pure . toNewStorage) $+        interpretUntyped+                  (caContract ca) (caParameter ca) (caStorage ca) (caEnv ca)+      case gsAddresses (_irGState ir) ^. at addr of+        Nothing -> expectationFailure $ "Address not found: " <> pretty addr+        Just (ASContract cs) -> csStorage cs @?= expectedValue+        Just _ -> expectationFailure $ "Address has unexpected state " <> pretty addr++failsToOriginateTwice :: Expectation+failsToOriginateTwice =+  simpleTest ops isAlreadyOriginated+  where+    contract = caContract contractAux1+    origination = dummyOrigination (caStorage contractAux1) contract+    ops = [OriginateOp origination, OriginateOp origination]+    isAlreadyOriginated (Left (IEAlreadyOriginated {})) = True+    isAlreadyOriginated _ = False++failsToOriginateIllTyped :: Value -> Contract -> Expectation+failsToOriginateIllTyped initialStorage illTypedContract =+  simpleTest ops isIllTypedContract+  where+    origination = dummyOrigination initialStorage illTypedContract+    ops = [OriginateOp origination]+    isIllTypedContract (Left (IEIllTypedContract {})) = True+    isIllTypedContract _ = False++simpleTest ::+     [InterpreterOp]+  -> (Either InterpreterError InterpreterRes -> Bool)+  -> Expectation+simpleTest ops predicate =+  interpreterPure dummyNow dummyMaxSteps initGState ops `shouldSatisfy`+  predicate++----------------------------------------------------------------------------+-- Data+----------------------------------------------------------------------------++ics :: Word -> InstrCallStack+ics x = InstrCallStack [] (SrcPos (Pos x) (Pos 0))++contractAux1 :: ContractAux+contractAux1 = ContractAux+  { caContract = contract+  , caEnv = dummyContractEnv+  , caStorage = ValueTrue+  , caParameter = ValueString [mt|aaa|]+  }+  where+    contract :: Contract+    contract = Contract+      { para = Type tstring noAnn+      , stor = Type tbool noAnn+      , code =+        [ WithSrcEx (ics 0) $ PrimEx (CDR noAnn noAnn)+        , WithSrcEx (ics 1) $ PrimEx (NIL noAnn noAnn $ Type TOperation noAnn)+        , WithSrcEx (ics 2) $ PrimEx (PAIR noAnn noAnn noAnn noAnn)+        ]+      }++contractAux2 :: ContractAux+contractAux2 = contractAux1+  { caContract = (caContract contractAux1)+    { code =+      [ WithSrcEx (ics 0) $ PrimEx (CDR noAnn noAnn)+      , WithSrcEx (ics 1) $ PrimEx (NOT noAnn)+      , WithSrcEx (ics 2) $ PrimEx (NIL noAnn noAnn $ Type TOperation noAnn)+      , WithSrcEx (ics 3) $ PrimEx (PAIR noAnn noAnn noAnn noAnn)+      ]+    }+  }
+ test/Test/Michelson/Text.hs view
@@ -0,0 +1,160 @@+-- | Tests on 'MText'.+module Test.Michelson.Text+  ( test_Roundtrip+  , unit_mkMText+  , unit_parse+  , unit_mkMTextCut+  , unit_QuasiQuoter+  , unit_mt+  ) where++import Test.HUnit (Assertion, (@?), (@?=))+import Test.Tasty (TestTree)+import Fmt (pretty)+import qualified Text.Megaparsec as P++import Michelson.Parser+import qualified Michelson.Untyped as U+import Michelson.Text++import Test.Util.QuickCheck (roundtripTest)++-- | Parse string literal content to 'MText'.+parseMTextTest :: Text -> Either () MText+parseMTextTest t =+  first (const ()) $+  expectString <$> parseNoEnv (stringLiteral <* P.eof) "" ("\"" <> t <> "\"")+  where+    expectString = \case+      U.ValueString t' -> t'+      o -> error $ "Expected string, but got " <> pretty o++-- | 'MText' rountrip conversions.+test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ roundtripTest writeMText parseMTextTest ]++-- | Check value against the given predicate.+(@??) :: (Show a, HasCallStack) => a -> (a -> Bool) -> Assertion+(@??) val predicate =+  predicate val @?+  ("Predicate does not hold for value " <> show val)++unit_mkMText :: Assertion+unit_mkMText = do+  mkMText ""+    @?= Right (MTextUnsafe "")+  mkMText "a ba"+    @?= Right (MTextUnsafe "a ba")+  mkMText "a\nb"+    @?= Right (MTextUnsafe "a\nb")+  mkMText "a\\nb"+    @?= Right (MTextUnsafe "a\\nb")+  mkMText "\\\\"+    @?= Right (MTextUnsafe "\\\\")+  mkMText "\""+    @?= Right (MTextUnsafe "\"")+  mkMText "\r"+    @?? isLeft+  mkMText "\t"+    @?? isLeft+  mkMText (toText @String [toEnum 5])+    @?? isLeft+  mkMText (toText @String [toEnum 127])+    @?? isLeft+  mkMText (toText @String [toEnum 300])+    @?? isLeft++unit_parse :: Assertion+unit_parse = do+  parseMTextTest ""+    @?= Right (MTextUnsafe "")+  parseMTextTest "a ba"+    @?= Right (MTextUnsafe "a ba")+  parseMTextTest "a\nb"+    @?? isLeft+  parseMTextTest "a\\nb"+    @?= Right (MTextUnsafe "a\nb")+  parseMTextTest "\\"+    @?? isLeft+  parseMTextTest "\\\\"+    @?= Right (MTextUnsafe "\\")+  parseMTextTest "\""+    @?? isLeft+  parseMTextTest "\\\""+    @?= Right (MTextUnsafe "\"")+  parseMTextTest "\r"+    @?? isLeft+  parseMTextTest "\t"+    @?? isLeft+  parseMTextTest (toText @String [toEnum 5])+    @?? isLeft+  parseMTextTest (toText @String [toEnum 127])+    @?? isLeft+  parseMTextTest (toText @String [toEnum 300])+    @?? isLeft++unit_mkMTextCut :: Assertion+unit_mkMTextCut = do+  mkMTextCut ""+    @?= MTextUnsafe ""+  mkMTextCut "a ba"+    @?= MTextUnsafe "a ba"+  mkMTextCut "a\nb"+    @?= MTextUnsafe "a\nb"+  mkMTextCut "a\\nb"+    @?= MTextUnsafe "a\\nb"+  mkMTextCut "\\"+    @?= MTextUnsafe "\\"+  mkMTextCut "\\\\"+    @?= MTextUnsafe "\\\\"+  mkMTextCut "\""+    @?= MTextUnsafe "\""+  mkMTextCut "\\\""+    @?= MTextUnsafe "\\\""+  mkMTextCut "a\rb"+    @?= MTextUnsafe "ab"+  mkMTextCut "c\td\r"+    @?= MTextUnsafe "cd"+  mkMTextCut (toText @String [toEnum 5])+    @?= MTextUnsafe ""+  mkMTextCut (toText @String [toEnum 127])+    @?= MTextUnsafe ""+  mkMTextCut (toText @String [toEnum 300, 'A'])+    @?= MTextUnsafe "A"++unit_QuasiQuoter :: Assertion+unit_QuasiQuoter = do+  qqMText ""+    @?= Right ""+  qqMText "a ba"+    @?= Right "a ba"+  qqMText "a\nb"+    @?? isLeft+  qqMText "a\\nb"+    @?= Right "a\nb"+  qqMText "\\"+    @?? isLeft+  qqMText "\\\\"+    @?= Right "\\"+  qqMText "\""+    @?= Right "\""+  qqMText "\\\""+    @?? isLeft+  qqMText "\r"+    @?? isLeft+  qqMText "\t"+    @?? isLeft+  qqMText [toEnum 5]+    @?? isLeft+  qqMText [toEnum 127]+    @?? isLeft+  qqMText [toEnum 300]+    @?? isLeft++unit_mt :: Assertion+unit_mt = do+  [mt|aba|]+    @?= MTextUnsafe "aba"+  [mt| a  |]+    @?= MTextUnsafe " a  "
− test/Test/Morley/Runtime.hs 
@@ -1,152 +0,0 @@--- | Tests for Morley.Runtime.--module Test.Morley.Runtime-  ( spec-  ) where--import Control.Lens (at)-import Fmt (pretty)-import Test.Hspec-  (Expectation, Spec, context, describe, expectationFailure, it, parallel, runIO, shouldBe,-  shouldSatisfy, specify)--import Michelson.Interpret (ContractEnv(..), InterpretUntypedError(..), InterpretUntypedResult(..))-import Michelson.Typed (unsafeValToValue)-import Michelson.Untyped-import Morley.Ext (interpretMorleyUntyped)-import Morley.Runtime-import Morley.Runtime.GState (GState(..), initGState)-import Morley.Test.Dummy (dummyContractEnv, dummyMaxSteps, dummyNow, dummyOrigination)-import Morley.Types (MorleyLogs)-import Tezos.Address (Address(..))-import Tezos.Core (unsafeMkMutez)--spec :: Spec-spec = describe "Morley.Runtime" $ do-  illTypedContract <- runIO $-    prepareContract (Just "contracts/ill-typed/sum-strings.tz")--  -- Safe to run in parallel, because 'interpreterPure' is pure.-  describe "interpreterPure" $ parallel $ do-    context "Updates storage value of executed contract" $ do-      specify "contract1" $ updatesStorageValue contractAux1-      specify "contract2" $ updatesStorageValue contractAux2-    it "Fails to originate an already originated contract" failsToOriginateTwice-    it "Fails to originate an ill-typed contract"-      (failsToOriginateIllTyped (ValueString "") illTypedContract)--------------------------------------------------------------------------------- Test code--------------------------------------------------------------------------------- | Data type, that containts contract and its auxiliary data.------ This type is mostly used for testing purposes.-data ContractAux = ContractAux-  { caContract :: !UntypedContract-  , caEnv :: !ContractEnv-  , caStorage :: !UntypedValue-  , caParameter :: !UntypedValue-  }--data UnexpectedFailed =-  UnexpectedFailed (InterpretUntypedError MorleyLogs)-  deriving (Show)--instance Exception UnexpectedFailed--updatesStorageValue :: ContractAux -> Expectation-updatesStorageValue ca = either throwM handleResult $ do-  let-    contract = caContract ca-    ce = caEnv ca-    origination = (dummyOrigination (caStorage ca) contract)-      { ooBalance = ceBalance ce-      }-    addr = mkContractAddress origination-    txData = TxData-      { tdSenderAddress = ceSender ce-      , tdParameter = caParameter ca-      , tdAmount = unsafeMkMutez 100-      }-    interpreterOps =-      [ OriginateOp origination-      , TransferOp addr txData-      ]-  (addr,) <$> interpreterPure dummyNow dummyMaxSteps initGState interpreterOps-  where-    toNewStorage :: InterpretUntypedResult MorleyLogs -> UntypedValue-    toNewStorage InterpretUntypedResult {..} = unsafeValToValue iurNewStorage--    handleResult :: (Address, InterpreterRes) -> Expectation-    handleResult (addr, ir) = do-      expectedValue <--        either (throwM . UnexpectedFailed) (pure . toNewStorage) $-        interpretMorleyUntyped-                  (caContract ca) (caParameter ca) (caStorage ca) (caEnv ca)-      case gsAddresses (_irGState ir) ^. at addr of-        Nothing -> expectationFailure $ "Address not found: " <> pretty addr-        Just (ASContract cs) -> csStorage cs `shouldBe` expectedValue-        Just _ -> expectationFailure $ "Address has unexpected state " <> pretty addr--failsToOriginateTwice :: Expectation-failsToOriginateTwice =-  simpleTest ops isAlreadyOriginated-  where-    contract = caContract contractAux1-    origination = dummyOrigination (caStorage contractAux1) contract-    ops = [OriginateOp origination, OriginateOp origination]-    isAlreadyOriginated (Left (IEAlreadyOriginated {})) = True-    isAlreadyOriginated _ = False--failsToOriginateIllTyped :: UntypedValue -> UntypedContract -> Expectation-failsToOriginateIllTyped initialStorage illTypedContract =-  simpleTest ops isIllTypedContract-  where-    origination = dummyOrigination initialStorage illTypedContract-    ops = [OriginateOp origination]-    isIllTypedContract (Left (IEIllTypedContract {})) = True-    isIllTypedContract _ = False--simpleTest ::-     [InterpreterOp]-  -> (Either InterpreterError InterpreterRes -> Bool)-  -> Expectation-simpleTest ops predicate =-  interpreterPure dummyNow dummyMaxSteps initGState ops `shouldSatisfy`-  predicate--------------------------------------------------------------------------------- Data-------------------------------------------------------------------------------contractAux1 :: ContractAux-contractAux1 = ContractAux-  { caContract = contract-  , caEnv = dummyContractEnv-  , caStorage = ValueTrue-  , caParameter = ValueString "aaa"-  }-  where-    contract :: UntypedContract-    contract = Contract-      { para = Type tstring noAnn-      , stor = Type tbool noAnn-      , code =-        [ PrimEx $ CDR noAnn noAnn-        , PrimEx $ NIL noAnn noAnn $ Type TOperation noAnn-        , PrimEx $ PAIR noAnn noAnn noAnn noAnn-        ]-      }--contractAux2 :: ContractAux-contractAux2 = contractAux1-  { caContract = (caContract contractAux1)-    { code =-      [ PrimEx $ CDR noAnn noAnn-      , PrimEx $ NOT noAnn-      , PrimEx $ NIL noAnn noAnn $ Type TOperation noAnn-      , PrimEx $ PAIR noAnn noAnn noAnn noAnn-      ]-    }-  }
test/Test/Parser.hs view
@@ -1,49 +1,52 @@ module Test.Parser-  ( spec+  ( unit_Parse_contracts+  , unit_Value+  , unit_string_literal+  , unit_IF+  , unit_MAP+  , unit_PAIR+  , unit_pair_type+  , unit_or_type+  , unit_lambda_type+  , unit_list_type+  , unit_set_type+  , unit_explicitType+  , unit_Pair_constructor+  , unit_PrintComment+  , unit_ParserException+  , unit_letType   ) where  import qualified Data.List.NonEmpty as NE-import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)+import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy) import Text.Megaparsec (parse)+import Text.Megaparsec.Error (ErrorFancy(ErrorCustom), ParseError(FancyError), bundleErrors) -import Morley.Parser as P-import Morley.Types as Mo+import Michelson.ErrorPos (srcPos)+import Michelson.Macro as Mo+import Michelson.Parser as P+import Michelson.Untyped as Mo+import Util.IO  import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts) -spec :: Spec-spec = describe "Parser tests" $ do-  it "Successfully parses contracts examples from contracts/" parseContractsTest-  it "Test stringLiteral" stringLiteralTest-  it "IF parsers test" ifParsersTest-  it "MAP parsers test" mapParsersTest-  it "PAIR parsers test" pairParsersTest-  it "pair type parser test" pairTypeParserTest-  it "or type parser test" orTypeParserTest-  it "lambda type parser test" lambdaTypeParserTest-  it "list type parser test" listTypeParserTest-  it "set type parser test" setTypeParserTest-  it "pair constructor test" pairTest-  it "value parser test" valueParserTest-  it "printComment parser test" printCommentParserTest--parseContractsTest :: Expectation-parseContractsTest = do+unit_Parse_contracts :: Expectation+unit_Parse_contracts = do   files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts   mapM_ checkFile files--checkFile :: FilePath -> Expectation-checkFile file = do-  code <- readFile file-  parse P.program file code `shouldSatisfy` isRight+  where+    checkFile :: FilePath -> Expectation+    checkFile file = do+      code <- readFileUtf8 file+      parse P.program file code `shouldSatisfy` isRight -valueParserTest :: Expectation-valueParserTest = do+unit_Value :: Expectation+unit_Value = do   P.parseNoEnv P.value "" "{}" `shouldBe`-    (Right Mo.ValueNil)+    Right Mo.ValueNil   P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe`-    (Right . Mo.ValueLambda $ NE.fromList-      [Mo.Prim (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))]+    (Right . ValueLambda $ NE.fromList+      [Mo.Prim (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]     )   P.parseNoEnv P.value "" "{1; 2}" `shouldBe`     (Right . Mo.ValueSeq $ NE.fromList@@ -54,81 +57,88 @@       [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]     ) -stringLiteralTest :: Expectation-stringLiteralTest = do+unit_string_literal :: Expectation+unit_string_literal = do   P.parseNoEnv P.stringLiteral "" "\"\"" `shouldSatisfy` isRight-  P.parseNoEnv P.stringLiteral "" "\" \\t \\b \\n\\r  \"" `shouldSatisfy` isRight-  P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \n\n\r\"" `shouldSatisfy` isRight+  P.parseNoEnv P.stringLiteral "" "\" \\n  \"" `shouldSatisfy` isRight   P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft   P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft -ifParsersTest :: Expectation-ifParsersTest = do-  P.parseNoEnv P.ops "" "{IF {} {};}" `shouldBe`-    (Prelude.Right [Mo.Prim $ Mo.IF [] []])-  P.parseNoEnv P.ops "" "{IFEQ {} {};}" `shouldBe`-    (Prelude.Right [Mo.Mac $ Mo.IFX (Mo.EQ noAnn) [] []])-  P.parseNoEnv P.ops "" "{IFCMPEQ {} {};}" `shouldBe`-    (Prelude.Right [Mo.Mac $ Mo.IFCMP (Mo.EQ noAnn) noAnn [] []])+unit_IF :: Expectation+unit_IF = do+  P.parseNoEnv P.codeEntry "" "{IF {} {};}" `shouldBe`+    Prelude.Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry "" "{IFEQ {} {};}" `shouldBe`+    Prelude.Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry "" "{IFCMPEQ {} {};}" `shouldBe`+    Prelude.Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)] -mapParsersTest :: Expectation-mapParsersTest = do-  parseNoEnv P.ops "" "{MAP {};}" `shouldBe`-    (Prelude.Right [Mo.Prim $ Mo.MAP noAnn []])-  parseNoEnv P.ops "" "{MAP_CAR {};}" `shouldBe`-    (Prelude.Right [Mo.Mac $ Mo.MAP_CADR [Mo.A] noAnn noAnn []])+unit_MAP :: Expectation+unit_MAP = do+  parseNoEnv P.codeEntry "" "{MAP {};}" `shouldBe`+    Prelude.Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]+  parseNoEnv P.codeEntry "" "{MAP_CAR {};}" `shouldBe`+    Prelude.Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)] -pairParsersTest :: Expectation-pairParsersTest = do-  P.parseNoEnv P.ops "" "{PAIR;}" `shouldBe`-    Prelude.Right [Mo.Prim $ PAIR noAnn noAnn noAnn noAnn]-  P.parseNoEnv P.ops "" "{PAIR %a;}" `shouldBe`-    Prelude.Right [Mac $ PAPAIR (P (F (noAnn, Mo.ann "a")) (F (noAnn,noAnn))) noAnn noAnn]-  P.parseNoEnv P.ops "" "{PAPAIR;}" `shouldBe`+unit_PAIR :: Expectation+unit_PAIR = do+  P.parseNoEnv P.codeEntry "" "{PAIR;}" `shouldBe`+    Prelude.Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry "" "{PAIR %a;}" `shouldBe`+    Prelude.Right [Mac (PAPAIR (P (F (noAnn, Mo.ann "a")) (F (noAnn,noAnn))) noAnn noAnn) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry "" "{PAPAIR;}" `shouldBe`     Prelude.Right-      [Mac $+      [flip Mac (srcPos 0 1) $         PAPAIR (P (F (noAnn,noAnn)) (P (F (noAnn,noAnn)) (F (noAnn,noAnn))))           noAnn noAnn       ] -pairTypeParserTest :: Expectation-pairTypeParserTest = do+unit_pair_type :: Expectation+unit_pair_type = do   P.parseNoEnv P.type_ "" "pair unit unit" `shouldBe` Right unitPair   P.parseNoEnv P.type_ "" "(unit, unit)" `shouldBe` Right unitPair+  P.parseNoEnv P.type_ "" "(Parameter, (int, (Storage, bool)))"+    `shouldSatisfy` isRight+  P.parseNoEnv P.type_ "" "(Parameter, Parameter, Storage, bool)"+    `shouldSatisfy` isRight   where     unitPair :: Mo.Type     unitPair =       Mo.Type (Mo.TPair noAnn noAnn (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn -orTypeParserTest :: Expectation-orTypeParserTest = do+unit_or_type :: Expectation+unit_or_type = do   P.parseNoEnv P.type_ "" "or unit unit" `shouldBe` Right unitOr   P.parseNoEnv P.type_ "" "(unit | unit)" `shouldBe` Right unitOr+  P.parseNoEnv P.type_ "" "Parameter | (int | (Storage | bool)))"+    `shouldSatisfy` isRight   where     unitOr :: Mo.Type     unitOr =       Mo.Type (Mo.TOr noAnn noAnn (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn -lambdaTypeParserTest :: Expectation-lambdaTypeParserTest = do+unit_lambda_type :: Expectation+unit_lambda_type = do   P.parseNoEnv P.type_ "" "lambda unit unit" `shouldBe` Right lambdaUnitUnit   P.parseNoEnv P.type_ "" "\\unit -> unit" `shouldBe` Right lambdaUnitUnit+  P.parseNoEnv P.type_ "" "lambda int (Storage, int)" `shouldSatisfy` isRight   where     lambdaUnitUnit :: Mo.Type     lambdaUnitUnit =       Mo.Type (Mo.TLambda (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn -listTypeParserTest :: Expectation-listTypeParserTest = do+unit_list_type :: Expectation+unit_list_type = do   P.parseNoEnv P.type_ "" "list unit" `shouldBe` Right unitList   P.parseNoEnv P.type_ "" "[unit]" `shouldBe` Right unitList+  P.parseNoEnv P.type_ "" "[(Parameter, Storage)]" `shouldSatisfy` isRight   where     unitList :: Mo.Type     unitList =       Mo.Type (Mo.TList (Mo.Type Mo.TUnit noAnn)) noAnn -setTypeParserTest :: Expectation-setTypeParserTest = do+unit_set_type :: Expectation+unit_set_type = do   P.parseNoEnv P.type_ "" "set int" `shouldBe` Right intSet   P.parseNoEnv P.type_ "" "{int}" `shouldBe` Right intSet   where@@ -136,16 +146,27 @@     intSet =       Mo.Type (Mo.TSet (Mo.Comparable Mo.CInt noAnn)) noAnn -pairTest :: Expectation-pairTest = do+unit_explicitType :: Expectation+unit_explicitType = do+  P.parseNoEnv P.explicitType "" "Parameter" `shouldSatisfy` isLeft+  P.parseNoEnv P.explicitType "" "Storage" `shouldSatisfy` isLeft+  P.parseNoEnv P.explicitType "" "List Parameter" `shouldSatisfy` isLeft+  P.parseNoEnv P.explicitType "" "Void int Parameter" `shouldSatisfy` isLeft+  P.parseNoEnv P.explicitType "" "(Parameter, (int, (bool, Storage)))"+    `shouldSatisfy` isLeft+  P.parseNoEnv P.explicitType "" "int"+    `shouldBe` (Right $ Mo.Type (Mo.Tc Mo.CInt) noAnn)++unit_Pair_constructor :: Expectation+unit_Pair_constructor = do   P.parseNoEnv P.value "" "Pair Unit Unit" `shouldBe` Right unitPair   P.parseNoEnv P.value "" "(Unit, Unit)" `shouldBe` Right unitPair   where-    unitPair :: Mo.Value Mo.ParsedOp+    unitPair :: Mo.Value' Mo.ParsedOp     unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit -printCommentParserTest :: Expectation-printCommentParserTest = do+unit_PrintComment :: Expectation+unit_PrintComment = do   P.parseNoEnv P.printComment "" "\"Sides are %[0] x %[1]\"" `shouldBe`     Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])   P.parseNoEnv P.printComment "" "\"%[0] x\"" `shouldBe`@@ -158,3 +179,36 @@     Right (PrintComment [Left "xxx"])   P.parseNoEnv P.printComment "" "\"\"" `shouldBe`     Right (PrintComment [])++unit_ParserException :: Expectation+unit_ParserException = do+  handleCustomError "0x000" P.value OddNumberBytesException+  handleCustomError "Right 0x000" P.value OddNumberBytesException+  handleCustomError "kek" P.type_ UnknownTypeException+  handleCustomError "\"aaa\\r\"" P.stringLiteral+    (StringLiteralException (InvalidEscapeSequence 'r'))+  handleCustomError "\"aaa\\b\"" P.stringLiteral+    (StringLiteralException (InvalidEscapeSequence 'b'))+  handleCustomError "\"aaa\\t\"" P.stringLiteral+    (StringLiteralException (InvalidEscapeSequence 't'))+  handleCustomError "\"aaa\n\"" P.stringLiteral+    (StringLiteralException (InvalidChar '\n'))+  handleCustomError "\"aaa\r\"" P.stringLiteral+    (StringLiteralException (InvalidChar '\r'))+  where+    handleCustomError+      :: HasCallStack => Text -> Parser a -> CustomParserException -> Expectation+    handleCustomError text parser customException =+      case P.parseNoEnv parser "" text of+        Right _ -> expectationFailure "expecting parser to fail"+        Left bundle -> case toList $ bundleErrors bundle of+          [FancyError _ errorSet] -> case toList errorSet of+            [(ErrorCustom e)] -> e `shouldBe` customException+            _ -> expectationFailure "expecting single ErrorCustom"+          _ -> expectationFailure "expecting single ErrorCustom"++unit_letType :: Expectation+unit_letType = do+  P.parseNoEnv P.letType "" "type kek = int" `shouldSatisfy` isRight+  P.parseNoEnv P.letType "" "type Parameter = int" `shouldSatisfy` isLeft+  P.parseNoEnv P.letType "" "type Storage = int" `shouldSatisfy` isLeft
test/Test/Printer/Michelson.hs view
@@ -1,27 +1,69 @@ module Test.Printer.Michelson-  ( spec+  ( unit_Roundtrip+  , unit_let_macro   ) where  import Fmt (pretty)-import Test.Hspec (Spec, describe, it, runIO, shouldBe)+import Test.HUnit (Assertion, assertEqual, assertFailure, (@?=))+import Generics.SYB (everywhere, mkT)  import Michelson.Printer (printUntypedContract)-import Morley.Runtime (parseExpandContract)-import Morley.Test (specWithUntypedContract)+import Michelson.Runtime (parseExpandContract)+import Michelson.Test (importUntypedContract)+import Michelson.Untyped.Instr (ExpandedOp(..))+import qualified Michelson.Untyped as U -import Test.Util.Contracts (getWellTypedContracts)+import Test.Util.Contracts -spec :: Spec-spec = describe "Michelson.TzPrinter.printUntypedContract" $ do-  contractFiles <- runIO getWellTypedContracts-  mapM_ roundtripPrintTest contractFiles+unit_Roundtrip :: Assertion+unit_Roundtrip = do+  morleyContractFiles <- getWellTypedMorleyContracts+  mapM_ morleyRoundtripPrintTest morleyContractFiles+  michelsonContractFiles <- getWellTypedMichelsonContracts+  mapM_ michelsonRoundtripPrintTest michelsonContractFiles+  where+    morleyRoundtripPrintTest :: FilePath -> Assertion+    morleyRoundtripPrintTest filePath = do+      contract1 <- importUntypedContract filePath+      contract2 <- printAndParse filePath contract1+      -- We don't expect that `contract1` equals `contract2`,+      -- because during printing we lose extra instructions.+      assertEqual ("After printing and parsing " <> filePath <>+                   " is printed differently")+        (printUntypedContract contract1)+        (printUntypedContract contract2)+    michelsonRoundtripPrintTest :: FilePath -> Assertion+    michelsonRoundtripPrintTest filePath = do+      contract1 <- importUntypedContract filePath+      contract2 <- printAndParse filePath contract1+      -- We expect `contract1` equals `contract2`.+      assertEqual ("After printing and parsing " <> filePath <>+                   " contracts are different")+        (transformContract contract1) (transformContract contract2) -roundtripPrintTest :: FilePath -> Spec-roundtripPrintTest filePath =-  -- these are untyped and expanded contracts, they might have macros-  specWithUntypedContract filePath $ \contract1 ->-    it "roundtrip printUntypedContract test" $ do-      case parseExpandContract (Just filePath) (toText $ printUntypedContract contract1) of-        Left err -> fail ("Failed to read 'printUntypedContract contract1': " ++ pretty err)-        Right contract2 ->-          printUntypedContract contract1 `shouldBe` printUntypedContract contract2+unit_let_macro :: Assertion+unit_let_macro = do+  let filePath = "contracts/ill-typed/letblock_trivial.mtz"+  contract <- printAndParse filePath =<< importUntypedContract filePath+  let ops = concatMap U.flattenExpandedOp (U.code contract)+  ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP]++printAndParse :: FilePath -> U.Contract -> IO U.Contract+printAndParse fp contract1 =+  case parseExpandContract (Just fp) (toText $ printUntypedContract contract1) of+    Left err ->+      assertFailure ("Failed to parse printed " <> fp <> ": " <> pretty err)+    Right contract2 -> pure contract2+++-- | Remove all `WithSrcEx` from contract code because `SrcPos`es+-- and such stuff can change during printing and parsing+transformContract :: U.Contract -> U.Contract+transformContract (U.Contract c s code) =+  U.Contract c s (map transform code)+  where+    transform :: ExpandedOp -> ExpandedOp+    transform = everywhere $ mkT removeWithSrcEx+    removeWithSrcEx :: ExpandedOp -> ExpandedOp+    removeWithSrcEx (WithSrcEx _ op) = op+    removeWithSrcEx op = op
test/Test/Serialization/Aeson.hs view
@@ -1,55 +1,53 @@ module Test.Serialization.Aeson-  ( spec+  ( test_Roundtrip   ) where -import Data.Aeson (FromJSON, ToJSON)-import Test.Aeson.GenericSpecs (roundtripADTSpecs, roundtripSpecs)-import Test.Hspec (Spec)+import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import Test.QuickCheck (Arbitrary)+import Test.Tasty (TestTree)  import Michelson.Untyped-  (Elt, FieldAnn, InstrAbstract, TypeAnn, UntypedContract, UntypedValue,-  VarAnn, ExpandedOp)+  (Contract, Elt, ExpandedOp, FieldAnn, InstrAbstract, TypeAnn, Value, VarAnn) import Tezos.Core (Mutez, Timestamp)+import Util.Test.Arbitrary () -import Test.Arbitrary ()-import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary)+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..))+import Test.Util.QuickCheck (roundtripADTTest, roundtripTest)  -- Note: if we want to enforce a particular JSON format, we can extend -- these test with golden tests (it's easy with `hspec-golden-aeson`).  -- For types with one constructor and/or without 'ToADTArbitrary' instance.-test :: forall a.-  (Arbitrary a, ToJSON a, FromJSON a, Typeable a)-  => Proxy a-  -> Spec-test = roundtripSpecs+test+  :: forall a. (Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a, Typeable a)+  => TestTree+test = roundtripTest @a encode eitherDecode  -- For types with 'ToADTArbitrary' instance. testADT :: forall a.-  (Show a, Eq a, Arbitrary a, ToADTArbitrary a, ToJSON a, FromJSON a)-  => Proxy a-  -> Spec-testADT = roundtripADTSpecs+  (Show a, Eq a, ToADTArbitrary a, ToJSON a, FromJSON a, Typeable a)+  => TestTree+testADT = roundtripADTTest @a encode eitherDecode -spec :: Spec-spec = do-  -- Core Tezos types-  test (Proxy @Timestamp)-  test (Proxy @Mutez)+test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ -- Core Tezos types+    test @Timestamp+  , test @Mutez    -- Michelson types-  testADT (Proxy @ExpandedOp)+  , testADT @ExpandedOp    -- these are actually all the same thing (Annotation a),   -- where a is a phantom type,   -- but let's test them in case they   -- ever change for some reason-  test (Proxy @TypeAnn)-  test (Proxy @FieldAnn)-  test (Proxy @VarAnn)+  , test @TypeAnn+  , test @FieldAnn+  , test @VarAnn -  test (Proxy @UntypedContract)-  testADT (Proxy @(InstrAbstract ExpandedOp))-  test (Proxy @UntypedValue)-  test (Proxy @(Elt ExpandedOp))+  , test @Contract+  , testADT @(InstrAbstract ExpandedOp)+  , test @Value+  , test @(Elt ExpandedOp)+  ]
+ test/Test/Serialization/Michelson.hs view
@@ -0,0 +1,660 @@+{-# LANGUAGE OverloadedLists #-}++module Test.Serialization.Michelson+  ( spec_Packing+  ) where++import Prelude hiding (Ordering(..))++import Data.Singletons (SingI(..))+import qualified Data.Text as T+import Data.Typeable ((:~:)(..), Typeable, eqT, typeRep)+import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)+import Text.Hex (decodeHex, encodeHex)++import Michelson.Interpret (runUnpack)+import Michelson.Interpret.Pack (packValue')+import Michelson.Macro (expandList)+import qualified Michelson.Parser as Parser+import Michelson.Test.Util+import Michelson.TypeCheck (HST(..), SomeInstr(..), SomeInstrOut(..), typeCheckList)+import Michelson.Typed+import Michelson.Text+import Michelson.Untyped (noAnn)+import Test.Util.Parser+import Tezos.Address (Address(..), unsafeParseAddress)+import Tezos.Core (Mutez, Timestamp, timestampFromSeconds, unsafeMkMutez)+import Tezos.Crypto (KeyHash(..), parseKeyHash, parsePublicKey, parseSignature)++spec_Packing :: Spec+spec_Packing = do+  describe "pack tests for comparable values (CValue)" $ do+    intTest+    natTest+    stringTest+    bytesTest+    mutezTest+    boolTest+    keyHashTest+    timestampTest+    addressTest++  describe "pack tests for non-comparable values" $ do+    keyTest+    unitTest+    signatureTest+    optionTest+    listTest+    setTest+    contractTest+    pairTest+    orTest+    mapTest++  describe "pack tests for instructions" $ do+    instrTest+    typesTest++  unpackNegTest++stripOptional0x :: Text -> Text+stripOptional0x h = T.stripPrefix "0x" h ?: h++-- | Dummy wrapper for what do we test - pack or unpack.+data TestMethod = TestMethod+  { _tmName :: String+  , _tmApply+      :: forall t. (Typeable t, SingI t, HasNoOp t, HasNoBigMap t)+      => Value t -> Text -> Expectation+  }++testMethods :: HasCallStack => [TestMethod]+testMethods =+  [ TestMethod "Pack" $+      \val encodedHex ->+        encodeHex (packValue' val) `shouldBe` stripOptional0x encodedHex++  , TestMethod "Unpack" $+      \val encodedHex ->+        let encoded = decodeHex (stripOptional0x encodedHex)+                      ?: error ("Invalid hex: " <> show encodedHex)+        in runUnpack mempty encoded+            `shouldBe` Right val+  ]++packSpecManual+    :: (Show x, Typeable t, SingI t, HasNoOp t, HasNoBigMap t, HasCallStack)+    => String -> (x -> Value t) -> [(x, Text)] -> Spec+packSpecManual name toVal' suites =+  forM_ @[_] testMethods $ \(TestMethod mname method) ->+    describe mname $+      describe name $ forM_ suites $ \(x, h) ->+        it (show x) $ method (toVal' x) h++packSpec+  :: forall x (t :: T).+     (Typeable t, IsoValue x, Show x, ToT x ~ t, SingI t, HasNoOp t, HasNoBigMap t+     , HasCallStack)+  => [(x, Text)]+  -> Spec+packSpec = packSpecManual typeName toVal+  where+    typeName = show $ typeRep (Proxy @(Value t))++parsePackSpec+  :: forall (inp :: T) (out :: T).+     (Each [Typeable, SingI] [inp, out], HasCallStack)+  => String+  -> [(Text, Text)]+  -> Spec+parsePackSpec name suites =+  forM_ @[_] testMethods $ \(TestMethod mname method) ->+    describe mname $+      describe name $ forM_ suites $ \(codeText, packed) ->+        it (truncateName $ toString codeText) $ do+          parsed <- Parser.codeEntry `shouldParse` codeText+          let code = expandList parsed+          let _ :/ typed = typeCheckList code initStack+                & runExceptT+                & evaluatingState initTypeCheckST+                & leftToShowPanic++          case typed of+            AnyOutInstr instr ->+              method (VLam @inp @out instr) packed++            (instr :: Instr '[inp] outs) ::: _ ->+              case eqT @'[out] @outs of+                Just Refl ->+                  method (VLam @inp @out instr) packed+                Nothing ->+                  error "Output type unexpectedly mismatched"+  where+    truncateName s+      | length s < 60 = s+      | otherwise = take 60 s <> " ..."+    initTypeCheckST = error "Type check state is not defined"+    initStack = (sing @inp, NStar, noAnn) ::& SNil++unpackNegSpec+  :: forall (t :: T).+      (SingI t, HasNoOp t, HasNoBigMap t)+  => String -> Text -> Spec+unpackNegSpec name encodedHex =+  it name $+    let encoded = decodeHex (stripOptional0x encodedHex)+                  ?: error ("Invalid hex: " <> show encodedHex)+    in runUnpack @t mempty encoded+        `shouldSatisfy` isLeft++-- | Helper for defining tests cases for 'packSpec'.+-- Read it as "is packed as".+(~:) :: a -> b -> (a, b)+(~:) = (,)+infix 0 ~:++intTest :: Spec+intTest =+  packSpec+    @Integer+    [ (-64, "0500c001")+    , (-63, "05007f")+    , (-2,  "050042")+    , (-1,  "050041")+    , (0,   "050000")+    , (1,   "050001")+    , (2,   "050002")+    , (63,  "05003f")+    , (64,  "05008001")+    , (65,  "05008101")+    , (-65, "0500c101")+    , (127, "0500bf01")+    , (128, "05008002")+    , (129, "05008102")+    , (-127, "0500ff01")+    , (191, "0500bf02")+    , (192, "05008003")+    , (193, "05008103")+    , (2028, "0500ac1f")+    , (5000, "0500884e")+    , (10000, "0500909c01")+    , (20000, "0500a0b802")+    , (-5000, "0500c84e")+    , (-10000, "0500d09c01")+    , (-20000, "0500e0b802")+    ]++natTest :: Spec+natTest =+  packSpec+    @Natural+    [ (0, "050000")+    , (1, "050001")+    , (63, "05003f")+    , (64, "05008001")+    , (65, "05008101")+    , (127, "0500bf01")+    , (128, "05008002")+    , (129, "05008102")+    , (191, "0500bf02")+    , (192, "05008003")+    , (193, "05008103")+    ]++stringTest :: Spec+stringTest =+  packSpec+    @MText+    [ [mt|Hello World!|] ~: "05010000000c48656c6c6f20576f726c6421"+    , [mt|HODL: Hold On for Dear Life|]+        ~: "05010000001b484f444c3a20486f6c64204f6e20666f722044656172204c696665"+    , [mt|\n|]+        ~: "0501000000010a"+    ]++bytesTest :: Spec+bytesTest =+  packSpec+    @ByteString+    [ "000123" ~: "050a00000006303030313233"+    , "A rose by any other name would smell as sweet"+        ~: "050a0000002d4120726f736520627920616e79206f74686572206e616\+           \d6520776f756c6420736d656c6c206173207377656574"+    ]++mutezTest :: Spec+mutezTest =+  packSpec+    @Mutez+    [ (unsafeMkMutez 0  , "050000")+    , (unsafeMkMutez 1  , "050001")+    , (unsafeMkMutez 63 , "05003f")+    , (unsafeMkMutez 64 , "05008001")+    , (unsafeMkMutez 65 , "05008101")+    , (unsafeMkMutez 127, "0500bf01")+    , (unsafeMkMutez 128, "05008002")+    , (unsafeMkMutez 129, "05008102")+    , (unsafeMkMutez 191, "0500bf02")+    , (unsafeMkMutez 192, "05008003")+    , (unsafeMkMutez 193, "05008103")+    ]++boolTest :: Spec+boolTest =+  packSpec+    @Bool+    [ (True , "05030a")+    , (False, "050303")+    ]++keyHashTest :: Spec+keyHashTest = do+  packSpec+    @KeyHash+    [ ( leftToShowPanic $ parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"+      , "050a000000150002298c03ed7d454a101eb7022bc95f7e5f41ac78"+      )+    ]++timestampTest :: Spec+timestampTest = do+  packSpec @Timestamp $ convertTimestamps+    [ (205027200, "050080dec3c301")+    , (1552564995, "0500838cd2c80b")+    ]+  where+    convertTimestamps = map . first $ timestampFromSeconds @Int++addressTest :: Spec+addressTest = do+  packSpec @Address $ parseAddrs+    [ ( "tz1PYgf9fBGLXvwx8ag8sdwjLJzmyGdNiswM"+      , "050a0000001600002addb327dbca405f07aeef318bba0ec2f714a755"+      )+    , ( "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH"+      , "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b"+      )+    , ( "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH"+      , "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b"+      )+    , ( "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"+      , "050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200"+      )+    , ( "KT1NSrmSJrSueZiWPKrcAUScYr6k2BkUVALr"+      , "050a00000016019812c669d9e8ff1a61bf8c57e33b955f074d832600"+      )+    ]+  where+    parseAddrs = map $ first unsafeParseAddress++keyTest :: Spec+keyTest =+  packSpecManual "key" VKey+    [ ( leftToShowPanic $+          parsePublicKey "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH"+      , "050a00000021009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d"+      )+    ]++unitTest :: Spec+unitTest =+  packSpec+    @()+    [() ~: "05030b"]++signatureTest :: Spec+signatureTest =+  packSpecManual "signature" VSignature+    [ ( leftToShowPanic $+          parseSignature "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8\+                         \ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"+      , "050a0000004091ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda\+        \232db34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b9188\+        \8fdc8201"+      )+    ]++optionTest :: Spec+optionTest = do+  packSpec+    @(Maybe Integer)+    [ Just 123 ~: "05050900bb01"+    , Nothing ~: "050306"+    ]+  packSpec+    @(Maybe MText)+    [ Just [mt|Goodnight World!|]+        ~: "0505090100000010476f6f646e6967687420576f726c6421"+    ]++listTest :: Spec+listTest =+  packSpec+    @[Integer]+    [ [] ~: "050200000000"+    , [1] ~: "0502000000020001"+    , [1..3] ~: "050200000006000100020003"+    ]++setTest :: Spec+setTest =+  packSpec+    @(Set Integer)+    [ [] ~: "050200000000"+    , [1] ~: "0502000000020001"+    , [0, 10, 24, 35, 100, 1000] ~: "05020000000e0000000a0018002300a40100a80f"+    ]++contractTest :: Spec+contractTest = do+  packSpecManual "contract" (VContract @'TUnit) $ parseAddrs+    [ "tz1PYgf9fBGLXvwx8ag8sdwjLJzmyGdNiswM"+        ~: "050a0000001600002addb327dbca405f07aeef318bba0ec2f714a755"+    , "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH"+        ~: "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b"+    ]++  packSpecManual "contract" (VContract @('Tc 'CInt)) $ parseAddrs+    [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"+        ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200"+    ]+  where+    parseAddrs = map $ first unsafeParseAddress++pairTest :: Spec+pairTest = do+  packSpec+    @(MText, Integer)+    [ ([mt|Good Night!|], 5) ~: "050707010000000b476f6f64204e69676874210005"+    ]+  packSpec+    @(Integer, (Integer, MText))+    [ (120, (5, [mt|What is that?|]))+        ~: "05070700b80107070005010000000d5768617420697320746861743f"+    ]++orTest :: Spec+orTest =+  packSpec+    @(Either MText Bool)+    [ Left [mt|Error|] ~: "05050501000000054572726f72"+    , Right True ~: "050508030a"+    ]++mapTest :: Spec+mapTest = do+  packSpec+    @(Map Integer MText)+    [ [] ~: "050200000000"+    , [(0, [mt|Hello|]), (1, [mt|Goodbye|]), (2, [mt|Goodnight|])]+        ~: "05020000003007040000010000000548656c6c6f07040001010000000\+            \7476f6f64627965070400020100000009476f6f646e69676874"+    ]++  packSpec+    @(Map MText (Integer, Bool))+    [ [ ([mt|Tudor|], (123, True))+      , ([mt|Lancaster|], (22323, False))+      , ([mt|Stuart|], (-832988, True))+      ] ~: "050200000040070401000000094c616e636173746572070700b3dc0203\+           \0307040100000006537475617274070700dcd765030a07040100000005\+           \5475646f72070700bb01030a"+    ]++instrTest :: Spec+instrTest = do+  -- Values we compare against are produced with command+  -- ./alphanet.sh client hash data '{ $instrs }' of type 'lambda int int'++  parsePackSpec @('Tc 'CInt) @('Tc 'CInt) "instr"+    [ "{ }"+       ~: "0x050200000000"+    , "{ PUSH int 1; DROP }"+       ~: "0x0502000000080743035b00010320"+    , "{ DUP; SWAP; DROP }"+       ~: "0x0502000000060321034c0320"+    , "{ UNIT; DROP }"+       ~: "0x050200000004034f0320"+    , "{ PUSH int 1; SOME; IF_NONE {} {DROP} }"+       ~: "0x0502000000160743035b00010346072f020000000002000000020320"+    , "{ PUSH int 1; SOME; IF_SOME {DROP} {} }"+       ~: "0x05020000001b0743035b00010346020000000e072f020000000002000000020320"+    , "{ NONE int; DROP }"+       ~: "0x050200000006053e035b0320"+    , "{ PUSH int 1; PAIR; CAR }"+       ~: "0x05020000000a0743035b000103420316"+    , "{ LEFT unit; IF_LEFT {} { DROP; PUSH int 1 } }"+       ~: "0x0502000000180533036c072e0200000000020000000803200743035b0001"+    , "{ RIGHT unit; IF_RIGHT {} { DROP; PUSH int 1 } }"+       ~: "0x05020000001d0544036c0200000014072e020000000803200743035b00010200000000"+    , "{ DUP; NIL int; SWAP; CONS; SIZE; DROP }"+       ~: "0x05020000000e0321053d035b034c031b03450320"+    , "{ NIL int; IF_CONS { DROP; DROP } {} }"+       ~: "0x050200000014053d035b072d0200000004032003200200000000"+    , "{ EMPTY_SET int; ITER { DROP } }"+       ~: "0x05020000000d0524035b055202000000020320"+    , "{ EMPTY_MAP int unit; MAP {}; DROP }"+       ~: "0x05020000000f0723035b036c053802000000000320"+    , "{ EMPTY_MAP int unit; PUSH int 1; MEM; DROP }"+       ~: "0x0502000000100723035b036c0743035b000103390320"+    , "{ EMPTY_MAP int unit; PUSH int 1; GET; DROP }"+       ~: "0x0502000000100723035b036c0743035b000103290320"+    , "{ EMPTY_MAP int unit; NONE unit; PUSH int 1; UPDATE; DROP }"+       ~: "0x0502000000140723035b036c053e036c0743035b000103500320"+    , "{ PUSH bool True; IF {} {} }"+       ~: "0x05020000001207430359030a072c02000000000200000000"+    , "{ PUSH bool True; LOOP { PUSH bool False } }"+       ~: "0x05020000001307430359030a05340200000006074303590303"+    , "{ PUSH (or int int) (Left 1); LOOP_LEFT { RIGHT int }; DROP }"+       ~: "0x05020000001907430764035b035b05050001055302000000040544035b0320"+    , "{ LAMBDA int int { PUSH int 1; DROP }; SWAP; EXEC }"+       ~: "0x05020000001f093100000011035b035b02000000080743035b0001032000000000034c0326"+    , "{ DIP {} }"+       ~: "0x050200000007051f0200000000"+    , "{ FAILWITH }"+       ~: "0x0502000000020327"+    , "{ CAST int }"+       ~: "0x0502000000040557035b"+    , "{ RENAME }"+       ~: "0x0502000000020358"+    , "{ DUP; PACK; UNPACK unit; DROP }"+       ~: "0x05020000000a0321030c050d036c0320"+    , "{ PUSH string \"\"; DUP; CONCAT; DROP }"+       ~: "0x05020000000f0743036801000000000321031a0320"+    , "{ NIL string; CONCAT; DROP }"+       ~: "0x050200000008053d0368031a0320"+    , "{ PUSH string \"\"; PUSH nat 1; PUSH nat 2; SLICE; DROP }"+       ~: "0x050200000019074303680100000000074303620001074303620002036f0320"+    , "{ PUSH int 1; ISNAT; DROP }"+       ~: "0x05020000000a0743035b000103560320"+      -- Arithmetic instructions are below+    , "{ PUSH nat 1; INT; DROP }"+       ~: "0x05020000000a07430362000103300320"+      -- SELF cannot appear in lambda+      -- CONTRACT - IMPLICIT_ACCOUNT go below+    , "{ NOW; DROP }"+      ~: "0x05020000000403400320"+    , "{ AMOUNT; DROP }"+      ~: "0x05020000000403130320"+    , "{ BALANCE; DROP }"+      ~: "0x05020000000403150320"+      -- CHECK_SIGNATURE goes below+    , "{ PUSH bytes 0x; SHA256; DROP }"+      ~: "0x05020000000d074303690a00000000030f0320"+    , "{ PUSH bytes 0x; SHA512; DROP }"+      ~: "0x05020000000d074303690a0000000003100320"+    , "{ PUSH bytes 0x; BLAKE2B; DROP }"+      ~: "0x05020000000d074303690a00000000030e0320"+      -- HASH_KEY goes below+    , "{ STEPS_TO_QUOTA; DROP }"+      ~: "0x050200000004034a0320"+    , "{ SOURCE; DROP }"+      ~: "0x05020000000403470320"+    , "{ SENDER; DROP }"+      ~: "0x05020000000403480320"+      -- ADDRESS goes below+    ]++  parsePackSpec @'TUnit @'TUnit "arith instr"+    [ "{ PUSH int 1; PUSH int 2; ADD; DROP }"+       ~: "0x0502000000100743035b00010743035b000203120320"+    , "{ PUSH int 1; PUSH int 2; SUB; DROP }"+       ~: "0x0502000000100743035b00010743035b0002034b0320"+    , "{ PUSH int 1; PUSH int 2; MUL; DROP }"+       ~: "0x0502000000100743035b00010743035b0002033a0320"+    , "{ PUSH int 1; PUSH int 2; EDIV; DROP }"+       ~: "0x0502000000100743035b00010743035b000203220320"+    , "{ PUSH int 1; ABS; DROP }"+       ~: "0x05020000000a0743035b000103110320"+    , "{ PUSH int 1; NEG; DROP }"+       ~: "0x05020000000a0743035b0001033b0320"+    , "{ PUSH nat 1; PUSH nat 2; LSL; DROP }"+       ~: "0x05020000001007430362000107430362000203350320"+    , "{ PUSH nat 1; PUSH nat 2; LSR; DROP }"+       ~: "0x05020000001007430362000107430362000203360320"+    , "{ PUSH nat 1; PUSH nat 2; OR; DROP }"+       ~: "0x05020000001007430362000107430362000203410320"+    , "{ PUSH nat 1; PUSH nat 2; XOR; DROP }"+       ~: "0x05020000001007430362000107430362000203510320"+    , "{ PUSH int 1; NOT; DROP }"+       ~: "0x05020000000a0743035b0001033f0320"+    , "{ PUSH nat 1; PUSH nat 2; COMPARE; DROP }"+       ~: "0x05020000001007430362000107430362000203190320"+    , "{ PUSH int 1; EQ; DROP }"+       ~: "0x05020000000a0743035b000103250320"+    , "{ PUSH int 1; NEQ; DROP }"+       ~: "0x05020000000a0743035b0001033c0320"+    , "{ PUSH int 1; LT; DROP }"+       ~: "0x05020000000a0743035b000103370320"+    , "{ PUSH int 1; GT; DROP }"+       ~: "0x05020000000a0743035b0001032a0320"+    , "{ PUSH int 1; LE; DROP }"+       ~: "0x05020000000a0743035b000103320320"+    , "{ PUSH int 1; GE; DROP }"+       ~: "0x05020000000a0743035b000103280320"+    ]++  parsePackSpec @('Tc 'CAddress) @'TUnit "instrs address-related"+    [ "{ CONTRACT unit; DROP; PUSH unit Unit }"+       ~: "0x05020000000c0555036c03200743036c030b"+    ]++  parsePackSpec @('TContract 'TUnit) @'TUnit "instrs contract-related"+    [ "{ PUSH mutez 5; PUSH unit Unit; TRANSFER_TOKENS; DROP; PUSH unit Unit }"+       ~: "0x0502000000160743036a00050743036c030b034d03200743036c030b"+    , "{ ADDRESS; DROP; PUSH unit Unit }"+       ~: "0x05020000000a035403200743036c030b"+    ]++  parsePackSpec @('Tc 'CKeyHash) @'TUnit "instrs key-hash-related"+    [ "{ SOME; SET_DELEGATE; DROP; PUSH unit Unit }"+       ~: "0x05020000000c0346034e03200743036c030b"+    , "{ DUP; DIP{ SOME; DIP{ PUSH mutez 5; PUSH bool True } }; \+        \CREATE_ACCOUNT; DROP; DROP; PUSH unit Unit \+      \}"+       ~: "0x05020000002a0321051f02000000150346051f020000000c0743036a00\+          \0507430359030a031c032003200743036c030b"+    , "{ DUP; DIP{ SOME; DIP{ PUSH unit Unit; PUSH mutez 5; PUSH bool True; DUP } }; \+       \ CREATE_CONTRACT{ \+       \   parameter unit; \+       \   storage unit; \+       \   code { DROP; UNIT; NIL operation; PAIR } \+       \  }; \+       \ DROP; DROP; PUSH unit Unit \+       \}"+       ~: "0x0502000000500321051f020000001d0346051f02000000140743036c030\+          \b0743036a000507430359030a0321051d02000000190500036c0501036c050\+          \2020000000a0320034f053d036d0342032003200743036c030b"+    , "{ IMPLICIT_ACCOUNT; DROP; PUSH unit Unit }"+       ~: "0x05020000000a031e03200743036c030b"+    ]++  parsePackSpec @'TKey @('Tc 'CKeyHash) "instrs public-key-related"+    [ "{ HASH_KEY }"+       ~: "0x050200000002032b"+    ]++  parsePackSpec @('TPair 'TSignature 'TKey) @('Tc 'CBool) "instrs public-key-related"+    [ "{ DIP{ PUSH bytes 0x }; DUP; DIP {CAR}; CDR; CHECK_SIGNATURE }"+       ~: "0x05020000001f051f0200000009074303690a000000000321051f020000\+          \0002031603170318"+    ]++typesTest :: Spec+typesTest = do+  -- Bytes we compare agains are produced with command+  -- ./alphanet.sh client hash data '{ LAMBDA ($ty) ($ty) {}; DROP }' of type 'lambda unit unit' /+  --     | tr -d '\n' | awk '{ print $45 }' | sed 's/Hash://'++  parsePackSpec @'TUnit @'TUnit "types"+    [ lambdaWrap "int"+        ~: "0x050200000015093100000009035b035b0200000000000000000320"+    , lambdaWrap "nat"+        ~: "0x050200000015093100000009036203620200000000000000000320"+    , lambdaWrap "string"+        ~: "0x050200000015093100000009036803680200000000000000000320"+    , lambdaWrap "bytes"+        ~: "0x050200000015093100000009036903690200000000000000000320"+    , lambdaWrap "mutez"+        ~: "0x050200000015093100000009036a036a0200000000000000000320"+    , lambdaWrap "bool"+        ~: "0x050200000015093100000009035903590200000000000000000320"+    , lambdaWrap "key_hash"+        ~: "0x050200000015093100000009035d035d0200000000000000000320"+    , lambdaWrap "timestamp"+        ~: "0x050200000015093100000009036b036b0200000000000000000320"+    , lambdaWrap "address"+        ~: "0x050200000015093100000009036e036e0200000000000000000320"+    , lambdaWrap "key"+        ~: "0x050200000015093100000009035c035c0200000000000000000320"+    , lambdaWrap "unit"+        ~: "0x050200000015093100000009036c036c0200000000000000000320"+    , lambdaWrap "signature"+        ~: "0x050200000015093100000009036703670200000000000000000320"+    , lambdaWrap "option unit"+        ~: "0x05020000001909310000000d0563036c0563036c0200000000000000000320"+    , lambdaWrap "set int"+        ~: "0x05020000001909310000000d0566035b0566035b0200000000000000000320"+    , lambdaWrap "operation"+        ~: "0x050200000015093100000009036d036d0200000000000000000320"+    , lambdaWrap "contract unit"+        ~: "0x05020000001909310000000d055a036c055a036c0200000000000000000320"+    , lambdaWrap "pair unit int"+        ~: "0x05020000001d0931000000110765036c035b0765036c035b0200000000000000000320"+    , lambdaWrap "or unit int"+        ~: "0x05020000001d0931000000110764036c035b0764036c035b0200000000000000000320"+    , lambdaWrap "lambda unit int"+        ~: "0x05020000001d093100000011075e036c035b075e036c035b0200000000000000000320"+    , lambdaWrap "map int unit"+        ~: "0x05020000001d0931000000110760035b036c0760035b036c0200000000000000000320"+    , lambdaWrap "big_map int unit"+        ~: "0x05020000001d0931000000110761035b036c0761035b036c0200000000000000000320"+    ]+  where+    lambdaWrap ty = "{ LAMBDA " <> ty <> " " <> ty <> " {}; DROP }"++unpackNegTest :: Spec+unpackNegTest = do+  describe "Bad entries order" $ do+    unpackNegSpec @('TSet 'CInt) "Unordered set elements"+      "0x050200000006000300020001"  -- { 3; 2; 1 }+    unpackNegSpec @('TMap 'CInt $ 'Tc 'CInt) "Unordered map elements"+      "0x05020000000c070400020006070400010007"  -- { Elt 2 6; Elt 1 7 }++  describe "Wron length specified" $ do+    unpackNegSpec @('TList $ 'Tc 'CInt) "Too few list length"+      "0x05020000000300010002"  -- { 1; 2 }+    unpackNegSpec @('TList $ 'Tc 'CInt) "Too big list length"+      "0x05020000000500010002"  -- { 1; 2 }+    unpackNegSpec @('TList $ 'Tc 'CInt) "Wrong bytes length"+      "0x050b000000021234"  -- 0x1234++  describe "Type check failures" $ do+    unpackNegSpec @('TUnit) "Value type mismatch"+      "0x050008"  -- 8+    unpackNegSpec @('TLambda 'TUnit 'TKey) "Lambda type mismatch"+      "0x050200000000"  -- {}+    unpackNegSpec @('TLambda 'TUnit 'TKey) "Lambda too large output stack size"+      "0x0502000000060743035b0005"  -- {PUSH int 5}+    unpackNegSpec @('TLambda 'TUnit 'TKey) "Lambda empty output stack size"+      "0x0502000000020320"  -- {DROP}
+ test/Test/Tasty/HUnit.hs view
@@ -0,0 +1,52 @@+-- | HUnit support for tasty.+--+-- We don't use `tasty-hunit`, because it doesn't interoperate properly with+-- other HUnit-based code.+-- Specifically, it defines its own `HUnitFailure` type and catches exceptions+-- of this type. It doesn't catch HUnit's `HUnitFailure`, so they are not+-- pretty-printed.++module Test.Tasty.HUnit+  ( testCase+  , testCaseInfo+  , testCaseSteps+  ) where++import Test.HUnit (Assertion)+import Test.HUnit.Lang (HUnitFailure(..), formatFailureReason)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Providers (IsTest(..), singleTest, testFailed, testPassed)++-- | Turn an 'Assertion' into a tasty test case+testCase :: TestName -> Assertion -> TestTree+testCase name = singleTest name . TestCaseWrapper . fmap (const "")++testCaseInfo :: TestName -> IO String -> TestTree+testCaseInfo name = singleTest name . TestCaseWrapper++-- We don't use this feature, so it's the same as simple 'testCase'.+testCaseSteps :: TestName -> ((String -> IO ()) -> Assertion) -> TestTree+testCaseSteps name f = testCase name (f $ const pass)++newtype TestCaseWrapper = TestCaseWrapper (IO String)++instance IsTest TestCaseWrapper where+  run _ (TestCaseWrapper assertion) _ = do+  -- The standard HUnit's performTestCase catches (almost) all exceptions.+  --+  -- This is bad for a few reasons:+  -- - it interferes with timeout handling+  -- - it makes exception reporting inconsistent across providers+  -- - it doesn't provide enough information for ingredients such as+  -- tasty-rerun+  --+  -- So we do it ourselves.+    hunitResult <- try @_ @HUnitFailure assertion+    return $+      case hunitResult of+        Right info -> testPassed info+        Left (HUnitFailure mbLoc reason) ->+          testFailed $ maybe id (mappend . (<> ":\n") . prettySrcLoc) mbLoc $+          formatFailureReason reason++  testOptions = return []
test/Test/Tezos/Address.hs view
@@ -1,27 +1,33 @@ -- | Tests for 'Tezos.Address'.  module Test.Tezos.Address-  ( spec+  ( test_Roundtrip+  , test_parseAddress   ) where -import Test.Hspec (Spec, describe, it, shouldSatisfy)+import Test.Hspec (shouldSatisfy)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)  import Tezos.Address (Address, formatAddress, parseAddress) -import Test.Util.QuickCheck (ShowThroughBuild(..), aesonRoundtrip, roundtripSpecSTB)+import Test.Util.QuickCheck (ShowThroughBuild(..), aesonRoundtrip, roundtripTestSTB) -spec :: Spec-spec = describe "Tezos.Address" $ do-  describe "parseAddress" $ do-    it "Successfully parses valid sample data" $-      forM_ sampleAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isRight)-    it "Fails to parse invalid data" $ do-      forM_ invalidAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isLeft)-    describe "Formatting" $ do-      describe "Roundtrip (parse . format ≡ pure)" $ do-        roundtripSpecSTB formatAddress parseAddress-      describe "Roundtrip (JSON encoding/deconding)" $ do-        aesonRoundtrip @Address+test_Roundtrip :: [TestTree]+test_Roundtrip =+    [ testGroup "parse . format ≡ pure"+      [ roundtripTestSTB formatAddress parseAddress ]+    , testGroup "JSON encoding/deconding"+      [ aesonRoundtrip @Address ]+    ]++test_parseAddress :: [TestTree]+test_parseAddress =+  [ testCase "Successfully parses valid sample data" $+    forM_ sampleAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isRight)+  , testCase "Fails to parse invalid data" $ do+    forM_ invalidAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isLeft)+  ]   where     sampleAddresses =       [ "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"
test/Test/Tezos/Crypto.hs view
@@ -1,60 +1,68 @@ -- | Tests for 'Tezos.Crypto'.  module Test.Tezos.Crypto-  ( spec+  ( test_Roundtrip+  , test_Signing+  , test_Bytes_Hashing+  , unit_Key_Hashing   ) where  import Fmt (fmt, hexF, pretty)-import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)+import Test.Hspec (Expectation, shouldSatisfy)+import Test.HUnit (Assertion, (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)  import Tezos.Crypto -import Test.Util.QuickCheck (aesonRoundtrip, roundtripSpecSTB)+import Test.Util.QuickCheck (aesonRoundtrip, roundtripTestSTB) -spec :: Spec-spec = describe "Tezos.Crypto" $ do-  describe "Signing" $ do-    describe "Formatting" $ do-      describe "parsePublicKey" $ do-        it "Successfully parses valid sample data" $-          mapM_ (parsePublicKeySample . sdPublicKey) sampleSignatures-        it "Fails to parse invalid data" $ do-          parsePublicKeyInvalid "aaa"-          parsePublicKeyInvalid-            "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3v"-          parsePublicKeyInvalid-            "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"-      describe "parseSignature" $ do-        it "Successfully parses valid sample data" $-          mapM_ (parseSignatureSample . sdSignature) sampleSignatures-        it "Fails to parse invalid data" $ do-          parseSignatureInvalid "bbb"-          parseSignatureInvalid-            "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"-          parseSignatureInvalid-            "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vB"-      describe "Roundtrip (parse . format ≡ pure)" $ do-        roundtripSpecSTB formatPublicKey parsePublicKey-        roundtripSpecSTB formatSecretKey parseSecretKey-        roundtripSpecSTB formatSignature parseSignature-        roundtripSpecSTB formatKeyHash parseKeyHash-      describe "Roundtrip (JSON encoding/deconding)" $ do-        aesonRoundtrip @PublicKey-        aesonRoundtrip @Signature-        aesonRoundtrip @KeyHash-    describe "checkSignature" $ do-      it "Works on sample data" $ mapM_ checkSignatureSample sampleSignatures-  describe "Bytes hashing" $ do-    hashingSpec "blake2b" blake2b blake2bHashes-    hashingSpec "sha256" sha256 sha256Hashes-    hashingSpec "sha512" sha512 sha512Hashes-  describe "Key hashing" $-    it "Works on sample data" $ mapM_ hashKeySample sampleKeyHashes+test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ testGroup "parse . format ≡ pure"+    [ roundtripTestSTB formatPublicKey parsePublicKey+    , roundtripTestSTB formatSecretKey parseSecretKey+    , roundtripTestSTB formatSignature parseSignature+    , roundtripTestSTB formatKeyHash parseKeyHash+    ]+  , testGroup "JSON encoding/deconding"+    [ aesonRoundtrip @PublicKey+    , aesonRoundtrip @Signature+    , aesonRoundtrip @KeyHash+    ]+  ]  ---------------------------------------------------------------------------- -- Signing ---------------------------------------------------------------------------- +test_Signing :: [TestTree]+test_Signing =+  [ testGroup "Formatting"+      [ testGroup "parsePublicKey"+        [ testCase "Successfully parses valid sample data" $+          mapM_ (parsePublicKeySample . sdPublicKey) sampleSignatures+        , testCase "Fails to parse invalid data" $ do+            parsePublicKeyInvalid "aaa"+            parsePublicKeyInvalid+              "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3v"+            parsePublicKeyInvalid+              "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"+        ]+      , testGroup "parseSignature"+        [ testCase "Successfully parses valid sample data" $+          mapM_ (parseSignatureSample . sdSignature) sampleSignatures+        , testCase "Fails to parse invalid data" $ do+            parseSignatureInvalid "bbb"+            parseSignatureInvalid+              "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"+            parseSignatureInvalid+              "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vB"+        ]+      ]+  , testCase "checkSignature" $ mapM_ checkSignatureSample sampleSignatures+  ]+ data SignatureData = SignatureData   { sdPublicKey :: !Text   , sdBytes :: !ByteString@@ -101,9 +109,9 @@ parseSignatureInvalid invalidSignatureText =   parseSignature invalidSignatureText `shouldSatisfy` isLeft -checkSignatureSample :: SignatureData -> Expectation+checkSignatureSample :: SignatureData -> Assertion checkSignatureSample sd =-  checkSignature publicKey signature (sdBytes sd) `shouldBe` sdValid sd+  checkSignature publicKey signature (sdBytes sd) @?= sdValid sd   where     publicKey = partialParse parsePublicKey (sdPublicKey sd)     signature = partialParse parseSignature (sdSignature sd)@@ -112,6 +120,13 @@ -- Hashing ---------------------------------------------------------------------------- +test_Bytes_Hashing :: [TestTree]+test_Bytes_Hashing =+  [ testGroup "blake2b" $ hashingTest blake2b blake2bHashes+  , testGroup "sha256" $ hashingTest sha256 sha256Hashes+  , testGroup "sha512" $ hashingTest sha512 sha512Hashes+  ]+ -- These values have been computed using the following contract: {- parameter string;@@ -135,17 +150,19 @@   , ("#", "d369286ac86b60fa920f6464d26becacd9f4c8bd885b783407cdcaa74fafd45a8b56b364b63f6256c3ceef26278a1c7799d4243a8149b5ede5ce1d890b5c7236")  -- 0x23   ] -hashingSpec :: String -> (ByteString -> ByteString) -> [(ByteString, Text)] -> Spec-hashingSpec funcName hashFunc pairs = do-  describe funcName $ do-    forM_ pairs $ \(bs, bsHashHex) -> do-      it ("correctly computes hash of 0x" <> fmt (hexF bs)) $-        fmt (hexF (hashFunc bs)) `shouldBe` bsHashHex+hashingTest :: (ByteString -> ByteString) -> [(ByteString, Text)] -> [TestTree]+hashingTest hashFunc pairs = do+  flip map pairs $ \(bs, bsHashHex) -> do+    testCase ("correctly computes hash of 0x" <> fmt (hexF bs)) $+      fmt (hexF (hashFunc bs)) @?= bsHashHex  ---------------------------------------------------------------------------- -- Key hashing ---------------------------------------------------------------------------- +unit_Key_Hashing :: Assertion+unit_Key_Hashing = mapM_ hashKeySample sampleKeyHashes+ sampleKeyHashes :: [(Text, Text)] sampleKeyHashes =   [ ("edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH"@@ -156,8 +173,8 @@     )   ] -hashKeySample :: (Text, Text) -> Expectation-hashKeySample (pkText, keyHashText) = hashKey pk `shouldBe` keyHash+hashKeySample :: (Text, Text) -> Assertion+hashKeySample (pkText, keyHashText) = hashKey pk @?= keyHash   where     pk = partialParse parsePublicKey pkText     keyHash = partialParse parseKeyHash keyHashText
test/Test/Typecheck.hs view
@@ -1,39 +1,200 @@+{-# LANGUAGE ViewPatterns #-}+ module Test.Typecheck-  ( typeCheckSpec+  ( unit_Good_contracts+  , unit_Bad_contracts+  , test_OriginatedContracts+  , test_srcPosition+  , unit_Unreachable_code+  , test_Roundtrip+  , test_StackRef+  , test_TCTypeError_display   ) where -import Test.Hspec (Expectation, Spec, describe, expectationFailure, it)+import Data.Default (def)+import qualified Data.Kind as Kind+import qualified Data.Map as M+import Data.Singletons (SingI(..))+import Data.Typeable (typeRep)+import Fmt (build, pretty)+import Test.Hspec (expectationFailure)+import Test.Hspec.Expectations (Expectation)+import Test.HUnit (Assertion, assertFailure, (@?=))+import Test.QuickCheck (Arbitrary, property, total, within)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty) -import Michelson.Untyped (UntypedContract)-import Morley.Ext (typeCheckMorleyContract)-import Morley.Runtime (prepareContract)+import Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..), srcPos)+import Michelson.Runtime (prepareContract)+import Michelson.Test.Gen ()+import Michelson.Test.Import (ImportContractError(..), readContract)+import Michelson.TypeCheck+import qualified Michelson.Typed as T+import Michelson.Untyped (CT(..), T(..), Type(..), noAnn)+import qualified Michelson.Untyped as Un+import Tezos.Address (Address, unsafeParseAddress)+import Tezos.Core (Timestamp)+import Util.IO (readFileUtf8)  import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts) -typeCheckSpec :: Spec-typeCheckSpec = describe "Typechecker tests" $ do-  it "Successfully typechecks contracts examples from contracts/" goodContractsTest-  it "Reports errors on contracts examples from contracts/ill-typed" badContractsTest+unit_Good_contracts :: Assertion+unit_Good_contracts = mapM_ (\f -> checkFile [] True f (const pass)) =<< getWellTypedContracts++unit_Bad_contracts :: Assertion+unit_Bad_contracts = mapM_ (\f -> checkFile [] False f (const pass)) =<< getIllTypedContracts++test_OriginatedContracts :: [TestTree]+test_OriginatedContracts =+  [ testCase "Successfully typechecked PUSH contract considering originated contracts" $ do+    checkFile' [(cAddr, tPair intP intQ)] True pushContrFile+    checkFile' [(cAddr, tPair int intQ)] True pushContrFile+    checkFile' [(cAddr, tPair int int)] True pushContrFile+  , testCase "Report an error on PUSH contract because of mismatched types" $ do+    checkFile' [(cAddr, tPair intP intP)] False pushContrFile+    checkFile' [(cAddr, tPair intQ intQ)] False pushContrFile+    checkFile' [(cAddr, tPair string intQ)] False pushContrFile+  ]   where-    doTC = either (Left . displayException) (\_ -> pure ()) .-            typeCheckMorleyContract+    checkFile' a b f = checkFile a b f (const pass)+    pushContrFile = "contracts/ill-typed/push_contract.tz"+    tPair t1 t2 = Type (TPair noAnn noAnn t1 t2) noAnn+    intP = Type (Tc CInt) "p"+    intQ = Type (Tc CInt) "q"+    int = Type (Tc CInt) noAnn+    string = Type (Tc CString) noAnn+    cAddr = unsafeParseAddress "KT1WsLzQ61xtMNJHfwgCHh2RnALGgFAzeSx9" -    goodContractsTest = mapM_ (checkFile doTC True) =<< getWellTypedContracts+pattern IsSrcPos :: Word -> Word -> InstrCallStack+pattern IsSrcPos l c <- InstrCallStack [] (SrcPos (Pos l) (Pos c)) -    badContractsTest = mapM_ (checkFile doTC False) =<< getIllTypedContracts+test_srcPosition :: [TestTree]+test_srcPosition =+  [ testProperty "Verify instruction position in a typecheck error" $ do+      checkIllFile "contracts/ill-typed/basic3.tz" $ \case+          TCFailedOnInstr (Un.CONS _) _ _ (IsSrcPos 4 6) (Just (AnnError _)) -> True+          _ -> False +      checkIllFile "contracts/ill-typed/testassert_invalid_stack3.mtz" $ \case+          TCFailedOnInstr Un.DROP _ _ (IsSrcPos 6 17) Nothing -> True+          _ -> False -checkFile :: (UntypedContract -> Either String ()) -> Bool -> FilePath -> Expectation-checkFile doTypeCheck wellTyped file = do+      checkIllFile "contracts/ill-typed/testassert_invalid_stack2.mtz" $ \case+          TCExtError _ (IsSrcPos 5 2) (TestAssertError _) -> True+          _ -> False++      checkIllFile "contracts/ill-typed/macro_in_let_fail.mtz" $ \case+          TCFailedOnInstr (Un.COMPARE _) _ _ (InstrCallStack [LetName "cmpLet"] (SrcPos (Pos 3) (Pos 6)))+                                              (Just (UnsupportedTypes _)) -> True+          _ -> False+  ]+  where+    unexpected f e =+      expectationFailure $ "Unexpected typecheck error: " <> displayException e <> " in file: " <> f+    checkIllFile file check = checkFile [] False file $+      \e -> if check e then pass else unexpected file e++checkFile+  :: [(Address, Type)]+  -> Bool+  -> FilePath+  -> (TCError -> Expectation)+  -> Expectation+checkFile originatedContracts wellTyped file onError = do   c <- prepareContract (Just file)-  case doTypeCheck c of+  case doTC c of     Left err       | wellTyped ->         expectationFailure $-        "Typechecker unexpectedly failed on " <> show file <> ": " <> err-      | otherwise -> pass+        "Typechecker unexpectedly failed on " <> show file <> ": " <> displayException err+      | otherwise -> onError err     Right _       | not wellTyped ->-        expectationFailure $+        assertFailure $         "Typechecker unexpectedly considered " <> show file <> " well-typed."       | otherwise -> pass+  where+    doTC = typeCheckContract (M.fromList originatedContracts)++unit_Unreachable_code :: Assertion+unit_Unreachable_code = do+  let file = "contracts/ill-typed/fail_before_nop.tz"+  let ics = InstrCallStack [] (srcPos 3 13)+  econtract <- readContract @'T.TUnit @'T.TUnit file <$> readFileUtf8 file+  econtract @?= Left (ICETypeCheck $ TCUnreachableCode ics (one $ Un.WithSrcEx ics $ Un.SeqEx []))++test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ testGroup "Value"+    [ roundtripValue @Integer+    , roundtripValue @Timestamp+    ]+  ]+  where+  roundtripValue+    :: forall (a :: Kind.Type).+        ( Each [Typeable, SingI, T.HasNoOp] '[T.ToT a]+        , Typeable a, Arbitrary (T.Value $ T.ToT a)+        )+    => TestTree+  roundtripValue =+    testProperty (show $ typeRep (Proxy @a)) $+      property $ \(val :: T.Value (T.ToT a)) ->+        let uval = T.untypeValue val+            runTC = runTypeCheckTest . usingReaderT (def @InstrCallStack)+        in case runTC $ typeVerifyValue uval of+            Right got -> got @?= val+            Left err -> expectationFailure $+                        "Type check unexpectedly failed: " <> pretty err++test_StackRef :: [TestTree]+test_StackRef =+  [ testProperty "Typecheck fails when ref is out of bounds" $+      let instr = printStRef 2+          hst = stackEl ::& stackEl ::& SNil+      in case+          runTypeCheck (error "no contract param") mempty $+          typeCheckList [Un.WithSrcEx def $ Un.PrimEx instr] hst+          of+            Left err -> total $ show @Text err+            Right _ -> error "Typecheck unexpectedly succeded"+  , testProperty "Typecheck time is reasonably bounded" $ within 1000 $+    -- Making code processing performance scale with code size looks like a+    -- good property, so we'd like to avoid scenario when user tries to+    -- access 100500-th element of stack and typecheck hangs as a result+    let instr = printStRef 100000000000+        hst = stackEl ::& SNil+    in case+        runTypeCheck (error "no contract param") mempty $+        typeCheckList [Un.WithSrcEx def $ Un.PrimEx instr] hst+      of+        Left err -> total $ show @Text err+        Right _ -> error "Typecheck unexpectedly succeded"+  ]+  where+    printStRef i = Un.EXT . Un.UPRINT $ Un.PrintComment [Right (Un.StackRef i)]+    stackEl = (sing @'T.TUnit, T.NStar, noAnn)++test_TCTypeError_display :: [TestTree]+test_TCTypeError_display =+  -- One may say that it's madness to write tests on 'Buildable' instances,+  -- but IMO (martoon) it's worth resulting duplication because tests allow+  -- avoiding silly errors like lost spaces and ensuring general sanity+  -- of used way to display content.+  [ testCase "TypeEqError" $+      build (TypeEqError T.TUnit T.TKey)+      @?= "Types not equal: unit /= key"++  , testCase "StackEqError" $+      build (StackEqError [T.TUnit, T.Tc T.CBytes] [])+      @?= "Stacks not equal: [unit, bytes] /= []"++  , testCase "UnsupportedTypes" $+      build (UnsupportedTypes [T.TUnit])+      @?= "Unsupported types: [unit]"++  , testCase "Unknown type" $+      build (UnknownType T.TUnit)+      @?= "Unknown type `unit`"+  ]
+ test/Test/Untyped/Instr.hs view
@@ -0,0 +1,43 @@+-- | Tests for 'Michelson.Untyped.Instr'.++module Test.Untyped.Instr+  ( unit_Flattening+  ) where++import Test.HUnit (Assertion, (@?=))++import Michelson.Untyped.Instr++unit_Flattening :: Assertion+unit_Flattening = flattenExpandedOp sampleOp @?= expectedInstrs+  where+    sampleOp :: ExpandedOp+    sampleOp = SeqEx+      [ toSeq []+      , toSeq seq1+      , toPrim prim3+      ]++    toPrim :: ExpandedInstr -> ExpandedOp+    toPrim = PrimEx+    toSeq :: [ExpandedInstr] -> ExpandedOp+    toSeq = SeqEx . map PrimEx++    seq1 = [prim1, prim2]+    prim1 = DROP+    prim2 = SWAP+    prim3 = DIP+      [ toPrim prim1+      , toSeq seq1+      , toSeq seq1+      , toSeq []+      , SeqEx [toSeq seq1, toSeq seq1]+      ]++    expectedInstrs :: [ExpandedInstr]+    expectedInstrs =+      [ prim1+      , prim2+      , DIP $ map toPrim $+        prim1 : mconcat (replicate 4 seq1)+      ]
test/Test/Util/Contracts.hs view
@@ -3,6 +3,8 @@ module Test.Util.Contracts        ( getIllTypedContracts        , getWellTypedContracts+       , getWellTypedMichelsonContracts+       , getWellTypedMorleyContracts        ) where  import Data.List (isSuffixOf)@@ -10,16 +12,27 @@ import System.FilePath ((</>))  getIllTypedContracts :: IO [FilePath]-getIllTypedContracts = getContracts "contracts/ill-typed"+getIllTypedContracts =+  concatMapM (flip getContractsWithExtension "contracts/ill-typed")+  [".tz", ".mtz"]  getWellTypedContracts :: IO [FilePath]-getWellTypedContracts = getContracts "contracts"+getWellTypedContracts = getWellTypedMichelsonContracts <> getWellTypedMorleyContracts -getContracts :: FilePath -> IO [FilePath]-getContracts dir = mapMaybe convertPath <$> listDirectory dir+getWellTypedMichelsonContracts :: IO [FilePath]+getWellTypedMichelsonContracts = concatMapM (getContractsWithExtension ".tz") wellTypedContractDirs++getWellTypedMorleyContracts :: IO [FilePath]+getWellTypedMorleyContracts = concatMapM (getContractsWithExtension ".mtz") wellTypedContractDirs++getContractsWithExtension :: String -> FilePath -> IO [FilePath]+getContractsWithExtension ext dir = mapMaybe convertPath <$> listDirectory dir   where     convertPath :: FilePath -> Maybe FilePath     convertPath fileName-      | (isSuffixOf ".tz" fileName) || (isSuffixOf ".mtz" fileName) =+      | (ext `isSuffixOf` fileName) =         Just (dir </> fileName)       | otherwise = Nothing++wellTypedContractDirs :: [FilePath]+wellTypedContractDirs = ["contracts", "contracts/A1", "contracts/tezos_examples"]
+ test/Test/Util/Parser.hs view
@@ -0,0 +1,17 @@+module Test.Util.Parser+  ( shouldParse+  ) where++import Test.HUnit.Base (assertFailure)+import Text.Megaparsec (errorBundlePretty)++import Michelson.Parser (Parser)+import qualified Michelson.Parser as Parser++-- | Expect the given text to be successfully parsed.+shouldParse :: Parser a -> Text -> IO a+shouldParse parser text =+  case Parser.parseNoEnv parser (toString text) text of+    Left err -> assertFailure (errorBundlePretty err)+    Right res -> return res+infix 2 `shouldParse`
test/Test/Util/QuickCheck.hs view
@@ -27,23 +27,21 @@   ( ShowThroughBuild (..)    -- * Roundtrip properties-  , roundtripSpec-  , roundtripSpecSTB+  , roundtripTest+  , roundtripADTTest+  , roundtripTestSTB   , aesonRoundtrip--  -- * 'Gen' helpers-  , runGen   ) where  import Data.Aeson (FromJSON(..), ToJSON(..)) import qualified Data.Aeson as Aeson import Data.Typeable (typeRep) import Fmt (Buildable, pretty)-import Test.Hspec (Spec)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Arbitrary, Property, (===))-import Test.QuickCheck.Gen (Gen, unGen)-import Test.QuickCheck.Random (mkQCGen)+import Test.QuickCheck (Arbitrary, forAll, resize)+import Test.QuickCheck.Arbitrary.ADT+  (ADTArbitrary(..), ConstructorArbitraryPair(..), ToADTArbitrary(..))+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (Property, testProperty, (.&&.), (===)) import qualified Text.Show (show)  ----------------------------------------------------------------------------@@ -65,51 +63,65 @@ -- Formatting ---------------------------------------------------------------------------- --- | This 'Spec' contains a property based test for conversion from+-- | This 'TestTree' contains a property based test for conversion from -- some @x@ to some @y@ and back to @x@ (it should successfully return -- the initial @x@).-roundtripSpec ::+roundtripTest ::      forall x y err.      ( Show x+     , Show err      , Typeable x      , Arbitrary x      , Eq x-     , Show err      , Eq err      )   => (x -> y)   -> (y -> Either err x)-  -> Spec-roundtripSpec xToY yToX = prop typeName check+  -> TestTree+roundtripTest xToY yToX = testProperty typeName check   where     typeName = show $ typeRep (Proxy @x)     check :: x -> Property     check x = yToX (xToY x) === Right x --- | Version of 'roundtripSpec' which shows values using 'Buildable' instance.-roundtripSpecSTB ::+roundtripADTTest ::      forall x y err.+     ( Show x+     , Show err+     , Typeable x+     , ToADTArbitrary x+     , Eq x+     , Eq err+     )+  => (x -> y)+  -> (y -> Either err x)+  -> TestTree+roundtripADTTest xToY yToX = testProperty typeName prop+  where+    prop :: Property+    prop =+      forAll (resize 1 $ toADTArbitrary (Proxy @x)) $ \adt ->+        foldr ((.&&.) . check . capArbitrary) z (adtCAPs adt)+    typeName = show $ typeRep (Proxy @x)+    check x = yToX (xToY x) === Right x+    z = True === True++-- | Version of 'roundtripTest' which shows values using 'Buildable' instance.+roundtripTestSTB ::+     forall x y err.      ( Show (ShowThroughBuild x)+     , Show (ShowThroughBuild err)      , Typeable x      , Arbitrary x      , Eq x-     , Show (ShowThroughBuild err)      , Eq err      )   => (x -> y)   -> (y -> Either err x)-  -> Spec-roundtripSpecSTB xToY yToX = roundtripSpec (xToY . unSTB) (bimap STB STB . yToX)+  -> TestTree+roundtripTestSTB xToY yToX = roundtripTest (xToY . unSTB) (bimap STB STB . yToX)  aesonRoundtrip ::      forall x. (Show (ShowThroughBuild x), ToJSON x, FromJSON x, Typeable x, Arbitrary x, Eq x)-  => Spec-aesonRoundtrip = roundtripSpecSTB (Aeson.encode @x) Aeson.eitherDecode--------------------------------------------------------------------------------- Gen--------------------------------------------------------------------------------- | Get something out of a quickcheck 'Gen' without having to do IO-runGen :: Gen a -> a-runGen g = unGen g (mkQCGen 31415926) 30+  => TestTree+aesonRoundtrip = roundtripTestSTB (Aeson.encode @x) Aeson.eitherDecode
test/Test/ValConversion.hs view
@@ -1,55 +1,55 @@-{-# OPTIONS_GHC -Wno-orphans #-}- -- | Testing of toVal / fromVal conversions  module Test.ValConversion-  ( spec+  ( test_Roundtrip+  , unit_toVal   ) where -import Test.Hspec (Spec, describe, it, shouldBe)+import Test.HUnit (Assertion, (@?)) import Test.QuickCheck (Arbitrary)--import Michelson.Typed (CVal(..), FromVal, ToT, ToVal, Val(..), fromVal, toVal)+import Test.Tasty (TestTree) -import Test.Util.QuickCheck (roundtripSpec)+import Michelson.Typed (CValue(..), IsoValue(..), ToT, Value, Value'(..)) --- | Spec to test toVal / fromVal conversions.-spec :: Spec-spec = do-  describe "ToVal / FromVal tests" $ do-    it "ToVal / FromVal manual tests" $ do-      check () $ (\case VUnit -> True;)-      check (10 :: Integer) $ (\case (VC (CvInt 10)) -> True; _ -> False)-      check ("abc" :: Text) $ (\case (VC (CvString "abc")) -> True; _ -> False)-      check (Just "abc" :: Maybe Text)-          $ (\case (VOption (Just (VC (CvString "abc")))) -> True; _ -> False)-      check (Left "abc" :: Either Text Text)-          $ (\case (VOr (Left (VC (CvString "abc")))) -> True; _ -> False)-      check (Left "abc" :: Either Text Integer)-          $ (\case (VOr (Left (VC (CvString "abc")))) -> True; _ -> False)-      check ((10, "abc") :: (Integer, Text))-          $ (\case (VPair (VC (CvInt 10), VC (CvString "abc"))) -> True; _ -> False)-      check (["abc", "cde"] :: [Text])-          $ (\case (VList [ VC (CvString "abc")-                          , VC (CvString "cde")]) -> True; _ -> False)+import Test.Util.QuickCheck (roundtripTest) -    describe "ToVal / FromVal property tests" $ do-      roundtrip @Integer-      roundtrip @Bool-      roundtrip @[Bool]-      roundtrip @(Maybe Integer)-      roundtrip @(Maybe (Maybe Integer))-      roundtrip @(Either Bool Integer)-      roundtrip @(Set Integer)-      roundtrip @(Set Integer)-      roundtrip @(Set Bool)-      roundtrip @(Map Integer Integer)-      roundtrip @(Map Integer Bool)-      roundtrip @(Map Integer (Maybe (Either Bool Bool)))+-- | TestTrees to test toVal / fromVal conversions (roundtrip)+test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ roundtrip @Integer+  , roundtrip @Bool+  , roundtrip @[Bool]+  , roundtrip @(Maybe Integer)+  , roundtrip @(Maybe (Maybe Integer))+  , roundtrip @(Either Bool Integer)+  , roundtrip @(Set Integer)+  , roundtrip @(Set Integer)+  , roundtrip @(Set Bool)+  , roundtrip @(Map Integer Integer)+  , roundtrip @(Map Integer Bool)+  , roundtrip @(Map Integer (Maybe (Either Bool Bool)))+  ]   where-    check :: ToVal a => a -> (Val instr (ToT a) -> Bool) -> IO ()-    check v p = p (toVal v) `shouldBe` True-     roundtrip :: forall a.-      (Show a, Eq a, Arbitrary a, Typeable a, ToVal a, FromVal a) => Spec-    roundtrip = roundtripSpec @a @_ @Void toVal (Right . fromVal)+      (Show a, Eq a, Arbitrary a, Typeable a, IsoValue a) => TestTree+    roundtrip = roundtripTest @a @_ @Void toVal (Right . fromVal)++unit_toVal :: Assertion+unit_toVal = do+  check () $ (\case VUnit -> True;)+  check (10 :: Integer) $ (\case (VC (CvInt 10)) -> True; _ -> False)+  check ("abc" :: ByteString) $ (\case (VC (CvBytes "abc")) -> True; _ -> False)+  check (Just "abc" :: Maybe ByteString)+    $ (\case (VOption (Just (VC (CvBytes "abc")))) -> True; _ -> False)+  check (Left "abc" :: Either ByteString ByteString)+    $ (\case (VOr (Left (VC (CvBytes "abc")))) -> True; _ -> False)+  check (Left "abc" :: Either ByteString Integer)+    $ (\case (VOr (Left (VC (CvBytes "abc")))) -> True; _ -> False)+  check ((10, "abc") :: (Integer, ByteString))+    $ (\case (VPair (VC (CvInt 10), VC (CvBytes "abc"))) -> True; _ -> False)+  check (["abc", "cde"] :: [ByteString])+    $ (\case (VList [ VC (CvBytes "abc")+                    , VC (CvBytes "cde")]) -> True; _ -> False)+  where+    check :: IsoValue a => a -> (Value (ToT a) -> Bool) -> Assertion+    check v p = p (toVal v) @? "toVal returned unexpected result"
+ test/Tree.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}