morley 1.4.0 → 1.5.0

raw patch · 112 files changed

+2834/−9663 lines, 112 filesdep +generic-derivingdep +haskelinedep −HUnitdep −base16-bytestringdep −criteriondep ~morley-preludePVP ok

version bump matches the API change (PVP)

Dependencies added: generic-deriving, haskeline

Dependencies removed: HUnit, base16-bytestring, criterion, directory, filepath, formatting, gauge, ghc-prim, hedgehog, hspec, hspec-expectations, o-clock, statistics, tasty, tasty-ant-xml, tasty-hedgehog, tasty-hspec, tasty-hunit-compat, tasty-quickcheck

Dependency ranges changed: morley-prelude

API changes (from Hackage documentation)

Files

• CHANGES.md +44/−8
• README.md +1/−7
• app/Main.hs +16/−16
• app/REPL.hs +233/−0
• bench/Main.hs +0/−74
• morley.cabal +14/−135
• src/Michelson/Doc.hs +15/−13
• src/Michelson/Doc/Test.hs +0/−243
• src/Michelson/Interpret.hs +14/−21
• src/Michelson/Interpret/Pack.hs +6/−9
• src/Michelson/Interpret/Unpack.hs +40/−127
• src/Michelson/Macro.hs +53/−25
• src/Michelson/OpSize.hs +1/−1
• src/Michelson/Parser.hs +54/−15
• src/Michelson/Parser/Macro.hs +16/−9
• src/Michelson/Parser/Value.hs +6/−5
• src/Michelson/Runtime.hs +15/−44
• src/Michelson/Runtime/GState.hs +65/−87
• src/Michelson/Test.hs +0/−113
• src/Michelson/Test/Dummy.hs +0/−62
• src/Michelson/Test/Gen.hs +0/−128
• src/Michelson/Test/Import.hs +0/−192
• src/Michelson/Test/Integrational.hs +0/−601
• src/Michelson/Test/Unit.hs +0/−135
• src/Michelson/Test/Util.hs +0/−251
• src/Michelson/Text.hs +2/−10
• src/Michelson/TypeCheck.hs +4/−2
• src/Michelson/TypeCheck/Error.hs +6/−6
• src/Michelson/TypeCheck/Helpers.hs +29/−11
• src/Michelson/TypeCheck/Instr.hs +86/−62
• src/Michelson/TypeCheck/TypeCheck.hs +64/−19
• src/Michelson/TypeCheck/Types.hs +57/−38
• src/Michelson/TypeCheck/Value.hs +188/−176
• src/Michelson/Typed.hs +1/−1
• src/Michelson/Typed/Arith.hs +38/−0
• src/Michelson/Typed/Convert.hs +3/−1
• src/Michelson/Typed/EntryPoints.hs +0/−478
• src/Michelson/Typed/Entrypoints.hs +512/−0
• src/Michelson/Typed/Haskell/Doc.hs +21/−6
• src/Michelson/Typed/Haskell/Instr/Sum.hs +1/−1
• src/Michelson/Typed/Haskell/Value.hs +11/−20
• src/Michelson/Typed/Instr.hs +24/−4
• src/Michelson/Typed/Polymorphic.hs +23/−0
• src/Michelson/Typed/Util.hs +27/−6
• src/Michelson/Typed/Value.hs +4/−4
• src/Michelson/Untyped.hs +1/−1
• src/Michelson/Untyped/Contract.hs +94/−7
• src/Michelson/Untyped/EntryPoints.hs +0/−128
• src/Michelson/Untyped/Entrypoints.hs +128/−0
• src/Michelson/Untyped/Type.hs +1/−1
• src/Michelson/Untyped/Value.hs +1/−1
• src/Morley/Micheline/Binary.hs +3/−2
• src/Morley/Micheline/Class.hs +60/−28
• src/Morley/Micheline/Expression.hs +23/−47
• src/Tezos/Address.hs +99/−60
• src/Tezos/Core.hs +9/−9
• src/Tezos/Crypto.hs +74/−37
• src/Tezos/Crypto/Ed25519.hs +0/−18
• src/Tezos/Crypto/P256.hs +53/−60
• src/Tezos/Crypto/Secp256k1.hs +16/−102
• src/Tezos/Crypto/Util.hs +119/−5
• src/Util/Binary.hs +67/−1
• src/Util/CustomGeneric.hs +381/−0
• src/Util/Exception.hs +2/−1
• src/Util/Named.hs +3/−8
• src/Util/Test/Arbitrary.hs +6/−4
• src/Util/Test/Gen.hs +0/−317
• src/Util/Test/Ingredients.hs +0/−18
• test/Main.hs +0/−16
• test/Test/Analyzer.hs +0/−56
• test/Test/EntryPoints.hs +0/−96
• test/Test/Ext.hs +0/−101
• test/Test/Integrational.hs +0/−36
• test/Test/Interpreter.hs +0/−333
• test/Test/Interpreter/Apply.hs +0/−39
• test/Test/Interpreter/Auction.hs +0/−142
• test/Test/Interpreter/Balance.hs +0/−107
• test/Test/Interpreter/CallSelf.hs +0/−111
• test/Test/Interpreter/ComparableSet.hs +0/−67
• test/Test/Interpreter/Compare.hs +0/−61
• test/Test/Interpreter/ComparePairs.hs +0/−64
• test/Test/Interpreter/Conditionals.hs +0/−62
• test/Test/Interpreter/ContractOp.hs +0/−77
• test/Test/Interpreter/EnvironmentSpec.hs +0/−122
• test/Test/Interpreter/StackRef.hs +0/−37
• test/Test/Interpreter/StringCaller.hs +0/−140
• test/Test/Macro.hs +0/−193
• test/Test/Michelson/Runtime.hs +0/−229
• test/Test/Michelson/Text.hs +0/−164
• test/Test/Michelson/Typed/Util.hs +0/−35
• test/Test/Michelson/Typed/Value.hs +0/−35
• test/Test/Morley/Expression.hs +0/−167
• test/Test/OpSize.hs +0/−277
• test/Test/Optimizer.hs +0/−163
• test/Test/Parser.hs +0/−312
• test/Test/Preprocess.hs +0/−60
• test/Test/Printer/Michelson.hs +0/−131
• test/Test/Serialization/Aeson.hs +0/−52
• test/Test/Serialization/Michelson.hs +0/−1093
• test/Test/Tezos/Address.hs +0/−54
• test/Test/Tezos/Core.hs +0/−80
• test/Test/Tezos/Crypto.hs +0/−217
• test/Test/Tezos/Crypto/Hash.hs +0/−52
• test/Test/Typeable.hs +0/−36
• test/Test/Typecheck.hs +0/−287
• test/Test/Untyped/Instr.hs +0/−47
• test/Test/Util/Contracts.hs +0/−83
• test/Test/Util/HUnit.hs +0/−18
• test/Test/Util/Hedgehog.hs +0/−91
• test/Test/Util/Parser.hs +0/−21
• test/Test/ValConversion.hs +0/−73
• test/Tree.hs +0/−5

@@ -1,6 +1,42 @@-Unreleased-==========-<!-- Append new entries here -->+1.5.0+=====+* [!509](https://gitlab.com/morley-framework/morley/-/merge_requests/509)+  Implement missing parts of `secp256k1` and `P256`.+  + `checkSignature` now works correctly with all signature formats.+* [!511](https://gitlab.com/morley-framework/morley/-/merge_requests/511)+  Add `zeroMutez` and `oneMutez` for safe initial values.+* [!500](https://gitlab.com/morley-framework/morley/-/merge_requests/500)+  Add ability to parse optimized formats of `signature`, `contract`, `key`, and `key_hash`.+* [!486](https://gitlab.com/morley-framework/morley/-/merge_requests/486)+  Add `Util.CustomGeneric` to derive `Generic` instances with a custom tree structure.+* [!466](https://gitlab.com/morley-framework/morley/-/merge_requests/466)+  Add sub-command 'repl' to Morley executable which starts an REPL that+  can execute Morley instructions.+* [!492](https://gitlab.com/morley-framework/morley/-/merge_requests/492)+  + `TypeHasDoc` instance for `newtype` now has its field remove by default+  without having to use `haskellRepNoFields`.+  + Add `haskellAddNewtypeField` function to add field name for `newtype`+  if desired.+* [!487](https://gitlab.com/morley-framework/morley/-/merge_requests/487)+  Fix typechecking error message pointing to the whole `map unit nat` as not comprable.+  + It now only points to `unit` type as not comparable.+* [!457](https://gitlab.com/morley-framework/morley/-/merge_requests/457)+  + Allow using the same position when defining `DocItem`.+  + When two `DocItem`s have the same position, they will be sorted alphabetically by their names.+* [!480](https://gitlab.com/morley-framework/morley/-/merge_requests/480)+  Arithmetic instructions (ADD, MUL, EDIV, LSL, ...) now take annotations into account.+    + Results from the instructions are also properly annotated.+* [!470](https://gitlab.com/morley-framework/morley/-/merge_requests/470)+  Move `Michelson.Doc.Test`, `Michelson.Test` and  Hedgehog generators to+  a new package: `cleveland`.+* [!453](https://gitlab.com/morley-framework/morley/-/merge_requests/453)+  Order of top-level entries in contract are now preserved.+  + `PACK`/`UNPACK` now serialize contracts according their top-level entries order.+  + Pretty printer now display contracts according to their given top-level entries order.+* [!445](https://gitlab.com/morley-framework/morley/merge_requests/445)+  Remove unnecessary `TcOriginatedContracts` usages and split `typeCheckTopLevelValue`+  to `typeCheckParameter` (the only case where `TcOriginatedContracts` is useful)+  and `typeCheckStorage`.  1.4.0 =====@@ -136,12 +172,12 @@ * [!241](https://gitlab.com/morley-framework/morley/merge_requests/241)   Derive `Show` instance for `Void_`. * [!238](https://gitlab.com/morley-framework/morley/merge_requests/238)-  + `NoExplicitDefaultEntryPoint` is now GHC-understandable constraint,+  + `NoExplicitDefaultEntrypoint` is now GHC-understandable constraint,     for previous behaviour with nice error message use-    `ForbidExplicitDefaultEntryPoint`.-  + `CanHaveEntryPoints` is made stricter, now it returns true only for+    `ForbidExplicitDefaultEntrypoint`.+  + `CanHaveEntrypoints` is made stricter, now it returns true only for      Michelson sum types. If that's a problem for you, consider using-     `ShouldHaveEntryPoints` wrapper.+     `ShouldHaveEntrypoints` wrapper.   + Added pseudo `Empty` type. * [!219](https://gitlab.com/morley-framework/morley/merge_requests/219)   Various entrypoints-related updates.@@ -155,7 +191,7 @@   + Generally it is encouraged to use `TAddress` instead of `Address`     where it is used to refer to a contract.   + `fromContractAddr` renamed to `fromContractRef`.-  + `Default` instances for `{Some,}EntryPointCall` are removed, use+  + `Default` instances for `{Some,}EntrypointCall` are removed, use      one of explicit versions: `epcPrimitive`, `epcCallRootUnsafe`.   + Reworked `FutureContract` type. 

@@ -35,13 +35,6 @@ 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](https://tezos.gitlab.io/index.html) or [Michelson tutorial](https://gitlab.com/morley-framework/michelson-tutorial). -## IV: 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.-There is [a document](/docs/testingEDSL.md) with a detailed description of the EDSL and a tutorial about its usage.- ## Running and building  Morley executable provides the following functionality:@@ -59,6 +52,7 @@   * Get [script](/scripts/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.+    You'll need `coreutils` to be installed in order to use `morley.sh`.   * Usage example:     + `./morley.sh` to see help message     + `./morley.sh run --contract add1.tz --storage 1 --parameter 1 --amount 1`

@@ -23,13 +23,14 @@ import Michelson.Optimizer (optimize) import Michelson.Printer (printSomeContract, printUntypedContract) import Michelson.Runtime-  (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer,-  typeCheckWithDb)+  (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer) import Michelson.Runtime.GState (genesisAddress)+import Michelson.TypeCheck (typeCheckContract) import Michelson.TypeCheck.Types (SomeContract(..), mapSomeContract) import Michelson.Typed (Contract(..)) import qualified Michelson.Untyped as U import Morley.CLI+import REPL import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp(..), unsafeMkMutez) import Tezos.Crypto@@ -51,22 +52,20 @@   | Run RunOptions   | Originate OriginateOptions   | Transfer TransferOptions+  | REPL  data OptimizeOptions = OptimizeOptions   { optoContractFile :: Maybe FilePath-  , optoDBPath :: FilePath   , optoOutput :: Maybe FilePath   , optoSingleLine :: Bool   }  data AnalyzeOptions = AnalyzeOptions   { aoContractFile :: Maybe FilePath-  , aoDBPath :: FilePath   }  data TypeCheckOptions = TypeCheckOptions   { tcoContractFile :: Maybe FilePath-  , tcoDBPath       :: FilePath   , tcoVerbose      :: Bool   } @@ -111,7 +110,8 @@   originateSubCmd <>   transferSubCmd <>   optimizeSubCmd <>-  analyzeSubCmd+  analyzeSubCmd <>+  replSubCmd   where     mkCommandParser commandName parser desc =       command commandName $@@ -142,6 +142,11 @@       "Run passed contract. \       \It's originated first and then a transaction is sent to it" +    replSubCmd =+      mkCommandParser "repl"+      (pure REPL)+      "Start a Morley REPL"+     originateSubCmd =       mkCommandParser "originate"       (Originate <$> originateOptions)@@ -181,7 +186,6 @@     typeCheckOptions :: Opt.Parser TypeCheckOptions     typeCheckOptions = TypeCheckOptions       <$> optional contractFileOption-      <*> dbPathOption       <*> verboseFlag      parseOptions :: Opt.Parser (Maybe FilePath, Bool)@@ -197,14 +201,11 @@     optimizeOptions :: Opt.Parser OptimizeOptions     optimizeOptions = OptimizeOptions       <$> optional contractFileOption-      <*> dbPathOption       <*> outputOption       <*> onelineOption      analyzeOptions :: Opt.Parser AnalyzeOptions-    analyzeOptions = AnalyzeOptions-      <$> optional contractFileOption-      <*> dbPathOption+    analyzeOptions = AnalyzeOptions <$> optional contractFileOption      runOptions :: Opt.Parser RunOptions     runOptions =@@ -288,19 +289,17 @@         write $ printUntypedContract forceSingleLine contract       Optimize OptimizeOptions{..} -> do         untypedContract <- prepareContract optoContractFile-        checkedContract <- either throwM pure =<<-          typeCheckWithDb optoDBPath untypedContract+        checkedContract <- either throwM pure $ typeCheckContract untypedContract         let optimizedContract = mapSomeContract optimize checkedContract         let write = maybe putStrLn writeFileUtf8 optoOutput         write $ printSomeContract optoSingleLine optimizedContract       Analyze AnalyzeOptions{..} -> do         untypedContract <- prepareContract aoContractFile-        SomeContract contract <- either throwM pure =<<-          typeCheckWithDb aoDBPath untypedContract+        SomeContract contract <- either throwM pure $ typeCheckContract untypedContract         putTextLn $ pretty $ analyze (cCode contract)       TypeCheck TypeCheckOptions{..} -> do         morleyContract <- prepareContract tcoContractFile-        either throwM (const pass) =<< typeCheckWithDb tcoDBPath morleyContract+        either throwM (const pass) $ typeCheckContract morleyContract         putTextLn "Contract is well-typed"       Run RunOptions {..} -> do         michelsonContract <- prepareContract roContractFile@@ -322,6 +321,7 @@         transfer toNow toMaxSteps toDBPath toDestination toTxData           ! #verbose toVerbose           ! #dryRun toDryRun+      REPL -> runRepl   usageDoc :: Maybe Doc

@@ -0,0 +1,233 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ+{-|+Implements an REPL that can execute Morley instructions.  REPL starts with an+empty stack. At each instruction entered, the modified stack, or an error is+printed. Multiple instructions separated by semicolons should work as expected.+Available meta commads are:++ ':help', displays this help\n ':stack', prints the current stack+ ':loadstack filename', loads the stack from a file+ ':dumpstack filename', dumps the stack to a file+ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."+-}+module REPL+  ( runRepl+  ) where++import Data.List (stripPrefix)+import Data.Text (strip)+import Data.Typeable (cast)+import Data.Vinyl (Rec(..))+import Fmt (pretty)+import System.Console.Haskeline+import Text.Megaparsec (parse)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as BSL++import Michelson.Interpret (ContractEnv(..), interpretInstr)+import qualified Michelson.Untyped as U+import qualified Michelson.Typed as T+import Michelson.Macro (ParsedOp, expandList)+import Michelson.Parser (errorBundlePretty, parseExpandValue, ops, type_)+import Michelson.Parser.Types (noLetEnv)+import Michelson.Printer (printDoc, printTypedValue)+import Michelson.Printer.Util (doesntNeedParens)+import Michelson.Runtime.GState (genesisAddress)+import Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))+import Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)+import Michelson.TypeCheck (SomeInstr(..), SomeInstrOut(..), getWTP, runTypeCheckIsolated)+import Tezos.Core (Timestamp(..), dummyChainId, unsafeMkMutez)+import Util.IO++data SomeStack = forall t. Typeable t => SomeStack+  { stValues :: (Rec T.Value t)+  , stTypes :: HST t+  }++type ReplM = InputT (StateT SomeStack IO)++runRepl :: IO ()+runRepl = evalStateT (runInputT defaultSettings repl) emptyStack++-- | Prints an error message to stderr+printErr :: (MonadIO m) => Text -> m ()+printErr m = liftIO $ hPutStrLn stderr m++-- | Read commands or instructions from stdin and executes them.+-- If user presses Ctrl-c during execution of an instruction, it will be+-- caught and handled here itself. This ensures that REPL does not crash as+-- a result of user pressing Ctrl-c in an attempt to end a loop.+repl :: ReplM ()+repl = do+   minput <- getInputLine "Morley>>> "+   case strStrip <$> minput of+     Nothing -> pass -- Ctrl D+     Just ":quit" -> pass+     Just input -> do+      case input of+        "" -> pass+        ":clear" -> lift $ put emptyStack+        ":stack" -> printStack+        (stripPrefix ":dumpstack" -> Just filename) ->+          dumpStackToFile $ toString $ strip $ toText filename+        (stripPrefix ":loadstack" -> Just filename) ->+          loadStackFromFile $ toString $ strip $ toText filename+        ":help" -> printHelp+        (stripPrefix ":" -> Just cmd) ->+          printErr $ "Unknown command`"<> (toText cmd) <> "`. Use :help to see a list of commands"+        _ -> handle (\Interrupt -> putTextLn "Cancelled") $ withInterrupt $ runCode (toText input)+      repl+  where+    strStrip = toString . strip . toText++-- | Try to execute the given input string as a Morley instruction.+runCode :: Text -> ReplM ()+runCode code = do+  case parseInstructions code of+    Left err -> printErr err+    Right [] -> pass+    Right parsedOps -> do+      let expandedOps = expandList parsedOps+      lift get >>= \case+        SomeStack {..} -> case cast stTypes of+          Just hstInp -> case runTypeCheckIsolated $ typeCheckList expandedOps hstInp of+            Right someInstr -> do+              case someInstr of+                _ :/ (instr ::: hstOut)-> case interpretInstr dummyContractEnv instr stValues of+                  Right recOut -> do+                    lift $ put (SomeStack recOut hstOut)+                    printStack+                  Left michelsonFail -> putTextLn (pretty michelsonFail)+                _ :/ (AnyOutInstr _) -> putTextLn "Encountered a FAILWITH instruction"+            Left err -> printErr $ show err+          Nothing -> printErr "Casting stack failed"++dummyContractEnv :: ContractEnv+dummyContractEnv = ContractEnv+  { ceNow = Timestamp 100+  , ceMaxSteps = 100500+  , ceBalance = unsafeMkMutez 100+  , ceContracts = mempty+  , ceSelf = genesisAddress+  , ceSource = genesisAddress+  , ceSender = genesisAddress+  , ceAmount = unsafeMkMutez 100+  , ceChainId = dummyChainId+  , ceOperationHash = Nothing+  }++printHelp :: ReplM ()+printHelp = putTextLn "REPL starts with an empty stack. At each instruction entered,\+  \ the modified stack, or an error is printed. Multiple instructions separated by semicolons should work\+  \ as expected. Available meta commads are:\n\+  \ ':help', displays this help\n ':stack', prints the current stack\n\+  \ ':loadstack filename', loads the stack from a file\n\+  \ ':dumpstack filename', dumps the stack to a file \n\+  \ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."++printStack :: ReplM ()+printStack = lift get >>= \case+  SomeStack stk hst -> do+    putTextLn "--"+    putTextLn $ showStack stk hst++emptyStack :: SomeStack+emptyStack = SomeStack RNil SNil++parseInstructions :: Text -> Either Text [ParsedOp]+parseInstructions src = let+  codeParser = runReaderT ops noLetEnv+  in case parse codeParser "" src of+    Right p -> Right p+    Left err -> Left (toText $ errorBundlePretty err)++-- helpers++addValueToHST+  :: forall t xs. Typeable xs+  => T.Value t+  -> HST xs+  -> Either Text (T.Dict (Typeable (t ': xs)), HST (t ': xs))+addValueToHST v hstIn = case T.valueTypeSanity v of+  T.Dict -> case getWTP @t of+    Right wtpDict -> Right (T.Dict, (T.starNotes @t, wtpDict, U.noAnn) ::&  hstIn)+    Left (NotWellTyped t) -> let+      U.Type t' tann = T.toUType t+      in Left $ "Value of type '" <> (renderT t' (U.fullAnnSet [tann] [] []))+                <> "' is not well typed in the provided Value."++renderType :: T.SingI t => T.Notes t -> U.VarAnn -> Text+renderType notes vann = let+  U.Type t tann = T.mkUType notes+  in renderT t (U.fullAnnSet [tann] [] [vann])++renderT :: U.T -> U.AnnotationSet -> Text+renderT t annSet = toText $ printDoc True $ U.renderType t True doesntNeedParens annSet++dumpStackToFile :: FilePath -> ReplM ()+dumpStackToFile fname =+ lift get >>= \case+  SomeStack stk hst -> case dumpStack stk hst of+    Right stkd -> liftIO $ Prelude.catch (writeFileUtf8 fname $ Aeson.encode stkd) handler+    Left err -> printErr err+  where+    handler :: IOException -> IO ()+    handler e = printErr $ toText $ displayException e++loadStackFromFile :: FilePath -> ReplM ()+loadStackFromFile fname = do+  mStack <- liftIO $ flip Prelude.catch handler $ do+    stackTxt <- BSL.readFile fname+    case Aeson.decode @[(Text, Text)] stackTxt of+      Just s -> pure $ loadStack s+      Nothing -> pure $ Left "Decoding error when parsing stack data from file"+  case mStack of+    Right stk -> lift $ put stk+    Left err -> printErr err+  where+    handler :: IOException -> IO (Either Text a)+    handler e = pure $ Left $ toText $ displayException e++-- | Dump stack as a lit of tuples that represent (value, type) pairs.+dumpStack :: forall t. Rec T.Value t -> HST t -> Either Text [(Text, Text)]+dumpStack RNil _ = Right []+dumpStack ((v :: T.Value a) :& rst) ((notes, _, vann) ::& rHst) = case T.valueTypeSanity v of+  T.Dict -> case T.checkOpPresence (T.sing @a) of+    T.OpAbsent -> case dumpStack rst rHst of+      Right t -> Right ((toText $ printTypedValue True v, renderType notes vann) : t)+      Left e -> Left e+    T.OpPresent ->  Left "Cannot dump stack with operations"++-- | Overwrite the current stack with a stack loaded from a list of tuples+-- representing (value/type) pairs.+loadStack :: [(Text, Text)] -> Either Text SomeStack+loadStack = foldl' buildStack (Right emptyStack) . reverse+  where+    buildStack :: Either Text SomeStack -> (Text, Text) -> Either Text SomeStack+    buildStack (Left err) _ = Left err+    buildStack (Right (SomeStack stk hst)) (txVal, txTyp) = case+      (parseExpandValue txVal, parse (runReaderT type_ noLetEnv) "" txTyp) of+        (Right val, Right typ) ->+          case typeCheckParameter mempty typ val of+            Right (T.SomeValue tVal) ->+              case addValueToHST tVal hst of+                Right (T.Dict, newHst) -> Right $ SomeStack (tVal :& stk) newHst+                Left err -> Left err+            Left tcError -> Left $ show tcError+        (Left err, _) -> Left $ pretty err+        (_, Left err) -> Left $ toText $ errorBundlePretty err++showStack :: forall t. Rec T.Value t -> HST t -> Text+showStack RNil _ = "--"+showStack ((v :: T.Value a) :& rst) ((notes, _, vann) ::& rHst)  = case T.valueTypeSanity v of+  T.Dict -> case T.checkOpPresence (T.sing @a) of+    T.OpAbsent -> -- print nice if value has no operations+      addSuffix (toText $ printTypedValue True v)+    T.OpPresent -> -- else just call show, and indicate value has operation inside+      case (v, T.sing @a) of+        (T.VList [], T.STList T.STOperation) -> "{ } :: list operation\n" <> showStack rst rHst+        _ -> addSuffix $ "(operations container:" <> show v <> ")"+  where+    addSuffix val = val <>" :: " <> renderType notes vann <> "\n" <> showStack rst rHst

@@ -1,74 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Main (main) where--import qualified Data.Map as M-import Gauge.Main (bench, nf, defaultMain, bgroup)-import Text.Megaparsec (parse)--import Michelson.Interpret (interpret)-import Michelson.Parser as P-import Michelson.Runtime (prepareContract)-import Michelson.Test.Import-import Michelson.Test.Dummy-import Michelson.Text-import Michelson.TypeCheck as T-import Michelson.Typed as T-import Tezos.Address-import Util.IO--main :: IO ()-main = do-  let-    basicFp = "../../contracts/basic1.tz"-    stringCallerFp = "../../contracts/string_caller.tz"-    callSelfFp = "../../contracts/call_self_several_times.tz"-    sq2Fp = "../../contracts/testassert_square2.mtz"-    contractPaths = [basicFp, stringCallerFp, callSelfFp, sq2Fp]-  contracts <- traverse (\x -> (x,) <$> readFileUtf8 x) contractPaths-  let makeParseBench (filename, code) =-        bench filename $ nf (parse P.program filename) code-  preparedContracts <- evaluateNF =<< traverse (\x -> (x,) <$> prepareContract (Just x)) contractPaths-  let-    makeTypeCheckBench (filename, contract) = bench filename $-      nf (T.typeCheckContract (M.fromList [])) contract--  (_, basicC) <- importContract basicFp-  (_, stringCallerC) <- importContract stringCallerFp-  (_, callSelfC) <- importContract callSelfFp-  (_, sq2C) <- importContract sq2Fp-  let-    basicBench = bench basicFp-      (nf-        (interpret (T.cCode basicC) T.epcPrimitive T.VUnit (T.VList [T.VInt 0]))-        dummyContractEnv-      )--    dummyAddress = detGenKeyAddress "thegreatandpowerful"-    dummyString = mkMTextUnsafe "TGAP"-    stringCallerBench = bench stringCallerFp-      (nf-        (interpret (T.cCode stringCallerC) T.epcPrimitive  (T.toVal dummyString) (T.toVal dummyAddress))-        dummyContractEnv-      )-    callSelfBench = bench callSelfFp-      (nf-        (interpret (T.cCode callSelfC) T.epcPrimitive (T.toVal (100 :: Integer)) (T.toVal (0 :: Natural)))-        dummyContractEnv-      )--    sq2Bench = bench sq2Fp-      (nf-        (interpret (T.cCode sq2C) T.epcPrimitive (T.toVal (100 :: Integer, 200 :: Integer)) T.VUnit)-        dummyContractEnv-      )----  defaultMain-    [ bgroup "parsing" $ map makeParseBench contracts-    , bgroup "type-checking" $ map makeTypeCheckBench preparedContracts-    , bgroup "interpreting" $ [basicBench, stringCallerBench, callSelfBench, sq2Bench]-    ]

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6cecee7b4a0dcb06694b15ff8be6902535e2f0b301c8c28cc603468df87e3153+-- hash: baa867af7f9b3c6cbf4de3c7d9746427b24b2cca6f9c9cb9025ad098b40ef60e  name:           morley-version:        1.4.0+version:        1.5.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@@ -31,7 +31,6 @@   exposed-modules:       Michelson.Analyzer       Michelson.Doc-      Michelson.Doc.Test       Michelson.ErrorPos       Michelson.FailPattern       Michelson.Interpret@@ -59,13 +58,6 @@       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@@ -81,7 +73,7 @@       Michelson.Typed.Arith       Michelson.Typed.Convert       Michelson.Typed.Doc-      Michelson.Typed.EntryPoints+      Michelson.Typed.Entrypoints       Michelson.Typed.Extract       Michelson.Typed.Haskell       Michelson.Typed.Haskell.Doc@@ -103,7 +95,7 @@       Michelson.Untyped.Aliases       Michelson.Untyped.Annotation       Michelson.Untyped.Contract-      Michelson.Untyped.EntryPoints+      Michelson.Untyped.Entrypoints       Michelson.Untyped.Ext       Michelson.Untyped.Instr       Michelson.Untyped.Type@@ -127,6 +119,7 @@       Util.Binary       Util.ByteString       Util.CLI+      Util.CustomGeneric       Util.Default       Util.Exception       Util.Fcf@@ -141,8 +134,6 @@       Util.Peano       Util.Positive       Util.Test.Arbitrary-      Util.Test.Gen-      Util.Test.Ingredients       Util.Text       Util.TH       Util.Type@@ -159,30 +150,23 @@   default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses 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:-      HUnit-    , QuickCheck+      QuickCheck     , aeson     , aeson-casing     , aeson-pretty     , base >=4.7 && <5-    , base16-bytestring     , base58-bytestring     , binary     , bytestring     , constraints >=0.11     , containers-    , criterion     , cryptonite     , data-default     , first-class-families >=0.5.0.0     , fmt-    , formatting-    , ghc-prim+    , generic-deriving     , gitrev-    , hedgehog     , hex-text-    , hspec-    , hspec-expectations     , interpolate     , lens     , megaparsec >=7.0.0@@ -190,7 +174,6 @@     , morley-prelude >=0.3.0     , mtl     , named-    , o-clock     , optparse-applicative     , parser-combinators >=1.0.0     , quickcheck-arbitrary-adt@@ -198,13 +181,7 @@     , semigroups >=0.19.1     , show-type     , singletons-    , statistics     , syb-    , tasty-    , tasty-ant-xml-    , tasty-hedgehog-    , tasty-hunit-compat-    , tasty-quickcheck     , template-haskell     , text     , th-lift@@ -223,6 +200,7 @@ executable morley   main-is: Main.hs   other-modules:+      REPL       Paths_morley   autogen-modules:       Paths_morley@@ -231,118 +209,19 @@   default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses 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 >=4.7 && <5-    , fmt-    , morley-    , morley-prelude-    , named-    , optparse-applicative-    , pretty-simple-  mixins:-      base hiding (Prelude)-  default-language: Haskell2010--test-suite morley-test-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules:-      Test.Analyzer-      Test.EntryPoints-      Test.Ext-      Test.Integrational-      Test.Interpreter-      Test.Interpreter.Apply-      Test.Interpreter.Auction-      Test.Interpreter.Balance-      Test.Interpreter.CallSelf-      Test.Interpreter.ComparableSet-      Test.Interpreter.Compare-      Test.Interpreter.ComparePairs-      Test.Interpreter.Conditionals-      Test.Interpreter.ContractOp-      Test.Interpreter.EnvironmentSpec-      Test.Interpreter.StackRef-      Test.Interpreter.StringCaller-      Test.Macro-      Test.Michelson.Runtime-      Test.Michelson.Text-      Test.Michelson.Typed.Util-      Test.Michelson.Typed.Value-      Test.Morley.Expression-      Test.OpSize-      Test.Optimizer-      Test.Parser-      Test.Preprocess-      Test.Printer.Michelson-      Test.Serialization.Aeson-      Test.Serialization.Michelson-      Test.Tezos.Address-      Test.Tezos.Core-      Test.Tezos.Crypto-      Test.Tezos.Crypto.Hash-      Test.Typeable-      Test.Typecheck-      Test.Untyped.Instr-      Test.Util.Contracts-      Test.Util.Hedgehog-      Test.Util.HUnit-      Test.Util.Parser-      Test.ValConversion-      Tree-      Paths_morley-  hs-source-dirs:-      test-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses 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 -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"-  build-tool-depends:-      tasty-discover:tasty-discover-  build-depends:-      HUnit-    , aeson+      aeson     , base >=4.7 && <5     , bytestring-    , containers-    , data-default-    , directory-    , filepath     , fmt-    , formatting-    , hedgehog-    , hex-text-    , hspec-    , hspec-expectations-    , lens+    , haskeline     , megaparsec >=7.0.0     , morley     , morley-prelude-    , singletons-    , syb-    , tasty-    , tasty-hedgehog-    , tasty-hspec-    , tasty-hunit-compat+    , named+    , optparse-applicative+    , pretty-simple     , text-    , unordered-containers-  mixins:-      base hiding (Prelude)-  default-language: Haskell2010--benchmark morley-bench-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules:-      Paths_morley-  hs-source-dirs:-      bench-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses 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 >=4.7 && <5-    , containers-    , gauge-    , megaparsec >=7.0.0-    , morley-    , morley-prelude+    , vinyl   mixins:       base hiding (Prelude)   default-language: Haskell2010

@@ -52,7 +52,6 @@ import Data.Typeable (cast, typeRep) import Development.GitRev (gitCommitDate, gitHash) import Fmt (Buildable, build, fmt, (+|), (+||), (|+), (||+))-import GHC.TypeNats (Nat) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Lift as TH import System.Environment (lookupEnv)@@ -82,16 +81,17 @@ -- E.g. all rendering and reording stuff could be merged in one method, and -- we could have several template implementations for it which would allow -- user to specify only stuff relevant to his case.-class (Typeable d, DOrd d, KnownNat (DocItemPosition d)) => DocItem d where+class (Typeable d, DOrd d) => DocItem d where   -- | Position of this item in the resulting documentation;   -- the smaller the value, the higher the section with this element-  -- will be placed.+  -- will be placed. If the position is the same as other doc items,+  -- they will be placed base on their name, alphabetically.   --   -- Documentation structure is not necessarily flat.   -- If some doc item consolidates a whole documentation block within it,   -- this block will have its own placement of items independent from outer parts   -- of the doc.-  type DocItemPosition d = (pos :: Nat) | pos -> d+  docItemPos :: Natural    -- | When multiple items of the same type belong to one section, how   -- this section will be called.@@ -165,7 +165,7 @@  -- | Get doc item position at term-level. docItemPosition :: forall d. DocItem d => DocItemPos-docItemPosition = DocItemPos $ natVal (Proxy @(DocItemPosition d))+docItemPosition = DocItemPos (docItemPos @d, show (typeRep $ Proxy @d))  -- | Render an item into Markdown block with all required adjustments. docItemToMarkdownFull :: DocItem d => HeaderLevel -> d -> Markdown@@ -200,10 +200,12 @@   deriving newtype (ToAnchor)  -- | Position of all doc items of some type.-newtype DocItemPos = DocItemPos Natural+newtype DocItemPos = DocItemPos (Natural, Text)   deriving stock (Eq, Ord, Show)-  deriving newtype (Buildable) +instance Buildable DocItemPos where+  build (DocItemPos (a, _)) = build a+ -- | Where do we place given doc item. data DocItemPlacementKind   = DocItemInlined@@ -473,7 +475,7 @@ newtype DGeneralInfoSection = DGeneralInfoSection SubDoc  instance DocItem DGeneralInfoSection where-  type DocItemPosition DGeneralInfoSection = 1+  docItemPos = 1   docItemSectionName = Nothing   docItemToMarkdown lvl (DGeneralInfoSection subDoc) =     subDocToMarkdown lvl subDoc@@ -482,7 +484,7 @@ data DName = DName Text SubDoc  instance DocItem DName where-  type DocItemPosition DName = 3+  docItemPos = 3   docItemSectionName = Nothing   docItemToMarkdown lvl (DName name doc) =     mdHeader lvl (build name) <>@@ -492,7 +494,7 @@ data DDescription = DDescription Markdown  instance DocItem DDescription where-  type DocItemPosition DDescription = 10+  docItemPos = 10   docItemSectionName = Nothing   docItemToMarkdown _ (DDescription txt) = build txt @@ -553,7 +555,7 @@           value -> error $ "Unknown value returned by git: " <> show value  instance DocItem DGitRevision where-  type DocItemPosition DGitRevision = 2+  docItemPos = 2   docItemSectionName = Nothing   docItemToMarkdown _ (DGitRevisionKnown DGitRevisionInfo{..}) =     mconcat@@ -571,7 +573,7 @@ data DComment = DComment Text  instance DocItem DComment where-  type DocItemPosition DComment = 0+  docItemPos = 0   docItemSectionName = Nothing   docItemToMarkdown _ (DComment commentText) =     "<!---\n" +| commentText |+ "\n-->"@@ -580,6 +582,6 @@ data DAnchor = DAnchor Anchor  instance DocItem DAnchor where-  type DocItemPosition DAnchor = 4+  docItemPos = 4   docItemSectionName = Nothing   docItemToMarkdown _ (DAnchor a) = mdAnchor a

@@ -1,243 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities for testing documentations sanity.------ These tests serve to ensure that documentation generation is not broken and--- that user follows sane documentation structure (e.g. contract should be--- named, some entities require description, e.t.c).-module Michelson.Doc.Test-  ( DocTest (..)-  , mkDocTest-  , excludeDocTest-  , excludeDocTests-  , runDocTests-  , expectDocTestFailure--    -- * Test predicates-  , testDocBasic--    -- ** Individual test predicates-  , testContractNameAtTop-  , testNoGitInfo-  , testDocNotEmpty-  , testNoAdjacentDescriptions-  , testStorageIsDocumented--    -- * Utilities-  , forEachContractLayer-  , forEachContractDocItem-  ) where--import qualified Data.List as L-import qualified Data.Text as T-import Data.Text.Lazy.Builder (toLazyText)-import Fmt (Buildable(..), blockListF, fmt, nameF, pretty)-import GHC.Stack (SrcLoc)-import Test.HUnit (Assertion, assertBool, assertFailure)-import Test.HUnit.Lang (HUnitFailure(..))-import Test.Tasty (TestTree)-import Test.Tasty.HUnit (testCase)-import qualified Text.Show--import Michelson.Doc-import Michelson.Typed.Haskell.Doc--------------------------------------------------------------------------------- Framework--------------------------------------------------------------------------------- | Test case for contract documentation.-data DocTest = DocTest-  { dtDeclLoc :: SrcLoc-    -- ^ Declaration location, used to distinguish different test predicates.-    -- This is primarily used in 'excludeDocTest'.-  , dtDesc :: String-    -- ^ Description of predicate, which you put to 'testCase'.-  , dtSuite :: HasCallStack => ContractDoc -> Assertion-    -- ^ Test itself.-  }--instance Eq DocTest where-  (==) = (==) `on` dtDeclLoc--instance Show DocTest where-  show = pretty--instance Buildable DocTest where-  build DocTest{..} = "Doc test '" <> build dtDesc <> "'"---- | Construct 'DocTest'.------ Note: you should not declare helpers with this function rather use it--- directly in every test suite.-mkDocTest-  :: HasCallStack-  => String-  -> (HasCallStack => ContractDoc -> Assertion)-  -> DocTest-mkDocTest dtDesc dtSuite = DocTest{..}-  where-  (_, dtDeclLoc) = case getCallStack callStack of-    [] -> error "Callstacks operate in a weird way, excluding doc tests won't work"-    layer : _ -> layer---- | Exclude given test suite.-excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]-excludeDocTest toExclude tests =-  case L.partition (== toExclude) tests of-    ([], _) ->-      error $ "Not in the list of doc items: " <> pretty toExclude-    (_ : _ : _, _) ->-      -- This is possible if someone abused 'mkDocTest' and created a function-      -- which calls it and this function is used to create multiple predicates-      error "Running invalid doc predicates: multiple ones were considered equal"-    ([_], notExcluded) ->-      notExcluded---- | Calling @excludeDocTests tests toExclude@ returns all test suites from--- @tests@ which are not present in @toExclude@.-excludeDocTests :: [DocTest] -> [DocTest] -> [DocTest]-excludeDocTests = foldr excludeDocTest---- | Finalize test suites.-runDocTests :: HasCallStack => [DocTest] -> ContractDoc -> [TestTree]-runDocTests tests contract =-  tests <&> \DocTest{..} ->-    testCase dtDesc (dtSuite contract)---- | Ensure that 'DocTest' check fires on given contract.--- Used in tests on this module.-expectDocTestFailure :: DocTest -> ContractDoc -> Assertion-expectDocTestFailure DocTest{..} contract = do-  passed <- (dtSuite contract $> True) `catch` \HUnitFailure{} -> pure False-  when passed $ assertFailure "Test didn't fail unexpectedly"--------------------------------------------------------------------------------- Test predicates--------------------------------------------------------------------------------- Utilities--------------------------------------------------------------------------------- | Apply given function to each group (created with 'DocGroup' instruction)--- recursively.--- This function will accept grouping doc item itself and its subcontents.-forEachLayer :: DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]-forEachLayer block f = do-  DocSection docElems <- toList block-  DocElem{..} <- toList docElems-  Just (SubDoc sub) <- pure deSub-  f (SomeDocItem deItem) sub : forEachLayer sub f---- | Apply given function to each group (created with 'DocGroup' instruction)--- within a contract recursively.--- This function will accept grouping doc item itself (unless we are at root)--- and its subcontents.-forEachContractLayer :: ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]-forEachContractLayer contract f =-  let contents = cdContents contract-  in f Nothing contents-   : forEachLayer contents (\sdi blk -> f (Just sdi) blk)---- | Apply given function to each doc item within a contract.-forEachContractDocItem :: DocItem d => ContractDoc -> (d -> r) -> [r]-forEachContractDocItem contract f =-  fold . forEachContractLayer contract $ \_ block ->-    fmap f . maybe [] toList $ lookupDocBlockSection block---- Basic predicates--------------------------------------------------------------------------------- | Check that contract documentation is wrapped with 'contractName'.-testContractNameAtTop :: DocTest-testContractNameAtTop =-  mkDocTest "The whole contract is wrapped into 'DName'" $-  \contractDoc -> do-    let mSections = lookupDocBlockSection @DName (cdContents contractDoc)-    case mSections of-      Nothing -> assertFailure "There is no 'DName' at the top"-      Just _ -> return ()---- | Check that contracts themselves do not set the git revision. It is supposed to be filled only--- in the executable.-testNoGitInfo :: DocTest-testNoGitInfo =-  mkDocTest "Git revision is not set in the contract" $-  \contractDoc -> do-    assertions <- sequence $ forEachContractDocItem contractDoc $ \case-      DGitRevisionUnknown -> return ()-      _ -> assertFailure "Unexpected Git revision"-    assertBool "No Git revision placeholder found or more than one" $-      (length assertions == 1)---- | Check that there is at least one non-grouping doc item.------ If there is no such, rendered documentation will be empty which signals about--- most of the documentation pieces being lost.-testDocNotEmpty :: DocTest-testDocNotEmpty =-  mkDocTest "There is at least one DOC_ITEM" $-  \contractDoc ->-    assertBool "No doc items found" . or $-      forEachContractLayer contractDoc hasDocItem-  where-    hasDocItem _ block = not . null @[()] $ do-      DocSection docElems <- toList block-      docElem <- toList docElems-      guard (deIsAtomic docElem)---- | Check that no group contains two 'DDescription' items.------ Normally such behaviour is allowed and can be exploited, but often it is not--- and multiple descriptions appearence under the same group signals about--- missing grouping wrapper (e.g. use of 'caseT' instead of 'entryCase').-testNoAdjacentDescriptions :: DocTest-testNoAdjacentDescriptions =-  mkDocTest "No two 'DDescription' appear under the same group" $-  \contractDoc ->-    sequence_ . forEachContractLayer contractDoc $ \_ block ->-      case lookupDocBlockSection @DDescription block of-        Just ds@(_ :| _ : _) ->-          let txts = ds <&> \(DDescription txt) -> txt-          in assertFailure . fmt $-             nameF "Found multiple adjacent descriptions" $-             blockListF $ map quotes txts-        _ -> pass-    where-      quotes t = "\"" <> t <> "\""---- | Check that all descriptions are proper.-testDescriptionsAreWellFormatted :: DocTest-testDescriptionsAreWellFormatted =-  mkDocTest "Descriptions are well-formatted" $-  \contractDoc ->-    sequence_ . forEachContractDocItem contractDoc $ \(DDescription desc) ->-      check (toText $ toLazyText desc)-  where-    check desc-      | T.null desc =-          assertFailure "Empty description."-      | T.last (T.stripEnd desc) /= '.' =-          assertFailure $ "Description does not end with a dot:\n\"" <>-                          toString desc <> "\""-      | otherwise = pass---- | Test whether storage documentation is included in the contract's documentation.-testStorageIsDocumented :: DocTest-testStorageIsDocumented =-  mkDocTest "Storage documentation is included" $-  \contractDoc -> assertBool "No documentation for storage in the contract." $-    or $ forEachContractDocItem contractDoc $ \(DStorageType _) -> True---- | Base properties which should comply for all documentations.-testDocBasic :: [DocTest]-testDocBasic =-  [ testContractNameAtTop-  , testNoGitInfo-  , testDocNotEmpty-  , testNoAdjacentDescriptions-  , testDescriptionsAreWellFormatted-  , testStorageIsDocumented-  ]

@@ -40,15 +40,15 @@ import Data.Default (Default(..)) import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Singletons (Sing)+import Data.Singletons (Sing, demote) import Data.Vinyl (Rec(..), (<+>))-import Fmt (Buildable(build), Builder, genericF, pretty)+import Fmt (Buildable(build), Builder, genericF)  import Michelson.Interpret.Pack (packValue') import Michelson.Interpret.Unpack (UnpackError, unpackValue') import Michelson.TypeCheck-  (SomeContract(..), TCError, TcOriginatedContracts, matchTypes, runTypeCheck, typeCheckContract,-  typeCheckValue)+  (SomeContract(..), SomeParamType(..), TCError, TcOriginatedContracts, TypeCheckMode(..),+  matchTypes, runTypeCheck, typeCheckContract, typeCheckValue) import Michelson.Typed import qualified Michelson.Typed as T import qualified Michelson.Untyped as U@@ -187,17 +187,17 @@   -> ContractEnv   -> Either InterpretError InterpretResult interpretUntyped uContract@U.Contract{..} paramU initStU env = do-  SomeContract (Contract (instr :: ContractCode cp st) _ _)-      <- first IllTypedContract $ typeCheckContract (ceContracts env) uContract+  SomeContract (Contract (instr :: ContractCode cp st) _ _ _)+      <- first IllTypedContract $ typeCheckContract uContract   -- Do creates dummy scope to somehow overcome this:   -- GHC internal error: ‘st’ is not in scope during type checking, but it passed the renamer.   do     let       runTC :: forall t. SingI t => U.Value -> Either TCError (Value t)-      runTC =-        runTypeCheck contractParameter (ceContracts env) .+      runTC val =+        runTypeCheck (TypeCheckValue (val, demote @t)) .         usingReaderT def .-        typeCheckValue @t+        typeCheckValue @t $ val      paramV <- first IllTypedParam $ runTC @cp paramU     initStV <- first IllTypedStorage $ runTC @st initStU@@ -216,7 +216,7 @@ interpret'   :: forall cp st arg.      ContractCode cp st-  -> EntryPointCallT cp arg+  -> EntrypointCallT cp arg   -> T.Value arg   -> T.Value st   -> ContractEnv@@ -237,7 +237,7 @@  interpret   :: ContractCode cp st-  -> EntryPointCallT cp arg+  -> EntrypointCallT cp arg   -> T.Value arg   -> T.Value st   -> ContractEnv@@ -503,15 +503,8 @@       castContract addr epName T.tyImplicitAccountParam :& r     ContractAddress ca ->       case Map.lookup ca ceContracts of-        -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-        -- valid parameter type. Should be not necessary after [#36].-        Just tc@(U.ParameterType (AsUTypeExt (_ :: Sing tc) tcNotes) rootAnn) ->-          let paramNotes = ParamNotesUnsafe tcNotes rootAnn in-          case T.checkScope @(T.ParameterScope tc) of-            Right Dict -> castContract addr epName paramNotes :& r-            _ -> error $ "Illegal type in parameter of env contract: " <> pretty tc-            -- TODO [#36]: we can do this safely once 'TcOriginatedContracts' stores-            -- typed stuff.+        Just (SomeParamType _ paramNotes) ->+          castContract addr epName paramNotes :& r         Nothing -> VOption Nothing :& r   where   castContract@@ -519,7 +512,7 @@     => Address -> EpName -> T.ParamNotes p -> T.Value ('TOption ('TContract a))   castContract addr epName param = VOption $ do     -- As we are within Maybe monad, pattern-match failure results in Nothing-    MkEntryPointCallRes na epc <- T.mkEntryPointCall epName param+    MkEntrypointCallRes na epc <- T.mkEntrypointCall epName param     Right (Refl, _) <- pure $ matchTypes nt na     return $ VContract addr (T.SomeEpc epc) 

@@ -351,15 +351,12 @@     "\x03\x4d"   SET_DELEGATE ->     "\x03\x4e"-  CREATE_CONTRACT (Contract instr np ng)-    | _ :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ] <- instr ->-    let contents =-          [ "\x05\x00" <> encodeParamNotes' @p np-          , "\x05\x01" <> encodeNotedT' @g ng-          , "\x05\x02" <> encodeInstrs instr-          ]-    -- TODO [TM-96] These ^ should be encoded in the same order in which-    -- they appear in the original code+  CREATE_CONTRACT contract@Contract{..}+    | _ :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ] <- cCode ->+    let contents = mapEntriesOrdered contract+            (\np -> "\x05\x00" <> encodeParamNotes' @p np)+            (\ng -> "\x05\x01" <> encodeNotedT' @g ng)+            (\instr -> "\x05\x02" <> encodeInstrs instr)     in "\x05\x1d" <> encodeList id contents   IMPLICIT_ACCOUNT ->    "\x03\x1e"

@@ -35,35 +35,28 @@ import Data.Constraint (Dict(..)) import Data.Default (def) import qualified Data.Kind as Kind-import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import Data.Singletons (Sing, SingI(..)) import Data.Typeable ((:~:)(..))-import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (|+))+import Fmt (Buildable, fmt, hexF, pretty, (+|), (|+))  import Michelson.Parser (Parser, ParserException(..), parseNoEnv) import qualified Michelson.Parser.Annotations as PA import Michelson.Text import Michelson.TypeCheck   (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..),-  TypeContext(..), withWTPm)+  TypeCheckMode(..), TypeContext(..), withWTPm) import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1) import Michelson.TypeCheck.Instr (typeCheckList) import Michelson.Typed (KnownT, RemFail(..), SingT(..), starNotes) import qualified Michelson.Typed as T-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Scope (UnpackedValScope) import Michelson.Untyped-import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core import Tezos.Crypto-  (KeyHash(..), KeyHashTag(..), PublicKey(..), keyHashLengthBytes, mkSignature, parseKeyHash,-  parsePublicKey, parseSignature)-import qualified Tezos.Crypto.Ed25519 as Ed25519-import qualified Tezos.Crypto.P256 as P256-import qualified Tezos.Crypto.Secp256k1 as Secp256k1-import Util.Binary (UnpackError (..), ensureEnd, launchGet)+import Util.Binary  ---------------------------------------------------------------------------- -- Helpers@@ -74,26 +67,6 @@ (?) = 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---- | Get remaining available bytes.------ Note that reading all remaining decoded input may be expensive and is thus--- discouraged, use can use this function only when you know that amount--- of data to be consumed is limited, e.g. within 'decodeAsBytes' call.-getRemainingByteStringCopy :: Get ByteString-getRemainingByteStringCopy = do-  lbs <- Get.getRemainingLazyByteString-  -- Avoiding memory overflows in case bad length to 'Get.isolate' was provided.-  -- Normally this function is used only to decode primitives, 'Signature' in-  -- the worst case, so we could set little length, but since this is a hack-  -- anyway let's make sure it never obstructs our work.-  when (length lbs > 640000) $ fail "Too big length for an entity"-  return (LBS.toStrict lbs)- -- | Read a byte and match it against given value. expectTag :: String -> Word8 -> Get () expectTag desc t =@@ -103,10 +76,6 @@       fail . fmt $ "Unexpected tag value (expected 0x" +| hexF t |+                    ", but got 0x" +| hexF t' |+ ")" --- | Fail with "unknown tag" error.-unknownTag :: String -> 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.@@ -143,29 +112,6 @@     then return []     else (:) <$> decode <*> manyForced decode --- | Describes how 'decodeWithTag' should decode tag-dependent data.--- We expect bytes of such structure: 'tdTag' followed by a bytestring--- which will be parsed with 'tdDecoder'.-data TaggedDecoder a = TaggedDecoder-  { tdTag :: Word8-  , tdDecoder :: Get a-  }---- | Alias for 'TaggedDecoder' constructor.-(#:) :: Word8 -> Get a -> TaggedDecoder a-(#:) = TaggedDecoder-infixr 0 #:---- Common decoder for the case when packed data starts with a tag (1--- byte) that specifies how to decode remaining data.-decodeWithTag :: String -> [TaggedDecoder a] -> Get a-decodeWithTag what decoders = Get.label what $ do-  tag <- Get.label (what <> " tag") Get.getWord8-  -- Number of decoders is usually small, so linear runtime lookup should be ok.-  case List.find ((tag ==) . tdTag) decoders of-    Nothing -> unknownTag what tag-    Just TaggedDecoder{..} -> tdDecoder- ---------------------------------------------------------------------------- -- Michelson serialisation ----------------------------------------------------------------------------@@ -219,14 +165,7 @@ decodeValue = Get.label "Value" $   case sing @t of     STKey -> T.VKey <$> decodeAsBytesOrString-      ( decodeWithTag "key"-        [ 0x00 #: decodeBytesLike "key Ed25519"-            (fmap PublicKeyEd25519 . Ed25519.mkPublicKey)-        , 0x01 #: decodeBytesLike "key Secp256k1"-            (fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey)-        , 0x02 #: decodeBytesLike "key P256"-            (fmap PublicKeyP256 . P256.mkPublicKey)-        ]+      ( decodeWithTag "key" keyDecoders       , parsePublicKey       )     STUnit -> do@@ -303,7 +242,10 @@       expectTag "Timestamp" 0x00       T.VTimestamp . timestampFromSeconds <$> decodeInt     STAddress ->-      T.VAddress <$> decodeEpAddress+      T.VAddress <$> decodeAsBytesOrString+      ( decodeBytesLike "EpAddress" parseEpAddressRaw+      , parseEpAddress+      )  withUnpackedValueScope   :: forall a v m. (KnownT a, MonadFail m)@@ -322,15 +264,6 @@   Just Dict -> act   Nothing -> fail "Comparable type is required here" -keyHashDecoders :: [TaggedDecoder KeyHash]-keyHashDecoders =-  [ 0x00 #: KeyHash KeyHashEd25519 <$> getPayload-  , 0x01 #: KeyHash KeyHashSecp256k1 <$> getPayload-  , 0x02 #: KeyHash KeyHashP256 <$> getPayload-  ]-  where-    getPayload = getByteStringCopy keyHashLengthBytes- -- | Read length of something (list, string, ...). decodeLength :: Get Int decodeLength = Get.label "Length" $ do@@ -384,14 +317,6 @@         Get.isolate l bytesDecoder ? "Binary content"     other -> unknownTag "text or string" other -decodeBytesLike-  :: (Buildable err)-  => String -> (ByteString -> Either err a) -> Get a-decodeBytesLike what constructor = do-  bs <- getRemainingByteStringCopy-  case constructor bs of-    Left err -> fail $ "Wrong " +| what |+ ": " +| err |+ ""-    Right res -> pure res  decodeBytesLikeMaybe   :: String -> (ByteString -> Maybe a) -> Get a@@ -417,33 +342,6 @@     either (fail . toString) pure $       Map.fromDistinctAscList <$> ensureDistinctAsc fst es -decodeEpAddress :: Get EpAddress-decodeEpAddress = Get.label "Address (maybe with entrypoint)" $-  decodeAsBytesOrString-  ( decodeWithTag "address"-      [ 0x00 #: Get.label "Plain address" $ do-          eaAddress <- KeyAddress <$>-            decodeWithTag "key_hash inside address" keyHashDecoders-          eaEntryPoint <- decodeEpName-          return EpAddress{..}-      , 0x01 #: Get.label "Contract address" $ do-          eaAddress <- ContractAddress . ContractHash <$>-            getByteStringCopy keyHashLengthBytes-          expectTag "Contract address suffix" 0x00-          eaEntryPoint <- decodeEpName-          return EpAddress{..}-      ]-  , parseEpAddress-  )--decodeEpName :: Get EpName-decodeEpName = do-  ss <- many Get.getWord8 ? "EpName' String content"-  s <- decodeUtf8' (BS.pack ss)-    & either (fail . show) pure-    ? "EpName' String UTF-8 decoding"-  either (fail . pretty) pure $ epNameFromRefAnn (ann s)- -- | Read a numeric value. decodeInt :: Num i => Get i decodeInt = fromIntegral @Integer <$> loop 0 0 ? "Number"@@ -500,12 +398,7 @@       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 = error "runInstrImpl(UNPACK): tcContracts touched"-        --- ^ Used only in typechecking of @contract@ values,-        ---   but it's not possible to unpack to ones.+      , tcMode = TypeCheckPack       }  decodeInstr :: Get ExpandedInstr@@ -722,17 +615,36 @@  decodeContract :: Get Contract decodeContract = decodeAsList $ do-  expectTag "Pre contract parameter" 0x05-  expectTag "Contract parameter" 0x00-  (t, ta, root) <- decodeTWithAnns-  expectTag "Pre contract storage" 0x05-  expectTag "Contract storage" 0x01-  s <- decodeType-  expectTag "Pre contract code" 0x05-  expectTag "Contract code" 0x02-  c <- decodeOps-  pure (Contract (ParameterType (Type t ta) (convAnn root)) s c)+  result <- contractTuple+  case orderContractBlock result of+    Just contract' -> do+      pure contract'+    Nothing ->+      fail "Duplicate contract field."+  where+    decodeParamsBlock = CBParam <$> do+      expectTag "Pre contract parameter" 0x05+      expectTag "Contract parameter" 0x00+      (t, ta, root) <- decodeTWithAnns+      pure $ ParameterType (Type t ta) (convAnn root)+    decodeStorageBlock = CBStorage <$> do+      expectTag "Pre contract storage" 0x05+      expectTag "Contract storage" 0x01+      decodeType+    decodeCodeBlock = CBCode <$> do+      expectTag "Pre contract code" 0x05+      expectTag "Contract code" 0x02+      decodeOps +    contractBlock = decodeParamsBlock <|> decodeStorageBlock <|> decodeCodeBlock++    contractTuple = do+      result1 <- contractBlock+      result2 <- contractBlock+      result3 <- contractBlock+      pure (result1, result2, result3)++ decodeOp :: Get ExpandedOp decodeOp = Get.label "Op" $ do   tag <- Get.lookAhead Get.getWord8@@ -779,6 +691,7 @@     0x05 -> decodeWithTFAnns (ct,,)     _ -> fail failMessage +{-# ANN decodeTWithAnns ("HLint: ignore Redundant <$>" :: Text) #-} decodeTWithAnns :: Get (T, TypeAnn, FieldAnn) decodeTWithAnns = doDecode <|> decodeTc ? "Type"   where

@@ -7,6 +7,7 @@   -- * Macros types     CadrStruct (..)   , PairStruct (..)+  , UnpairStruct (..)   , Macro (..)   , LetMacro (..) @@ -23,7 +24,8 @@   , expandValue      -- * For parsing-  , mapLeaves+  , mapPairLeaves+  , mapUnpairLeaves      -- * Internals exported for tests   , expand@@ -62,7 +64,7 @@ instance NFData LetMacro  data PairStruct-  = F (VarAnn, FieldAnn)+  = F FieldAnn   | P PairStruct PairStruct   deriving stock (Eq, Show, Data, Generic) @@ -71,6 +73,16 @@ instance Buildable PairStruct where   build = genericF +data UnpairStruct+  = UF (VarAnn, FieldAnn)+  | UP UnpairStruct UnpairStruct+  deriving stock (Eq, Show, Data, Generic)++instance NFData UnpairStruct++instance Buildable UnpairStruct where+  build = genericF+ data CadrStruct   = A   | D@@ -127,7 +139,7 @@   | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]   | FAIL   | PAPAIR PairStruct TypeAnn VarAnn-  | UNPAIR PairStruct+  | UNPAIR UnpairStruct   | CADR [CadrStruct] VarAnn FieldAnn   | SET_CADR [CadrStruct] VarAnn FieldAnn   | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]@@ -208,7 +220,7 @@   -- It's needed because we have a hack in parser: we parse PAIR as PAPAIR.   -- We need to do something better eventually.   (Mac (PAPAIR (P (F a) (F b)) t v) pos) ->-    WithSrcEx (ics pos) $ PrimEx (PAIR t v (snd a) (snd b))+    WithSrcEx (ics pos) $ PrimEx (PAIR t v a b)   -- DIIP is now always represented as a single instruction.   -- `expandMacro` always returns a list which we wrap into `SeqEx`, so we   -- can't use it.@@ -229,7 +241,7 @@  expandMacro :: InstrCallStack -> Macro -> [ExpandedOp] expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case-  VIEW a             -> expandMacro p (UNPAIR $ P (F (noAnn,noAnn)) (F (noAnn,noAnn))) +++  VIEW a             -> expandMacro p (UNPAIR $ UP (UF (noAnn, noAnn)) (UF (noAnn, noAnn))) ++                         [ PrimEx (DIP $ expandMacro p $ DUUP 2 noAnn) ] ++                         [ PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++                         (expand cs <$> a) ++@@ -240,7 +252,7 @@                         , PrimEx $ CONS noAnn                         , PrimEx $ PAIR noAnn noAnn noAnn noAnn                         ]-  VOID a             -> expandMacro p (UNPAIR (P (F (noAnn,noAnn)) (F (noAnn,noAnn)))) +++  VOID a             -> expandMacro p (UNPAIR (UP (UF (noAnn, noAnn)) (UF (noAnn, noAnn)))) ++                         [ PrimEx SWAP                         , PrimEx $ DIP $ expand cs <$> a                         , PrimEx SWAP@@ -285,11 +297,11 @@ -- 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) (F b) -> [PrimEx $ PAIR t v a b]   P (F a) r     -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)-                              , PAIR t v (snd a) noAnn]+                              , PAIR t v a noAnn]   P l     (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) ++-                   [PrimEx $ PAIR t v noAnn (snd b)]+                   [PrimEx $ PAIR t v noAnn b]   P l     r     -> expandMacro ics (PAPAIR l noAnn noAnn) ++                    [ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)                    , PrimEx $ PAIR t v noAnn noAnn]@@ -297,34 +309,34 @@   -- 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 :: InstrCallStack -> UnpairStruct -> [ExpandedOp] expandUnpapair ics = \case-  P (F (v,f)) (F (w,g)) ->+  UP (UF (v,f)) (UF (w,g)) ->     PrimEx <$> [ DUP noAnn                , CAR v f                , DIP [PrimEx $ CDR w g]                ]-  P (F (v, f)) r ->+  UP (UF (v, f)) r ->     PrimEx <$> [ DUP noAnn                , CAR v f                , DIP (PrimEx (CDR noAnn noAnn) : expandMacro ics (UNPAIR r))                ]-  P l     (F (v, f))    ->+  UP l (UF (v, f)) ->     map PrimEx [ DUP noAnn                , DIP [PrimEx $ CDR v f]                , CAR noAnn noAnn                ] ++                expandMacro ics (UNPAIR l)-  P l      r ->+  UP 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,+  UF _  -> [] -- Do nothing in this case.+  -- It's impossible from the structure of UnpairStruct and considered cases above,   -- but if it accidentally happened let's just do nothing.   where-    unpairOne = UNPAIR (P fn fn)-    fn = F (noAnn, noAnn)+    unpairOne = UNPAIR (UP fn fn)+    fn = UF (noAnn, noAnn)  expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp] expandCadr ics cs v f = case cs of@@ -420,25 +432,41 @@         ]     pre e = Endo (e :) --mapLeaves :: [(VarAnn, FieldAnn)] -> PairStruct -> PairStruct-mapLeaves fs p = evalState (leavesST p) fs+mapPairLeaves :: [FieldAnn] -> PairStruct -> PairStruct+mapPairLeaves fs p = evalState (pairLeavesST p) fs -leavesST :: PairStruct -> State [(VarAnn, FieldAnn)] PairStruct-leavesST = \case+pairLeavesST :: PairStruct -> State [FieldAnn] PairStruct+pairLeavesST = \case   (P l r) -> do-    l' <- leavesST l-    r' <- leavesST r+    l' <- pairLeavesST l+    r' <- pairLeavesST r     return $ P l' r'   (F _) -> do     f <- state getLeaf     return $ F f     where       getLeaf (a:as) = (a, as)+      getLeaf _      = (noAnn, [])++mapUnpairLeaves :: [(VarAnn, FieldAnn)] -> UnpairStruct -> UnpairStruct+mapUnpairLeaves fs p = evalState (unpairLeavesST p) fs++unpairLeavesST :: UnpairStruct -> State [(VarAnn, FieldAnn)] UnpairStruct+unpairLeavesST = \case+  (UP l r) -> do+    l' <- unpairLeavesST l+    r' <- unpairLeavesST r+    return $ UP l' r'+  (UF _) -> do+    f <- state getLeaf+    return $ UF f+    where+      getLeaf (a:as) = (a, as)       getLeaf _      = ((noAnn, noAnn), [])  deriveJSON morleyAesonOptions ''ParsedOp deriveJSON morleyAesonOptions ''LetMacro deriveJSON morleyAesonOptions ''PairStruct+deriveJSON morleyAesonOptions ''UnpairStruct deriveJSON morleyAesonOptions ''CadrStruct deriveJSON morleyAesonOptions ''Macro

@@ -155,7 +155,7 @@ expandedInstrsOpSize = foldMap expandedInstrOpSize  contractOpSize :: Contract -> OpSize-contractOpSize (Contract (ParameterType cp rootAnn) st is) =+contractOpSize (Contract (ParameterType cp rootAnn) st is _) =   OpSize 16 <> typeOpSize' [convAnn rootAnn] cp <> typeOpSize st <> expandedInstrsOpSize is  numOpSize :: Integral i => i -> OpSize

@@ -23,6 +23,7 @@    -- * For tests   , codeEntry+  , ops   , type_   , letInner   , letType@@ -41,7 +42,6 @@  import Prelude hiding (try) -import Control.Applicative.Permutations (intercalateEffect, toPermutation) import qualified Language.Haskell.TH.Quote as TH import Text.Megaparsec   (Parsec, choice, eitherP, eof, errorBundlePretty, getSourcePos, lookAhead, parse, try)@@ -90,27 +90,66 @@       env <- fromMaybe noLetEnv <$> (optional (letBlock parsedOp))       local (const env) contract +cbParameter :: Parser ParameterType+cbParameter = do+  (fieldAnn, t) <- symbol "parameter" *> field+  pure $ ParameterType t (convAnn fieldAnn)++cbStorage :: Parser Type+cbStorage = symbol "storage" *> type_++cbCode :: Parser [ParsedOp]+cbCode = symbol "code" *> codeEntry++contractBlock :: Parser (ContractBlock ParsedOp)+contractBlock = choice+  [ (CBParam <$> cbParameter)+  , (CBStorage <$> cbStorage)+  , (CBCode <$> cbCode)+  ]++-- | This ensures that the error message will point to the correct line.+ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()+ensureNotDuplicate blocks result =+  let+    failDuplicateField a = fail $ "Duplicate contract field: " <> a+  in+    case (result, blocks) of+      (CBParam _, CBParam _ : _) -> failDuplicateField "parameter"+      (CBStorage _, CBStorage _: _) -> failDuplicateField "storage"+      (CBCode _, CBCode _: _) -> failDuplicateField "code"+      (_, _:xs) -> ensureNotDuplicate xs result+      (_, []) -> pure ()+ -- | Michelson contract contract :: Parser (Contract' ParsedOp) contract = do   mSpace-  ((r, p), s, c) <- braces contractTuple <|> contractTuple-  return $ Contract (ParameterType p (convAnn r)) s c+  result <- braces contractTuple <|> contractTuple+  case orderContractBlock result of+    Just contract' ->+      return contract'+    Nothing ->+      fail $ "Duplicate contract field: " <> show result   where-    contractTuple = intercalateEffect semicolon $-                     (,,) <$> toPermutation parameter-                          <*> toPermutation storage-                          <*> toPermutation code--    parameter :: Parser (FieldAnn, Type)-    parameter = symbol "parameter" *> field--    storage :: Parser Type-    storage = symbol "storage" *> type_+    -- | @ensureNotDuplicate@ provides a better message and point to the correct line+    -- when the parser fails.+    contractTuple = do+      result1 <- contractBlock+      semicolon -    code :: Parser [ParsedOp]-    code = symbol "code" *> codeEntry+      result2 <- do+        r <- contractBlock+        ensureNotDuplicate [result1] r+        pure r+      semicolon +      result3 <- do+        r <- contractBlock+        ensureNotDuplicate [result1, result2] r+        pure r+      optional semicolon+      pure (result1, result2, result3)  -- Value ------------------

@@ -19,7 +19,7 @@ import Text.Megaparsec (customFailure, notFollowedBy, try) import Text.Megaparsec.Char.Lexer (decimal) -import Michelson.Macro (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..))+import Michelson.Macro (CadrStruct(..), Macro(..), PairStruct(..), UnpairStruct(..), ParsedOp(..)) import qualified Michelson.Macro as Macro import Michelson.Parser.Annotations import Michelson.Parser.Error@@ -68,28 +68,35 @@   where     num str = fromIntegral . length <$> some (string' str) +pairMacInner :: Parser PairStruct+pairMacInner = do+  string' "P"+  l <- (string' "A" $> F noAnn) <|> pairMacInner+  r <- (string' "I" $> F noAnn) <|> pairMacInner+  return $ P l r+ pairMac :: Parser Macro pairMac = do   a <- pairMacInner   symbol' "R"   (tn, vn, fns) <- permute3Def noteDef note (some note)-  let ps = Macro.mapLeaves ((noAnn,) <$> fns) a+  let ps = Macro.mapPairLeaves fns a   return $ PAPAIR ps tn vn -pairMacInner :: Parser PairStruct-pairMacInner = do+upairMacInner :: Parser UnpairStruct+upairMacInner = do   string' "P"-  l <- (string' "A" $> F (noAnn, noAnn)) <|> pairMacInner-  r <- (string' "I" $> F (noAnn, noAnn)) <|> pairMacInner-  return $ P l r+  l <- (string' "A" $> UF (noAnn, noAnn)) <|> upairMacInner+  r <- (string' "I" $> UF (noAnn, noAnn)) <|> upairMacInner+  return $ UP l r  unpairMac :: Parser Macro unpairMac = do   string' "UN"-  a <- pairMacInner+  a <- upairMacInner   symbol' "R"   (vns, fns) <- permute2Def (some note) (some note)-  return $ UNPAIR (Macro.mapLeaves (zip vns fns) a)+  return $ UNPAIR (Macro.mapUnpairLeaves (zip vns fns) a)  cadrMac :: Parser Macro cadrMac = lexeme $ do

@@ -16,9 +16,9 @@  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 qualified Text.Hex as Hex  import Text.Megaparsec (anySingle, choice, customFailure, manyTill, satisfy, takeWhileP, try) import Text.Megaparsec.Char (char, string)@@ -80,10 +80,11 @@ bytesLiteral = do   string "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+  let mBytes = Hex.decodeHex hexdigits+  maybe+    (customFailure OddNumberBytesException)+    (return . U.ValueBytes . U.InternalByteString)+    mBytes  intLiteral :: Parser (U.Value' op) intLiteral = try $ U.ValueInt <$> L.signed pass L.decimal

@@ -16,7 +16,6 @@   , parseExpandContract   , readAndParseContract   , prepareContract-  , typeCheckWithDb    -- * Re-exports   , ContractState (..)@@ -63,8 +62,7 @@ import qualified Michelson.Parser as P import Michelson.Runtime.GState import Michelson.Runtime.TxData-import Michelson.TypeCheck-  (SomeContract, TCError, typeCheckContract, typeCheckTopLevelType, typeVerifyTopLevelType)+import Michelson.TypeCheck (TCError, typeVerifyParameter) import Michelson.Typed   (CreateContract(..), EpName, Operation'(..), SomeValue'(..), TransferTokens(..),   convertContractCode, untypeValue)@@ -431,12 +429,8 @@   gs <- use esGState   originationNonce <- use esOriginationNonce -  typedContract <- liftEither $ first EEIllTypedContract $-    typeCheckContract (extractAllContracts gs) (ooContract origination)-  typedStorage <- liftEither $ first EEIllTypedStorage $-    typeCheckTopLevelType-      (extractAllContracts gs) (U.contractStorage $ ooContract origination)-      (ooStorage origination)+  contractState <- liftEither $ mkContractState EEIllTypedContract EEIllTypedStorage+    (ooBalance origination, ooContract origination, ooStorage origination)   let originatorAddress = ooOriginator origination   originatorBalance <- case gsAddresses gs ^. at originatorAddress of     Nothing -> throwError (EEUnknownManager originatorAddress)@@ -450,13 +444,13 @@   let     address = mkContractAddress opHash $ OriginationIndex originationNonce     updates =-      [ GSAddAddress address (ASContract $ mkContractState typedContract typedStorage)+      [ GSAddAddress address (ASContract contractState)       , GSSetBalance originatorAddress originatorBalance       , GSIncrementCounter       ]   case applyUpdates updates gs of     Left _ ->-      throwError $ EEAlreadyOriginated address $ mkContractState typedContract typedStorage+      throwError $ EEAlreadyOriginated address contractState     Right newGS -> do       esGState .= newGS       esOriginationNonce += 1@@ -464,14 +458,6 @@       esLog <>= ExecutorLog updates []        return address-  where-    mkContractState typedContract typedStorage = ContractState-      { csBalance = ooBalance origination-      , csStorage = ooStorage origination-      , csContract = ooContract origination-      , csTypedContract = Just typedContract-      , csTypedStorage = Just typedStorage-      }  -- | Execute a transfer operation. executeTransfer@@ -523,12 +509,12 @@           newBalance = oldBalance `unsafeAddMutez` tdAmount txData           upd = GSSetBalance addr newBalance         onlyUpdates [upd]-      (Just (ASContract cs), _) -> do+      (Just (ASContract (ContractState {..})), _) -> do         let           existingContracts = extractAllContracts gs           -- can't overflow if global state is correct (because we can't           -- create money out of nowhere)-          newBalance = csBalance cs `unsafeAddMutez` tdAmount txData+          newBalance = csBalance `unsafeAddMutez` tdAmount txData           contractEnv = ContractEnv             { ceNow = now             , ceMaxSteps = remainingSteps@@ -543,13 +529,11 @@             }           epName = tdEntrypoint txData -        SomeContractAndStorage typedContract typedStorage-          <- liftEither $ getTypedContractAndStorage EEIllTypedContract EEIllTypedStorage gs cs-        T.MkEntryPointCallRes _ epc-          <- T.mkEntryPointCall epName (T.cParamNotes typedContract)+        T.MkEntrypointCallRes _ epc+          <- T.mkEntrypointCall epName (T.cParamNotes csContract)              & maybe (throwError $ EEUnknownEntrypoint epName) pure         typedParameter <- liftEither $ first EEIllTypedParameter $-           typeVerifyTopLevelType existingContracts (tdParameter txData)+           typeVerifyParameter existingContracts (tdParameter txData)         iur@InterpretResult           { iurOps = sideEffects           , iurNewStorage = newValue@@ -557,16 +541,15 @@           }           <- liftEither $ first (EEInterpreterFailed addr) $              handleContractReturn $-                interpret (T.cCode typedContract) epc-                typedParameter typedStorage contractEnv+                interpret (T.cCode csContract) epc+                typedParameter csStorage contractEnv         let-          newValueU = untypeValue newValue           updBalance-            | newBalance == csBalance cs = Nothing+            | newBalance == csBalance = Nothing             | otherwise = Just $ GSSetBalance addr newBalance           updStorage-            | SomeValue newValue == SomeValue typedStorage = Nothing-            | otherwise = Just $ GSSetStorageValue addr newValueU (SomeValue newValue)+            | SomeValue newValue == SomeValue csStorage = Nothing+            | otherwise = Just $ GSSetStorageValue addr newValue           updates = catMaybes             [ updBalance             , updStorage@@ -586,18 +569,6 @@     esLog <>= ExecutorLog updates (maybe mempty (one . (addr, )) maybeInterpretRes)      return $ mapMaybe (convertOp addr) sideEffects--------------------------------------------------------------------------------- TypeCheck-------------------------------------------------------------------------------typeCheckWithDb-  :: FilePath-  -> U.Contract-  -> IO (Either TCError SomeContract)-typeCheckWithDb dbPath morleyContract = do-  gState <- readGState dbPath-  pure . typeCheckContract (extractAllContracts gState) $ morleyContract  ---------------------------------------------------------------------------- -- Simple helpers

@@ -8,10 +8,7 @@   (     -- * Auxiliary types     ContractState (..)-  , getTypedContract-  , getTypedStorage-  , SomeContractAndStorage (..)-  , getTypedContractAndStorage+  , mkContractState   , AddressState (..)   , asBalance @@ -56,16 +53,16 @@ import Data.List.NonEmpty ((!!)) import qualified Data.Map.Strict as Map import Data.Typeable ((:~:)(..), eqT)-import Fmt ((+|), (|+), (||+))-import Formatting.Buildable (Buildable(build))+import Fmt (Buildable(build), (+|), (|+), (||+)) import System.IO.Error (IOError, isDoesNotExistError)  import Michelson.TypeCheck-  (SomeContract(..), TCError, TcOriginatedContracts, typeCheckContract, typeCheckTopLevelType)-import Michelson.Typed (SomeValue, SomeValue'(..))+  (SomeContract(..), SomeParamType(..), TCError(..), TcOriginatedContracts, typeCheckContract,+  typeCheckStorage)+import Michelson.Typed (SomeValue'(..)) import qualified Michelson.Typed as T import Michelson.Typed.Scope-import Michelson.Untyped (Contract, ParameterType, Value, contractParameter, contractStorage)+import Michelson.Untyped (Contract, Value, contractStorage) import Tezos.Address (Address(..), ContractHash) import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId) import Tezos.Crypto@@ -73,53 +70,56 @@ import Util.Lens  -- | State of a contract with code.-data ContractState = ContractState+data ContractState =+  forall cp st. (ParameterScope cp, StorageScope st) => ContractState   { csBalance :: Mutez   -- ^ Amount of mutez owned by this contract.-  , csStorage :: Value+  , csContract :: T.Contract cp st+  -- ^ Contract itself.+  , csStorage :: T.Value st   -- ^ Storage value associated with this contract.-  , csContract :: Contract-  -- ^ Contract itself (untyped).-  , csTypedContract :: (Maybe SomeContract)-  , csTypedStorage :: (Maybe SomeValue)-  -- ^ We keep typed representation of contract code-  -- and storage in form, that hides their actual type-  -- in order to simplify the rest of the code-  -- (e.g. avoid type parameters for `ContractState` and so on).-  -- They are made optional in order to perform safe parsing-  -- from JSON (we simply return `Nothing` in this parser and use-  -- `getTypedStorage` or `getTypedContract` that optionally typecheck-  -- storage or contract code).   }  deriving stock instance Show ContractState +mkContractState+  :: (TCError -> err)+  -> (TCError -> err)+  -> (Mutez, Contract, Value)+  -> Either err ContractState+mkContractState liftContractErr liftStorageErr (balance, uContract, uStorage) = do+  SomeContract (contract@T.Contract{} :: T.Contract cp st) <- first liftContractErr $ typeCheckContract uContract+  SomeValue (storage :: T.Value st') <- first liftStorageErr $ typeCheckStorage (contractStorage uContract) uStorage+  case eqT @st @st' of+    Just Refl -> pure $ ContractState balance contract storage+    _ -> Left $ liftStorageErr (TCContractError "Storage type does not match the contract in runtime state" Nothing)+ instance ToJSON ContractState where-  toJSON ContractState{..} = object+  toJSON ContractState{..} =+    object     [ "balance" .= csBalance-    , "storage" .= csStorage-    , "contract" .= csContract+    , "storage" .= T.untypeValue csStorage+    , "contract" .= T.convertContract csContract     ]  -- These instance is a bit hacky because it is quite painful to -- write proper JSON instances for typed `Instr` and `Value` so -- we typecheck untyped representation instead of parsing. instance FromJSON ContractState where-  parseJSON = withObject "contractstate" $ \o -> do-    csBalance <- o .: "balance"-    csStorage <- o .: "storage"-    csContract <- o .: "contract"-    let csTypedContract = Nothing-    let csTypedStorage = Nothing-    return ContractState {..}+  parseJSON =+    withObject "contractstate" $ \o -> do+      (balance :: Mutez) <- o .: "balance"+      (uStorage :: Value) <- o .: "storage"+      (uContract :: Contract) <- o .: "contract"+      case mkContractState id id (balance, uContract, uStorage) of+        Right r -> return r+        Left err -> fail $ "Unable to parse `ContractState`: " <> (show err)  instance Buildable ContractState where   build ContractState{..} =     "Contractstate:\n csBalance: " +| csBalance |+-    "\n  csStorage: " +| csStorage |+-    "\n  csContract: " +| csContract |+-    "\n  csTypedContract: " +| csTypedContract ||+-    "\n  csTypedStorage: " +| csTypedStorage ||+ ""+    "\n  csContract: " +| T.untypeValue csStorage ||++    "\n  csStorage: " +| T.convertContract csContract ||+ ""  -- | State of an arbitrary address. data AddressState@@ -160,37 +160,9 @@  deriveJSON morleyAesonOptions ''GState -getTypedContract :: GState -> ContractState -> Either TCError SomeContract-getTypedContract gs ContractState{..} =-  typeCheckContract (extractAllContracts gs) csContract -getTypedStorage :: GState -> ContractState -> Either TCError SomeValue-getTypedStorage gs ContractState{..} =-  typeCheckTopLevelType (extractAllContracts gs) (contractStorage csContract) csStorage --- [#36] TODO: try to get rid of this type, 'ContractState' should become--- broader than it-data SomeContractAndStorage =-  forall cp st. (ParameterScope cp, StorageScope st) => SomeContractAndStorage-  { scsContract :: T.Contract cp st-  , scsStorage :: T.Value st-  } -getTypedContractAndStorage-  :: (TCError -> err)-  -> (TCError -> err)-  -> GState-  -> ContractState-  -> Either err SomeContractAndStorage-getTypedContractAndStorage liftContractErr liftStorageErr gs cs = do-  SomeContract (contract@T.Contract{} :: T.Contract cp st) <--    first liftContractErr $ getTypedContract gs cs-  SomeValue (storage :: T.Value st') <--    first liftStorageErr $ getTypedStorage gs cs-  Refl <- pure $ eqT @st @st'-              ?: error "Storage type does not match the contract in runtime state"-  return $ SomeContractAndStorage contract storage- -- | Number of genesis addresses. genesisAddressesNum :: Word genesisAddressesNum = 10@@ -280,20 +252,21 @@       }  -- | Updates that can be applied to 'GState'.-data GStateUpdate-  = GSAddAddress Address AddressState-  | GSSetStorageValue Address Value SomeValue-  | GSSetBalance Address Mutez-  | GSIncrementCounter-  deriving stock (Show)+data GStateUpdate where+  GSAddAddress :: Address -> AddressState -> GStateUpdate+  GSSetStorageValue :: StorageScope st => Address -> T.Value st -> GStateUpdate+  GSSetBalance :: Address -> Mutez -> GStateUpdate+  GSIncrementCounter :: GStateUpdate +deriving stock instance Show GStateUpdate+ 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 |+ ""+      GSSetStorageValue addr tVal ->+        "Set storage value of address " +| addr |+ " to " +| T.untypeValue tVal |+ ""       GSSetBalance addr balance ->         "Set balance of address " +| addr |+ " to " +| balance |+ ""       GSIncrementCounter ->@@ -303,6 +276,7 @@   = GStateAddressExists Address   | GStateUnknownAddress Address   | GStateNotContract Address+  | GStateStorageNotMatch Address   deriving stock (Show)  instance Buildable GStateUpdateError where@@ -311,6 +285,9 @@       GStateAddressExists addr -> "Address already exists: " <> build addr       GStateUnknownAddress addr -> "Unknown address: " <> build addr       GStateNotContract addr -> "Address doesn't have contract: " <> build addr+      GStateStorageNotMatch addr ->+        "Storage type does not match the contract in run-time state\+        \ when updating new storage value to address: " <> build addr  -- | Apply 'GStateUpdate' to 'GState'. applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState@@ -318,8 +295,8 @@   \case     GSAddAddress addr st ->       maybeToRight (GStateAddressExists addr) . addAddress addr st-    GSSetStorageValue addr newValue newTypedValue ->-      setStorageValue addr newValue newTypedValue+    GSSetStorageValue addr newValue ->+      setStorageValue addr newValue     GSSetBalance addr newBalance -> setBalance addr newBalance     GSIncrementCounter -> Right . over gsCounterL (+1) @@ -335,18 +312,19 @@   where     accounts = gsAddresses gs --- | Updare storage value associated with given address.-setStorageValue ::-     Address -> Value -> SomeValue -> GState -> Either GStateUpdateError GState-setStorageValue addr newValue newTypedValue = updateAddressState addr modifier+-- | Update storage value associated with given address.+setStorageValue :: forall st. (StorageScope st) =>+     Address -> T.Value st -> GState -> Either GStateUpdateError GState+setStorageValue addr newValue = updateAddressState addr modifier   where+    modifier :: AddressState -> Either GStateUpdateError AddressState     modifier (ASSimple _) = Left (GStateNotContract addr)-    modifier (ASContract cs) = Right $ ASContract $-      cs { csStorage = newValue-         , csTypedStorage = Just newTypedValue-         }+    modifier (ASContract (ContractState b c (_ :: T.Value st') )) = do+      case (eqT @st @st') of+        Just Refl -> Right $ ASContract $ ContractState b c newValue+        _ -> Left $ GStateStorageNotMatch addr --- | Updare storage value associated with given address.+-- | Update storage value associated with given address. setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState setBalance addr newBalance = updateAddressState addr (Right . modifier)   where@@ -372,10 +350,10 @@ extractAllContracts = Map.fromList . mapMaybe extractContract . toPairs . gsAddresses  where     extractContract-      :: (Address, AddressState) -> Maybe (ContractHash, ParameterType)+      :: (Address, AddressState) -> Maybe (ContractHash, SomeParamType)     extractContract =       \case (KeyAddress _, ASSimple {}) -> Nothing             (KeyAddress _, _) -> error "broken GState"-            (ContractAddress ca, ASContract cs) ->-              Just (ca, contractParameter $ csContract cs)+            (ContractAddress ca, ASContract (ContractState{..})) ->+              Just (ca, SomeParamType sing $ T.cParamNotes $ csContract)             (ContractAddress _, _) -> error "broken GState"

@@ -1,113 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | 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-  , specWithTypedContract-  , specWithUntypedContract-  , testTreesWithContract-  , testTreesWithUntypedContract-  , testTreesWithTypedContract-  , concatTestTrees-  , importContract-  , importUntypedContract--  -- * Unit testing-  , ContractReturn-  , ContractPropValidator-  , contractProp-  , contractPropVal-  , validateSuccess-  , validateStorageIs-  , validateMichelsonFailsWith--  -- * Integrational testing-  -- ** Testing engine-  , IntegrationalScenario-  , IntegrationalScenarioM-  , integrationalTestExpectation-  , integrationalTestProp-  , originate-  , tOriginate-  , transfer-  , tTransfer-  , integrationalFail-  , unexpectedInterpreterError-  , setMaxSteps-  , setNow-  , rewindTime-  , withSender-  , setChainId-  , branchout-  , (?-)--  -- ** Validators-  , expectNoUpdates-  , expectNoStorageUpdates-  , expectStorageUpdate-  , expectStorageUpdateConst-  , expectBalance-  , expectStorage-  , expectStorageConst-  , tExpectStorageConst--  -- ** Errors-  , attempt-  , expectError-  , catchExpectedError-  , expectGasExhaustion-  , expectMichelsonFailed--  -- ** Various-  , TxData (..)-  , genesisAddress--  -- * General utilities-  , failedTest-  , succeededTest-  , eitherIsLeft-  , eitherIsRight-  , total-  , meanTimeUpperBoundProp-  , meanTimeUpperBoundPropNF--  -- * Re-exports-  ---  -- | These functions from "Time" are re-exported here to make it convenient to call-  -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.-  , mcs, ms, sec, minute--  -- * Autodoc testing-  , runDocTests-  , testDocBasic-  , excludeDocTests--  -- * Dummy values-  , dummyContractEnv--  -- * Arbitrary data-  , minTimestamp-  , maxTimestamp-  , midTimestamp--  -- * Deprecated-  , integrationalTestProperty-  , failedProp-  , succeededProp-  , qcIsLeft-  , qcIsRight-  ) where--import Michelson.Doc.Test-import Michelson.Test.Dummy-import Michelson.Test.Gen-import Michelson.Test.Import-import Michelson.Test.Integrational-import Michelson.Test.Unit-import Michelson.Test.Util

@@ -1,62 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | 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)-import Michelson.Untyped-import Tezos.Core (Timestamp(..), dummyChainId, 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-  , ceChainId = dummyChainId-  , ceOperationHash = Nothing-  }---- | '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-  { ooOriginator = genesisAddress-  , ooDelegate = Nothing-  , ooBalance = unsafeMkMutez 100-  , ooStorage = storage-  , ooContract = contract-  }

@@ -1,128 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--{-# OPTIONS_GHC -Wno-orphans #-}---- | Utilities for arbitrary data generation in property tests.------   == Deprecation Notice------   At the moment, this module exposes both Hedgehog generators and QuickCheck `Arbitrary`---   instances for convenience.---   However, `Arbitrary` instances should be considered deprecated and will eventually be removed.--module Michelson.Test.Gen-  ( minTimestamp-  , maxTimestamp-  , midTimestamp-  , genMutez-  , genTimestamp-  , genValueKeyHash-  , genValueMutez-  , genValueInt-  , genValueList-  , genValueUnit-  , genValuePair-  , genValueTimestamp-  ) where--import Data.Time.Calendar (Day, addDays, diffDays)-import Data.Time.Clock (UTCTime(..))-import Data.Time.Format (defaultTimeLocale, parseTimeM)-import Hedgehog (MonadGen)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import Test.QuickCheck (Arbitrary(..), choose)--import Michelson.Typed (KnownT, T(..), Value'(..))-import Tezos.Core-  (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds,-  unsafeMkMutez)-import Tezos.Crypto (genKeyHash)--instance Arbitrary (Value' instr 'TKeyHash) where-  arbitrary = VKeyHash <$> arbitrary-instance Arbitrary (Value' instr 'TMutez) where-  arbitrary = VMutez <$> arbitrary-instance Arbitrary (Value' instr 'TInt) where-  arbitrary = VInt <$> arbitrary-instance (KnownT a, 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--genValueKeyHash :: MonadGen m => m (Value' instr 'TKeyHash)-genValueKeyHash = VKeyHash <$> genKeyHash--genValueMutez :: MonadGen m => m (Value' instr 'TMutez)-genValueMutez = VMutez <$> genMutez--genValueInt :: MonadGen m => m (Value' instr 'TInt)-genValueInt = VInt <$> Gen.integral (Range.linearFrom 0 -1000 1000)--genValueList :: (MonadGen m, KnownT a) => m (Value' instr a) -> m (Value' instr ('TList a))-genValueList genA = VList <$> Gen.list (Range.linear 0 100) genA--genValueUnit :: Applicative m => m (Value' instr 'TUnit)-genValueUnit = pure VUnit--genValuePair :: MonadGen m => m (Value' instr a) -> m (Value' instr b) -> m (Value' instr ('TPair a b))-genValuePair genA genB = VPair ... (,) <$> genA <*> genB---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 (Value' instr 'TTimestamp) where-  arbitrary = VTimestamp <$> arbitrary--instance Arbitrary Mutez where-  arbitrary = unsafeMkMutez <$> choose (unMutez minBound, unMutez maxBound)--instance Arbitrary Timestamp where-  arbitrary =-    timestampFromSeconds <$>-    choose (timestampToSeconds minTimestamp, timestampToSeconds maxTimestamp)--genValueTimestamp :: MonadGen m => m (Value' instr 'TTimestamp)-genValueTimestamp = VTimestamp <$> genTimestamp--genMutez :: MonadGen m => m Mutez-genMutez = unsafeMkMutez <$> Gen.word64 (Range.linear (unMutez minBound) (unMutez maxBound))--genTimestamp :: MonadGen m => m Timestamp-genTimestamp =-  timestampFromSeconds <$> Gen.integral-    (Range.linear (timestampToSeconds minTimestamp) (timestampToSeconds maxTimestamp))

@@ -1,192 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Functions to import contracts to be used in tests.--module Michelson.Test.Import-  (-    -- * Read, parse, typecheck-    readContract-  , importContract-  , importUntypedContract-  , ImportContractError (..)--    -- * Tasty helpers-  , testTreesWithContract-  , testTreesWithTypedContract-  , testTreesWithUntypedContract-  , concatTestTrees--    -- * HSpec helpers-  , specWithContract-  , specWithTypedContract-  , specWithUntypedContract-  ) where--import Control.Exception (IOException)-import Data.Singletons (demote)-import Data.Typeable ((:~:)(..), eqT)-import Fmt (Buildable(build), pretty, (+|), (|+))-import Test.Hspec (Spec, describe, expectationFailure, it, runIO)-import Test.HUnit (assertFailure)-import Test.Tasty (TestTree)-import Test.Tasty.HUnit (testCase)--import Michelson.Parser.Error (ParserException(..))-import Michelson.Runtime (parseExpandContract, prepareContract)-import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract)-import Michelson.Typed (Contract(..), KnownT, toUType)-import qualified Michelson.Untyped as U-import Util.IO--------------------------------------------------------------------------------- tasty helpers--------------------------------------------------------------------------------- | Import contract and use to create test trees. Both versions of contract are--- passed to the callback function (untyped and typed).------ If contract's import fails, a tree with single failing test will be generated--- (so test tree will likely be generated unexceptionally, but a failing--- result will notify about problem).-testTreesWithContract-  :: (Each '[KnownT] [cp, st], HasCallStack)-  => FilePath -> ((U.Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree]-testTreesWithContract = testTreesWithContractImpl importContract---- | Like 'testTreesWithContract' but supplies only untyped contract.-testTreesWithUntypedContract-  :: HasCallStack-  => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]-testTreesWithUntypedContract =-  testTreesWithContractImpl importUntypedContract---- | Like 'testTreesWithContract' but supplies only typed contract.-testTreesWithTypedContract-  :: (Each '[KnownT] [cp, st], HasCallStack)-  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]-testTreesWithTypedContract =-  testTreesWithContractImpl (fmap snd . importContract)--testTreesWithContractImpl-  :: HasCallStack-  => (FilePath -> IO contract)-  -> FilePath-  -> (contract -> IO [TestTree])-  -> IO [TestTree]-testTreesWithContractImpl doImport file testImpl =-  saferImport doImport file >>= \case-    Left err -> pure [testCase ("Import contract " <> file) $ assertFailure err]-    Right contract -> testImpl contract---- A helper function which allows you to use multiple--- 'testTreesWithTypedContract' in a single top-level test with type--- 'IO [TestTree]'.-concatTestTrees :: [IO [TestTree]] -> IO [TestTree]-concatTestTrees = fmap concat . sequence--------------------------------------------------------------------------------- hspec helpers--------------------------------------------------------------------------------- | 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 fails, a spec with single failing expectation--- will be generated (so tests will likely run unexceptionally, but a failing--- result will notify about problem).-specWithContract-  :: (Each '[KnownT] [cp, st], HasCallStack)-  => FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec-specWithContract = specWithContractImpl importContract---- | A version of 'specWithContract' which passes only the typed--- representation of the contract.-specWithTypedContract-  :: (Each '[KnownT] [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 (saferImport doImport file)-  where-    errorSpec = it ("Import contract " <> file) . expectationFailure--------------------------------------------------------------------------------- Helpers--------------------------------------------------------------------------------- Catch some errors during contract import, we don't want the whole--- test suite to crash if something like that happens.-saferImport :: (FilePath -> IO contract) -> FilePath -> IO (Either String contract)-saferImport doImport file =-  ((Right <$> doImport file)-  `catch` \(e :: ImportContractError) -> pure $ Left $ displayException e)-  `catch` \(e :: IOException) -> pure $ Left $ displayException e--------------------------------------------------------------------------------- Reading, parsing, typechecking-------------------------------------------------------------------------------readContract-  :: forall cp st .-     Each '[KnownT] [cp, st]-  => FilePath-  -> Text-  -> Either ImportContractError (U.Contract, Contract cp st)-readContract filePath txt = do-  contract <- first ICEParse $ parseExpandContract (Just filePath) txt-  SomeContract (tContract@Contract{} :: Contract cp' st')-    <- first ICETypeCheck $ typeCheckContract mempty contract-  case (eqT @cp @cp', eqT @st @st') of-    (Just Refl, Just Refl) -> pure (contract, tContract)-    (Nothing, _) -> Left $-      ICEUnexpectedParamType (U.contractParameter contract) (toUType $ demote @cp)-    _ -> Left (ICEUnexpectedStorageType (U.contractStorage 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 '[KnownT] [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.ParameterType U.Type-  | ICEUnexpectedStorageType U.Type U.Type-  | ICEParse ParserException-  | ICETypeCheck TCError-  deriving stock (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

@@ -1,601 +0,0 @@-{-# OPTIONS_GHC -Wno-deprecations #-}---- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | 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-  , IntegrationalScenarioM-  , IntegrationalScenario-  , TestError (..)-  , integrationalTestExpectation-  , integrationalTestProp-  , originate-  , tOriginate-  , transfer-  , tTransfer-  , integrationalFail-  , unexpectedInterpreterError-  , setMaxSteps-  , modifyNow-  , setNow-  , rewindTime-  , withSender-  , setChainId-  , branchout-  , (?-)-  , offshoot--  -- * Validators-  , expectNoUpdates-  , expectNoStorageUpdates-  , expectStorageUpdate-  , expectStorageUpdateConst-  , expectBalance-  , expectStorage-  , expectStorageConst-  , tExpectStorageConst--  -- * Errors-  , attempt-  , expectError-  , catchExpectedError-  , expectGasExhaustion-  , expectMichelsonFailed--  -- * Lenses-  , isGState--  -- * Deprecated-  , integrationalTestProperty-  ) where--import Control.Lens (assign, at, makeLenses, makeLensesFor, modifying, (%=), (.=), (<>=), (?=))-import Control.Monad.Except (Except, catchError, runExcept, throwError, withExcept)-import qualified Data.List as List-import Data.Map as Map (empty, insert, lookup)-import Fmt (Buildable(..), blockListF, listF, pretty, (+|), (|+))-import Hedgehog (MonadTest)-import Named ((:!), arg)-import Test.Hspec (Expectation, expectationFailure)-import qualified Test.QuickCheck as QC--import Michelson.Interpret (InterpretError(..), MichelsonFailed(..), RemainingSteps)-import Michelson.Runtime-  (ExecutorError, ExecutorError'(..), ExecutorM, ExecutorOp(..), ExecutorRes(..),-  executeGlobalOperations, executeOrigination, runExecutorM, withGlobalOperation)-import Michelson.Runtime.GState-import Michelson.Runtime.TxData-import Michelson.Test.Dummy-import Michelson.Test.Util (failedProp, failedTest, succeededProp, succeededTest)-import Michelson.TypeCheck (TCError)-import qualified Michelson.Typed as Typed-import Michelson.Typed.Scope (ParameterScope, StorageScope, properParameterEvi, withDict)-import Michelson.Untyped (Contract, EpName, OriginationOperation(..), Value)-import Tezos.Address (Address)-import Tezos.Core (ChainId, Mutez, Timestamp, timestampPlusSeconds, unsafeMkMutez)--------------------------------------------------------------------------------- Some internals (they are here because TH makes our very existence much harder)--------------------------------------------------------------------------------- | A result of an executed operation.-type ExecutorResOrError a = Either ExecutorError (ExecutorRes, a)-type ExecutorResOrError' = Either ExecutorError ExecutorRes--data InternalState = InternalState-  { _isMaxSteps :: RemainingSteps-  , _isNow :: Timestamp-  , _isGState :: GState-  , _isInterpreterLog :: [ExecutorResOrError']-  -- ^ Store result of interpreted operations as they added.-  , _isExecutorResult :: Maybe ExecutorRes-  -- ^ Store the most recent result of interpreted operations.-  , _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---- | When using 'branch' function for building test scenarios - names--- of branches we are currently within.-newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }--instance Buildable ScenarioBranchName where-  build = mconcat . intersperse "/" . map build . unTestBranch--------------------------------------------------------------------------------- Interface--------------------------------------------------------------------------------- | A monad inside which integrational tests can be described using--- do-notation.-type IntegrationalScenarioM = StateT InternalState (Except ScenarioError)--type IntegrationalScenario = IntegrationalScenarioM ()--newtype ExpectedStorage = ExpectedStorage Value deriving stock (Show)-newtype ExpectedBalance = ExpectedBalance Mutez deriving stock (Show)--data AddressName = AddressName (Maybe Text) Address deriving stock (Show)--addrToAddrName :: Address -> InternalState -> AddressName-addrToAddrName addr iState =-  AddressName (lookup addr (iState ^. isContractsNames)) addr--addrNameToAddr :: AddressName -> Address-addrNameToAddr (AddressName _ addr) = addr--instance Buildable AddressName where-  build (AddressName mbName addr) =-    build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName--type IntegrationalExecutorError = ExecutorError' AddressName--data TestError-  = InterpreterError IntegrationalExecutorError-  | UnexpectedInterpreterError Text IntegrationalExecutorError-  | UnexpectedTypeCheckError TCError-  | ExpectingInterpreterToFail-  | IncorrectUpdates TestError [GStateUpdate]-  | IncorrectStorageUpdate AddressName Text-  | InvalidStorage AddressName ExpectedStorage Text-  | StoragePredicateMismatch AddressName Text-  | InvalidBalance AddressName ExpectedBalance Text-  | UnexpectedUpdates (NonEmpty GStateUpdate)-  | ValidatingEmptyScenario-  | CustomTestError Text-  deriving stock (Show)--instance Buildable TestError where-  build (InterpreterError iErr) =-    "Interpreter failed: " +| iErr |+ ""-  build (UnexpectedInterpreterError reason iErr) =-    "Unexpected interpreter error. Reason: " +| reason |+ ". Got: " +| 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 (StoragePredicateMismatch addr msg) =-    "Expected " +| addr |+ " to have storage that matches the predicate, but" +| msg |+ ""-  build (InvalidBalance addr (ExpectedBalance expected) msg) =-    "Expected " +| addr |+ " to have balance " +| expected |+ ", but " +| msg |+ ""-  build (UnexpectedUpdates updates) =-    "Did not expect certain updates, but there are some: " +| listF updates |+ ""-  build ValidatingEmptyScenario =-    "Validating empty scenario"-  build (CustomTestError msg) = pretty msg--instance Exception TestError where-  displayException = pretty---- | Overall information about test scenario error.-data ScenarioError = ScenarioError-  { _seBranch :: ScenarioBranchName-  , _seError :: TestError-  }--makeLensesFor [("_seBranch", "seBranch")] ''ScenarioError--instance Buildable ScenarioError where-  build (ScenarioError br err) =-    let builtBranch-          | nullScenarioBranch br = ""-          | otherwise = "In '" +| br |+ "' branch:\n"-    in builtBranch <> build err---- | Integrational test that executes given operations and validates--- them. 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-  :: HasCallStack-  => IntegrationalScenario -> Expectation-integrationalTestExpectation =-  integrationalTest (maybe pass (expectationFailure . pretty))---- | Integrational test similar to 'integrationalTestExpectation'.--- It can fail using 'QC.Property' capability.--- It can be used with QuickCheck's @forAll@ to make a--- property-based test with arbitrary data.-integrationalTestProperty :: IntegrationalScenario -> QC.Property-integrationalTestProperty =-  integrationalTest (maybe succeededProp (failedProp . pretty))-{-# DEPRECATED integrationalTestProperty "Use 'integrationalTestProp' instead." #-}---- | Integrational test similar to 'integrationalTestExpectation'.--- It can fail using 'Property' capability.--- It can be used with Hedgehog's @forAll@ to make a--- property-based test with arbitrary data.-integrationalTestProp :: MonadTest m => IntegrationalScenario -> m ()-integrationalTestProp scenario =-  integrationalTest (maybe succeededTest (failedTest . pretty)) scenario---- | Helper function which provides the results of the given operations.-interpret :: ExecutorM a -> IntegrationalScenarioM (ExecutorResOrError a)-interpret action = do-  now <- use isNow-  maxSteps <- use isMaxSteps-  gState <- use isGState-  let interpretedResult = runExecutorM now maxSteps gState action-  whenRight interpretedResult $ \(result, _) -> isGState .= _erGState result-  return interpretedResult---- | Interprets provided list of operations.-registerInterpretation :: [ExecutorOp] -> IntegrationalScenarioM ()-registerInterpretation ops =-  interpret (executeGlobalOperations ops) <&> fmap fst >>= putResult---- | 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-  is <- get-  result <- interpret $ withGlobalOperation (OriginateOp origination)-        $ executeOrigination origination-  putResult $ fmap fst result-  address <- either (interpreterError is) (pure . snd) $ result--  isContractsNames %= insert address contractName-  return address-  where-    interpreterError :: InternalState -> ExecutorError -> IntegrationalScenarioM a-    interpreterError is = integrationalFail . InterpreterError . mkError is--    origination = (dummyOrigination value contract) {ooBalance = balance}---- | Like 'originate', but for typed contract and value.-tOriginate ::-     (ParameterScope cp, StorageScope st)-  => Typed.Contract cp st-  -> Text-  -> Typed.Value st-  -> Mutez-  -> IntegrationalScenarioM Address-tOriginate contract name value balance =-  originate (Typed.convertContract contract) name-    (Typed.untypeValue value) balance---- | Transfer tokens to a given address.-transfer :: TxData -> Address -> IntegrationalScenarioM ()-transfer txData destination = do-  mSender <- use isSender-  let unwrappedData = maybe id (set tdSenderAddressL) mSender txData-  registerInterpretation [TransferOp destination unwrappedData]---- | Similar to 'transfer', for typed values.--- Note that it works with untyped 'Address' and does not check that--- entrypoint with given name is present and has the expected type.--- Passed value must correspond to the entrypoint argument type, not--- the parameter type of the contract (and must be unit for implicit--- accounts).-tTransfer-  :: forall arg.-     (ParameterScope arg)-  => "from" :! Address-  -> "to" :! Address-  -> Mutez-  -> EpName-  -> Typed.Value arg-  -> IntegrationalScenarioM ()-tTransfer (arg #from -> from) (arg #to -> to) money epName param =-  let txData = TxData-        { tdSenderAddress = from-        , tdParameter =-            withDict (properParameterEvi @arg) $-            Typed.untypeValue param-        , tdEntrypoint = epName-        , tdAmount = money-        }-  in transfer txData to---- | Validator for integrational testing that expects successful execution.-validate-  :: (InternalState -> GState -> [GStateUpdate] -> Either TestError ())-  -> IntegrationalScenario-validate validator = do-  iState <- get-  interpreterResult <- use isExecutorResult-  case interpreterResult of-    Nothing -> integrationalFail ValidatingEmptyScenario-    Just result -> do-      case validator iState (_erGState result) (_erUpdates result) of-        Left bad -> integrationalFail $ IncorrectUpdates bad (_erUpdates result)-        Right () -> pass---- | Just fail with given error.-integrationalFail :: TestError -> IntegrationalScenarioM anything-integrationalFail = throwError . ScenarioError emptyScenarioBranch---- | Fail a test because an interpreter error happened unexpectedly, with the given reason.-unexpectedInterpreterError :: ExecutorError -> Text -> IntegrationalScenarioM a-unexpectedInterpreterError err reason = do-  iState <- get-  integrationalFail $ UnexpectedInterpreterError reason (mkError iState err)---- | Make all further interpreter calls use the modified timestamp as the current one.-modifyNow :: (Timestamp -> Timestamp) -> IntegrationalScenarioM ()-modifyNow = modifying isNow---- | Make all further interpreter calls use the given timestamp as the current one.-setNow :: Timestamp -> IntegrationalScenarioM ()-setNow time = modifyNow (const time)---- | Increase current time by the given number of seconds.-rewindTime :: Integer -> IntegrationalScenarioM ()-rewindTime interval = modifyNow (flip timestampPlusSeconds interval)---- | Make all further interpreter calls use the 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)---- | Make all further interpreter calls use the given chain id.-setChainId :: ChainId -> IntegrationalScenarioM ()-setChainId = assign (isGState . gsChainIdL)---- | Put an interpreted result to InternalState.-putResult :: ExecutorResOrError' -> IntegrationalScenarioM ()-putResult resOrErr = do-  isInterpreterLog <>= one resOrErr-  case resOrErr of-    Right res -> isExecutorResult .= Just res-    Left err -> do-      iState <- get-      integrationalFail $ InterpreterError $ mkError iState err---- | Make branch names for a case when we are not within any branch.-emptyScenarioBranch :: ScenarioBranchName-emptyScenarioBranch = ScenarioBranchName []---- | Add a new branch element to names provided by inner 'branch' calls.-appendScenarioBranch :: Text -> ScenarioBranchName -> ScenarioBranchName-appendScenarioBranch brName (ScenarioBranchName branches) =-  ScenarioBranchName (brName : branches)--nullScenarioBranch :: ScenarioBranchName -> Bool-nullScenarioBranch (ScenarioBranchName brs) = null brs---- | Execute multiple testing scenarios independently, basing--- them on scenario built till this point.------ The following property holds for this function:------ @ pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c] @.------ In case of property failure in one of the branches no following branch is--- executed.------ Providing empty list of scenarios to this function causes error;--- we do not require 'NonEmpty' here though for convenience.-branchout :: HasCallStack => [(Text, IntegrationalScenario)] -> IntegrationalScenario-branchout scenarios-  | null scenarios = error "branch: empty list of scenarios provided"-  | otherwise = do-      st <- get-      lift . forM_ scenarios $ \(name, scenario) ->-        withExcept (seBranch %~ appendScenarioBranch name) $-        evalStateT scenario st---- | Make a tuple with name without extra syntactic noise.-(?-) :: Text -> a -> (Text, a)-(?-) = (,)-infixr 0 ?----- | Test given scenario with the state gathered till this moment;--- if this scenario passes, go on as if it never happened.-offshoot :: Text -> IntegrationalScenario -> IntegrationalScenario-offshoot name scenario = do-  st <- get-  lift $-    withExcept (seBranch %~ appendScenarioBranch name) $-    evalStateT scenario st--------------------------------------------------------------------------------- Validators--------------------------------------------------------------------------------- | Check that there were no updates.-expectNoUpdates :: IntegrationalScenario-expectNoUpdates = validate $ \_ _ updates ->-  maybe pass (throwError . UnexpectedUpdates) . nonEmpty $ updates---- | Check that there were no storage updates.-expectNoStorageUpdates :: IntegrationalScenario-expectNoStorageUpdates = validate $ \_ _ updates ->-  maybe pass (throwError . UnexpectedUpdates) . nonEmpty $-  filter isStorageUpdate updates-  where-    isStorageUpdate = \case-      GSSetStorageValue {} -> True-      _ -> False---- | Check that storage value satisfies the given predicate.-expectStorage-  :: Address-  -> (Value -> Either TestError ())-  -> IntegrationalScenario-expectStorage addr predicate = validate $ \is gs _ ->-  let intro = StoragePredicateMismatch (addrToAddrName addr is) in-  case gsAddresses gs ^. at addr of-    Just (ASContract cs) ->-      predicate $ csStorage cs-    Just (ASSimple {}) ->-      Left $ intro $ "it's a simple address"-    Nothing -> Left $ intro $ "it's unknown"---- | 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 TestError ())-  -> IntegrationalScenario-expectStorageUpdate addr predicate = validate $ \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-  -> IntegrationalScenario-expectStorageUpdateConst addr expected = do-  is <- get-  let-    predicate val-      | val == expected = pass-      | otherwise = Left $-        IncorrectStorageUpdate (addrToAddrName addr is) (pretty expected)-  expectStorageUpdate addr predicate---- | Check that eventually address has some particular storage value.-expectStorageConst :: Address -> Value -> IntegrationalScenario-expectStorageConst addr expected = do-  is <- get-  let-    predicate val-      | val == expected = pass-      | otherwise = Left $-        InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected) (pretty val)-  expectStorage addr predicate---- | Similar to 'expectStorageConst', for typed stuff.-tExpectStorageConst-  :: forall st.-     (StorageScope st)-  => Address -> Typed.Value st -> IntegrationalScenario-tExpectStorageConst addr expected =-  expectStorageConst addr (Typed.untypeValue expected)---- | Check that eventually address has some particular balance.-expectBalance :: Address -> Mutez -> IntegrationalScenario-expectBalance addr balance = validate $ \is gs _ ->-  let realBalance = maybe (unsafeMkMutez 0) asBalance (gsAddresses gs ^. at addr) in-  if realBalance == balance then pass-  else-    Left-    $ InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance)-    $ "its actual balance is: " <> pretty realBalance----- | Attempt to run an action and return its result or, if interpretation fails, an error.-attempt :: IntegrationalScenarioM a -> IntegrationalScenarioM (Either ExecutorError a)-attempt ma = catchError (Right <$> ma) $ \case-  ScenarioError _ (InterpreterError err) -> pure . Left $ addrNameToAddr <$> err-  err -> throwError err---- | Run an action that is expected to fail.--- If the action fails, the test succeeds and the error is returned.--- If the action succeeds, the test fails.-expectError :: IntegrationalScenarioM a -> IntegrationalScenarioM ExecutorError-expectError scenario = catchExpectedError scenario pure---- | Run an action that is expected to fail.------ In @action `catchExpectedError` f@:--- If the action fails, @f@ is applied to the error.--- If the action succeeds, the test fails.-catchExpectedError-  :: IntegrationalScenarioM a-  -> (ExecutorError -> IntegrationalScenarioM b)-  -> IntegrationalScenarioM b-catchExpectedError scenario handle =-  attempt scenario >>= \case-    Left err -> handle err-    Right _ -> integrationalFail ExpectingInterpreterToFail---- | Check that interpreter failed due to gas exhaustion.-expectGasExhaustion :: ExecutorError -> IntegrationalScenario-expectGasExhaustion =-  \case-    EEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> pass-    err -> unexpectedInterpreterError err "expected runtime failure due to gas exhaustion"---- | Expect that interpretation of contract with given address ended--- with [FAILED].-expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> ExecutorError -> IntegrationalScenario-expectMichelsonFailed predicate expectedAddr err =-  case err of-    EEInterpreterFailed actualAddr (RuntimeFailure (mf, _))-      | expectedAddr /= actualAddr -> do-          iState <- get-          unexpectedInterpreterError err $-            "expected runtime failure for contract with address "-            <> pretty (addrToAddrName expectedAddr iState)-      | not (predicate mf) -> unexpectedInterpreterError err "predicate failed"-      | otherwise -> pass-    _ -> unexpectedInterpreterError err "expected runtime failure"--------------------------------------------------------------------------------- Implementation of the testing engine-------------------------------------------------------------------------------initIS :: InternalState-initIS = InternalState-  { _isNow = dummyNow-  , _isMaxSteps = dummyMaxSteps-  , _isGState = initGState-  , _isInterpreterLog = mempty-  , _isExecutorResult = Nothing-  , _isContractsNames = Map.empty-  , _isSender = Nothing-  }--integrationalTest ::-     (Maybe ScenarioError -> res)-  -> IntegrationalScenario-  -> res-integrationalTest howToFail scenario =-  howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)--mkError-  :: InternalState-  -> ExecutorError-  -> IntegrationalExecutorError-mkError is = fmap $ flip addrToAddrName is

@@ -1,135 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utility functions for unit testing.--module Michelson.Test.Unit-  ( ContractReturn-  , ContractPropValidator-  , contractProp-  , contractPropVal-  , contractHasEntryPoints-  , matchContractEntryPoints-  , mkEntrypointsMap-  , hasEp-  , validateSuccess-  , validateStorageIs-  , validateMichelsonFailsWith-  ) where--import Data.List.NonEmpty (fromList)-import qualified Data.Map as Map-import Fmt ((+|), (|+))-import Test.Hspec.Expectations (Expectation, shouldBe, shouldSatisfy)-import Test.HUnit (Assertion, assertFailure, (@?=))--import Michelson.Interpret (ContractEnv, ContractReturn, MichelsonFailed(..), interpret)-import Michelson.Printer (printUntypedContract)-import Michelson.Runtime (parseExpandContract)-import Michelson.Typed (Contract, IsoValue(..), ToT)-import qualified Michelson.Typed as T-import Michelson.Untyped hiding (Contract)-import qualified Michelson.Untyped as U---- | 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---- | ContractCode'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-     , T.ParameterScope cp-     )-  => 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.------ This function assumes that contract has no explicit default entrypoints--- and you always have to construct parameter manually; if you need to test--- contract calling specific entrypoints, use integrational testing defined--- by "Michelson.Test.Integrational" module.-contractPropVal-  :: (T.ParameterScope cp)-  => Contract cp st-  -> ContractPropValidator st prop-  -> ContractEnv-  -> T.Value cp-  -> T.Value st-  -> prop-contractPropVal instr check env param initSt =-  check $ interpret (T.cCode instr) T.epcCallRootUnsafe param initSt env---- | Check if entrypoint is present in `T`.-hasEp :: T -> (EpName, U.Type) -> Bool-hasEp (TOr lFieldAnn rFieldAnn lType@(Type lT _) rType@(Type rT _))-      ep@(epNameToParamAnn -> epAnn, epType) = or-  [ (epAnn == lFieldAnn && epType == lType)-  , (epAnn == rFieldAnn && epType == rType)-  , hasEp lT ep-  , hasEp rT ep ]-hasEp _ _ = False---- | Check whether the given set of entrypoints is present in contract.-contractHasEntryPoints :: U.Contract -> Map EpName U.Type -> Bool-contractHasEntryPoints contract eps = isRight $ matchContractEntryPoints contract eps---- | Match the given contract with provided set of entrypoints, return left if some--- entrypoints were not found.-matchContractEntryPoints-  :: HasCallStack-  => U.Contract-  -> Map EpName U.Type-  -> Either (NonEmpty (EpName, U.Type)) ()-matchContractEntryPoints contract eps =-  phi $ fromRight (error "Impossible") parsedContract-  where-    parsedContract = parseExpandContract Nothing-      (toText $ printUntypedContract True contract)-    phi (contractParameter -> ParameterType (Type t _) _) =-      conv $ filter (\ep -> not (hasEp t ep)) (Map.toList eps)-    conv l | null l = Right ()-           | otherwise = Left $ fromList l--------------------------------------------------------------------------------- Validators--------------------------------------------------------------------------------- | 'ContractPropValidator' that expects a successful termination.-validateSuccess :: HasCallStack => ContractPropValidator st Expectation-validateSuccess (res, _) = res `shouldSatisfy` isRight---- | 'ContractPropValidator' that expects contract execution to--- succeed and update storage to a particular constant value.-validateStorageIs-  :: IsoValue st-  => st -> ContractPropValidator (ToT st) Assertion-validateStorageIs expected (res, _) =-  case res of-    Left err ->-      assertFailure $ "Unexpected interpretation failure: " +| err |+ ""-    Right (_ops, got) ->-      got @?= toVal expected---- | 'ContractPropValidator' that expects a given failure.-validateMichelsonFailsWith-  :: IsoValue v-  => v -> ContractPropValidator st Expectation-validateMichelsonFailsWith v (res, _) = res `shouldBe` Left (MichelsonFailedWith $ toVal v)

@@ -1,251 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Testing utility functions used by testing framework itself or--- intended to be used by test writers.--module Michelson.Test.Util-  ( leftToShowPanic-  , leftToPrettyPanic-  , failedTest-  , succeededTest-  , eitherIsLeft-  , eitherIsRight-  , total-  , meanTimeUpperBoundProp-  , meanTimeUpperBoundPropNF-  , genEither-  , genTuple2-  , runGen-  , roundtripTree--  -- * Re-exports-  ---  -- | These functions from "Time" are re-exported here to make it convenient to call-  -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.-  , mcs, ms, sec, minute--  -- * Deprecated-  , failedProp-  , succeededProp-  , qcIsLeft-  , qcIsRight-  , roundtripTest-  ) where--import Criterion (Benchmarkable, benchmarkWith', nf, whnf)-import Criterion.Main (defaultConfig)-import Criterion.Types (SampleAnalysis(anMean), Verbosity(Quiet), reportAnalysis, verbosity)-import Data.Typeable (typeRep)-import Fmt (Buildable, pretty)-import Hedgehog-  (Gen, MonadGen, MonadTest, Property, annotate, eval, evalIO, failure, forAll, property, success,-  tripping, withTests)-import qualified Hedgehog.Gen as Gen-import Hedgehog.Internal.Gen (runGenT)-import qualified Hedgehog.Internal.Seed as Seed-import Hedgehog.Internal.Tree (TreeT(runTreeT), nodeValue)-import qualified Hedgehog.Range as Range-import Statistics.Types (Estimate(estPoint))-import Test.QuickCheck (Arbitrary)-import qualified Test.QuickCheck.Property as QC-import Test.Tasty (TestTree)-import Test.Tasty.Hedgehog (testProperty)-import qualified Test.Tasty.QuickCheck as TQC-import Text.Printf (printf)-import Time-  (KnownDivRat, KnownUnitName, Microsecond, Millisecond, Minute, Nanosecond, Picosecond, RatioNat,-  Second, Time, mcs, minute, ms, ns, sec, timeout, toUnit, unTime, unitNameVal)--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 'QC.Property' that always fails with given message.-failedProp :: Text -> QC.Property-failedProp r = QC.property $ QC.failed { QC.reason = toString r }-{-# DEPRECATED failedProp "Use 'failedtest' instead." #-}---- | A 'QC.Property' that always succeeds.-succeededProp :: QC.Property-succeededProp = QC.property True-{-# DEPRECATED succeededProp "Use 'succeededTest' instead." #-}---- | The 'QC.Property' holds on `Left a`.-qcIsLeft :: Show b => Either a b -> QC.Property-qcIsLeft = \case-  Left _ -> succeededProp-  Right x -> failedProp $ "expected Left, got Right (" <> show x <> ")"-{-# DEPRECATED qcIsLeft "Use 'eitherIsLeft' instead." #-}---- | The 'QC.Property' holds on `Right b`.-qcIsRight :: Show a => Either a b -> QC.Property-qcIsRight = \case-  Right _ -> succeededProp-  Left x -> failedProp $ "expected Right, got Left (" <> show x <> ")"-{-# DEPRECATED qcIsRight "Use 'eitherIsRight' instead." #-}---- | A 'Property' that always fails with given message.-failedTest :: (HasCallStack, MonadTest m) => Text -> m ()-failedTest r = withFrozenCallStack $ annotate (toString r) >> failure---- | A 'Property' that always succeeds.-succeededTest :: MonadTest m => m ()-succeededTest = success---- | The 'Property' holds on `Left a`.-eitherIsLeft :: (Show b, MonadTest m, HasCallStack) => Either a b -> m ()-eitherIsLeft = \case-  Left _ -> succeededTest-  Right x -> withFrozenCallStack $ failedTest $ "expected Left, got Right (" <> show x <> ")"---- | The 'Property' holds on `Right b`.-eitherIsRight :: (Show a, MonadTest m, HasCallStack) => Either a b -> m ()-eitherIsRight = \case-  Right _ -> succeededTest-  Left x -> withFrozenCallStack $ failedTest $ "expected Right, got Left (" <> show x <> ")"---- | Checks that a value is total, i.e., doesn't crash when evaluated,--- by reducing it to its normal form.------ Equivalent to QuickCheck's @total@.-total :: (MonadTest m, NFData a, HasCallStack) => a -> m a-total a = (withFrozenCallStack $ eval $ rnf a) $> a---- | Benchmarks the given function and checks that the mean time to evaluate to weak head--- normal form is under the given amount of time.------ This test fails if the benchmark takes longer than 30 seconds to run.-meanTimeUpperBoundProp-  :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack)-  => Time unit -> (a -> b) -> a -> Property-meanTimeUpperBoundProp upperBound run arg =-  withFrozenCallStack $-    checkReport upperBound $ whnf run arg---- | Benchmarks the given function and checks that the mean time to evaluate to--- normal form is under the given amount of time.------ This test aborts and fails if the benchmark takes longer than 120 seconds to run.-meanTimeUpperBoundPropNF-  :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack, NFData b)-  => Time unit -> (a -> b) -> a -> Property-meanTimeUpperBoundPropNF upperBound run arg =-  withFrozenCallStack $-    checkReport upperBound $ nf run arg--checkReport-  :: (KnownDivRat unit Second, KnownUnitName unit)-  => HasCallStack => Time unit -> Benchmarkable -> Property-checkReport upperBound benchmarkable =-  withTests 1 $ property $-    evalIO runBench >>= \case-      Nothing -> failedTest "Expected benchmark to complete within 120 seconds."-      Just report ->-        let mean = sec . realToFrac @Double @RatioNat . estPoint . anMean $ reportAnalysis report-        in  if mean < toUnit @Second upperBound-              then succeededTest-              else failedTest $-                "Expected mean estimate to be under "-                <> show upperBound-                <> ", but was "-                <> display mean-  where-    runBench = timeout (minute 2) $-      benchmarkWith' (defaultConfig { verbosity = Quiet }) benchmarkable--    display :: Time Second -> Text-    display n = case n of-      (toUnit @Minute -> x) | x > minute 1 -> format x-      (toUnit @Second -> x) | x > sec 1 -> format x-      (toUnit @Millisecond -> x) | x > ms 1 -> format x-      (toUnit @Microsecond -> x) | x > mcs 1 -> format x-      (toUnit @Nanosecond -> x) | x > ns 1 -> format x-      _ -> format (toUnit @Picosecond n)--    format :: forall unit. KnownUnitName unit => Time unit -> Text-    format n =-      toText @String $ printf "%.4f%s"-        (realToFrac @RatioNat @Double $ unTime n)-        (unitNameVal @unit)--------------------------------------------------------------------------------- Generator--------------------------------------------------------------------------------- | Randomly selects one of the two generators.-genEither :: MonadGen m => m a -> m b -> m (Either a b)-genEither genA genB = Gen.choice [ Left <$> genA, Right <$> genB ]---- | Generates an @a@ and a @b@ and wraps them in a tuple.-genTuple2 :: MonadGen m => m a -> m b -> m (a, b)-genTuple2 = liftA2 (,)---- | Run the given generator deterministically, by fixing its size and seed.-runGen :: HasCallStack => Range.Size -> Word64 -> Gen a -> a-runGen size seed genT =-  let tree = runGenT size (Seed.from seed) genT-      node = fromMaybe discardedErr $ runIdentity $ runMaybeT $ runTreeT tree-      discardedErr = error $-        "Generator could not produce a value for size "-        <> show size <> " and seed " <> show seed-  in  nodeValue node----------------------------------------------------------------------------------- Roundtrip--------------------------------------------------------------------------------- | 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@).-roundtripTest-  :: forall x y err.-     ( Show x-     , Show err-     , Typeable x-     , Arbitrary x-     , Eq x-     , Eq err-     )-  => (x -> y)-  -> (y -> Either err x)-  -> TestTree-roundtripTest xToY yToX = TQC.testProperty typeName check-  where-    typeName = show $ typeRep (Proxy @x)-    check :: x -> QC.Property-    check x = yToX (xToY x) QC.=== Right x-{-# DEPRECATED roundtripTest "Use 'roundtripTree' instead." #-}---- | 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@).-roundtripTree-  :: forall x y err.-     ( Show x-     , Show y-     , Show err-     , Typeable x-     , Eq x-     , Eq err-     )-  => Gen x-  -> (x -> y)-  -> (y -> Either err x)-  -> TestTree-roundtripTree genX xToY yToX = testProperty typeNameX prop-  where-    typeNameX = show $ typeRep (Proxy @x)-    prop :: Property-    prop = property $ do-      x <- forAll genX-      tripping x xToY yToX

@@ -25,7 +25,8 @@   , takeMText   , dropMText   , isMChar-  , genMText+  , minBoundMChar+  , maxBoundMChar      -- * Misc   , qqMText@@ -41,9 +42,6 @@ import Data.Data (Data) import qualified Data.Text as T import Fmt (Buildable)-import Hedgehog (MonadGen)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import Test.QuickCheck (Arbitrary(..), choose, listOf)@@ -128,12 +126,6 @@  dropMText :: Int -> MText -> MText dropMText n (MTextUnsafe txt) = MTextUnsafe $ T.drop n txt--genMText :: MonadGen m => m MText-genMText =-  mkMTextUnsafe <$> Gen.text-    (Range.linear 0 100)-    (Gen.enum (toEnum @Char minBoundMChar) (toEnum @Char maxBoundMChar))  instance ToText MText where   toText = unMText

@@ -4,8 +4,10 @@  module Michelson.TypeCheck   ( typeCheckContract-  , typeCheckTopLevelType-  , typeVerifyTopLevelType+  , typeCheckStorage+  , typeCheckParameter+  , typeVerifyStorage+  , typeVerifyParameter   , typeCheckValue   , typeCheckList   , typeCheckExt

@@ -168,11 +168,11 @@   -- (e.g. @timestamp@ cannot be obtained from a `U.ValueTrue`)   | NotEnoughItemsOnStack   -- ^ There are not enough items on stack to perform a certain instruction.-  | IllegalEntryPoint T.EpNameFromRefAnnError+  | IllegalEntrypoint T.EpNameFromRefAnnError   -- ^ Invalid entrypoint name provided   | UnknownContract Address   -- ^ Contract with given address is not originated.-  | EntryPointNotFound T.EpName+  | EntrypointNotFound T.EpName   -- ^ Given entrypoint is not present.   | IllegalParamDecl T.ParamEpError   -- ^ Incorrect parameter declaration (with respect to entrypoints feature).@@ -222,8 +222,8 @@       "Not enough items on stack"     UnknownContract addr ->       "Contract is not registered: " +| addr |+ ""-    IllegalEntryPoint err -> build err-    EntryPointNotFound ep ->+    IllegalEntrypoint err -> build err+    EntrypointNotFound ep ->       "No such entrypoint '" +| ep |+ "'"     IllegalParamDecl err -> build err     NegativeNat -> "Natural number cannot be negative"@@ -257,8 +257,8 @@     TCFailedOnValue v t custom ics mbTCTypeError ->       "Error checking value "       +| v |+ " against type "-      +| toUType t |+ bool (": " +| custom |+ " ") "" (null custom)-      +| (maybe "" (\e -> " " +| e |+ "") mbTCTypeError)+      +| toUType t |+ bool (": " +| custom |+ " ") "." (null custom)+      +| (maybe "" (\e -> "\n" +| e |+ ".\n") mbTCTypeError)       +| buildCallStack ics     TCContractError msg typeError ->       "Error occured during contract typecheck: "

@@ -455,17 +455,25 @@ -- | Helper function to construct instructions for binary arithmetic -- operations. arithImpl-  :: ( Typeable (ArithRes aop n m ': s)+  :: forall aop inp m n s t.+     ( ArithOp aop n m+     , Typeable (ArithRes aop n m ': s)      , WellTyped (ArithRes aop n m)      , inp ~ (n ': m ': s)-     , Monad t+     , MonadReader InstrCallStack t+     , MonadError TCError t      )   => Instr inp (ArithRes aop n m ': s)   -> HST inp   -> VarAnn+  -> Un.ExpandedInstr   -> t (SomeInstr inp)-arithImpl mkInstr i@(_ ::& _ ::& rs) vn = do-  pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)+arithImpl mkInstr i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do+  case convergeArith (Proxy @aop) an bn of+    Right cn ->+      pure $ i :/ mkInstr ::: ((cn, Dict, vn) ::& rs)+    Left err -> do+      typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err  addImpl   :: forall a b inp rs m.@@ -478,6 +486,7 @@   => Sing a -> Sing b   -> HST inp   -> VarAnn+  -> Un.ExpandedInstr   -> m (SomeInstr inp) addImpl t1 t2 = case (t1, t2) of   (STInt, STInt) -> arithImpl @Add ADD@@ -487,7 +496,7 @@   (STInt, STTimestamp) -> arithImpl @Add ADD   (STTimestamp, STInt) -> arithImpl @Add ADD   (STMutez, STMutez) -> arithImpl @Add ADD-  _ -> \i vn -> typeCheckInstrErr' (Un.ADD vn) (SomeHST i) (Just ArithmeticOperation) $+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b)  edivImpl@@ -501,6 +510,7 @@   => Sing a -> Sing b   -> HST inp   -> VarAnn+  -> Un.ExpandedInstr   -> m (SomeInstr inp) edivImpl t1 t2 = case (t1, t2) of   (STInt, STInt) -> edivImplDo@@ -509,7 +519,7 @@   (STNat, STNat) -> edivImplDo   (STMutez, STMutez) -> edivImplDo   (STMutez, STNat) -> edivImplDo-  _ -> \i vn -> typeCheckInstrErr' (Un.EDIV vn) (SomeHST i) (Just ArithmeticOperation) $+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b)  edivImplDo@@ -517,13 +527,19 @@      , WellTyped (EModOpRes n m)      , WellTyped (EDivOpRes n m)      , inp ~ (n ': m ': s)-     , Monad t+     , MonadReader InstrCallStack t+     , MonadError TCError t      )   => HST inp   -> VarAnn+  -> Un.ExpandedInstr   -> t (SomeInstr inp)-edivImplDo i@(_ ::& _ ::& rs) vn = do-  pure $ i :/ EDIV ::: ((starNotes, Dict, vn) ::& rs)+edivImplDo i@((an, _, _) ::& (bn, _, _) ::& rs) vn uInstr = do+  case convergeEDiv an bn of+    Right cn ->+      pure $ i :/ EDIV ::: ((cn, Dict, vn) ::& rs)+    Left err -> do+      typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $ AnnError err  subImpl   :: forall a b inp rs m.@@ -536,6 +552,7 @@   => Sing a -> Sing b   -> HST inp   -> VarAnn+  -> Un.ExpandedInstr   -> m (SomeInstr inp) subImpl t1 t2 = case (t1, t2) of   (STInt, STInt) -> arithImpl @Sub SUB@@ -545,7 +562,7 @@   (STTimestamp, STTimestamp) -> arithImpl @Sub SUB   (STTimestamp, STInt) -> arithImpl @Sub SUB   (STMutez, STMutez) -> arithImpl @Sub SUB-  _ -> \i vn -> typeCheckInstrErr' (Un.SUB vn) (SomeHST i) (Just ArithmeticOperation) $+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b)  mulImpl@@ -559,6 +576,7 @@   => Sing a -> Sing b   -> HST inp   -> VarAnn+  -> Un.ExpandedInstr   -> m (SomeInstr inp) mulImpl t1 t2 = case (t1, t2) of   (STInt, STInt) -> arithImpl @Mul MUL@@ -567,7 +585,7 @@   (STNat, STNat) -> arithImpl @Mul MUL   (STNat, STMutez) -> arithImpl @Mul MUL   (STMutez, STNat) -> arithImpl @Mul MUL-  _ -> \i vn -> typeCheckInstrErr' (Un.MUL vn) (SomeHST i) (Just ArithmeticOperation) $+  _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b)  -- | Helper function to construct instructions for binary arithmetic

@@ -32,8 +32,10 @@     ( typeCheckContract     , typeCheckValue     , typeCheckList-    , typeVerifyTopLevelType-    , typeCheckTopLevelType+    , typeVerifyStorage+    , typeVerifyParameter+    , typeCheckStorage+    , typeCheckParameter     ) where  import Prelude hiding (EQ, GT, LT)@@ -60,28 +62,28 @@ import Michelson.Untyped.Annotation (VarAnn)  typeCheckContract-  :: TcOriginatedContracts-  -> U.Contract+  :: U.Contract   -> Either TCError SomeContract-typeCheckContract cs c =-  runTypeCheck (U.contractParameter c) cs $ typeCheckContractImpl c+typeCheckContract c = do+  paramType <- mkSomeParamType (U.contractParameter c)+  runTypeCheck (TypeCheckContract paramType) $ typeCheckContractImpl c  withWTP :: forall t a. SingI t => (WellTyped t => TypeCheck a) -> TypeCheck a withWTP fn = case getWTP @t of-  Just Dict -> fn-  Nothing -> throwError $ TCContractError "Not a well typed value" Nothing+  Right Dict -> fn+  Left (NotWellTyped t) -> throwError $ TCContractError ("Not a well typed value: " <> show t) Nothing  withWTPInstr_ :: forall t a. SingI t => U.ExpandedInstr -> SomeHST -> (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a withWTPInstr_ v t fn = case getWTP @t of-  Just Dict -> fn-  Nothing -> do+  Right Dict -> fn+  Left (NotWellTyped badType) -> do     loc <- ask-    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope (demote @t) BtNotComparable)+    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType BtNotComparable)  typeCheckContractImpl   :: U.Contract   -> TypeCheck SomeContract-typeCheckContractImpl (U.Contract (U.ParameterType mParam rootAnn) mStorage pCode) = do+typeCheckContractImpl (U.Contract (U.ParameterType mParam rootAnn) mStorage pCode entriesOrder) = do   _ <- maybe (throwError $ TCContractError "no instructions in contract code" $ Just EmptyCode)                 pure (nonEmpty pCode)   withUType mParam $ \(paramNote :: Notes param) ->@@ -113,6 +115,7 @@                     { cCode = instr                     , cParamNotes                     , cStoreNotes+                    , cEntriesOrder = entriesOrder                     }                 Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err             AnyOutInstr instr ->@@ -120,6 +123,7 @@                 { cCode = instr                 , cParamNotes                 , cStoreNotes+                , cEntriesOrder = entriesOrder                 }   where     hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a@@ -149,33 +153,52 @@ -- @typeCheckValue@ is polymorphic in the expected type of value. -- -- Type checking algorithm pattern-matches on parse value representation,--- expected type @t@ and constructs @Val t@ value.+-- expected type @t@ and constructs @Value 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-  :: forall t.-      (SingI t)+  :: forall t. SingI t   => U.Value   -> TypeCheckInstr (Value t)-typeCheckValue = typeCheckValImpl @t typeCheckInstr+typeCheckValue = typeCheckValImpl @t Nothing typeCheckInstr -typeVerifyTopLevelType-  :: (SingI t, HasCallStack)+typeVerifyParameter+  :: SingI t   => TcOriginatedContracts -> U.Value -> Either TCError (Value t)-typeVerifyTopLevelType originatedContracts valueU =-  runTypeCheck param originatedContracts $ usingReaderT (def :: InstrCallStack) $-    typeCheckValue valueU-  where-    param = error "parameter type touched during top-level type typecheck"+typeVerifyParameter originatedContracts = typeVerifyTopLevelType (Just originatedContracts) +typeVerifyStorage+  :: SingI t+  => U.Value -> Either TCError (Value t)+typeVerifyStorage = typeVerifyTopLevelType Nothing++typeVerifyTopLevelType+  :: forall t. SingI t+  => Maybe TcOriginatedContracts -> U.Value -> Either TCError (Value t)+typeVerifyTopLevelType mOriginatedContracts valueU =+  runTypeCheck (TypeCheckValue (valueU, demote @t)) $ usingReaderT (def :: InstrCallStack) $+    typeCheckValImpl mOriginatedContracts typeCheckInstr valueU++-- | Like 'typeCheckValue', but for values to be used as parameter.+--+-- Also accepts a 'TcOriginatedContracts' in order to be able to type-check+-- @contract p@ values (which can only be part of a parameter).+typeCheckParameter+  :: TcOriginatedContracts -> U.Type -> U.Value -> Either TCError SomeValue+typeCheckParameter originatedContracts = typeCheckTopLevelType (Just originatedContracts)++-- | Like 'typeCheckValue', but for values to be used as storage.+typeCheckStorage+  :: U.Type -> U.Value -> Either TCError SomeValue+typeCheckStorage = typeCheckTopLevelType Nothing+ typeCheckTopLevelType-  :: HasCallStack-  => TcOriginatedContracts -> U.Type -> U.Value -> Either TCError SomeValue-typeCheckTopLevelType originatedContracts typeU valueU =+  :: Maybe TcOriginatedContracts -> U.Type -> U.Value -> Either TCError SomeValue+typeCheckTopLevelType mOriginatedContracts typeU valueU =   withSomeSingT (fromUType typeU) $ \(_ :: Sing t) ->-    SomeValue <$> typeVerifyTopLevelType @t originatedContracts valueU+    SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU  -- Helper data type we use to typecheck DROPN. data TCDropHelper inp where@@ -740,19 +763,19 @@     (U.ISNAT _, SNil)-> notEnoughItemsOnStack      -- Type checking is already done inside `addImpl`.-    (U.ADD vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> addImpl a b inp vn+    (U.ADD vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> addImpl a b inp vn uInstr      (U.ADD _, _) -> notEnoughItemsOnStack -    (U.SUB vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> subImpl a b inp vn+    (U.SUB vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> subImpl a b inp vn uInstr      (U.SUB _, _) -> notEnoughItemsOnStack -    (U.MUL vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> mulImpl a b inp vn+    (U.MUL vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> mulImpl a b inp vn uInstr      (U.MUL _, _) -> notEnoughItemsOnStack -    (U.EDIV vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> edivImpl a b inp vn+    (U.EDIV vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> edivImpl a b inp vn uInstr      (U.EDIV _, _) -> notEnoughItemsOnStack @@ -772,21 +795,21 @@     (U.NEG _, SNil) -> notEnoughItemsOnStack      (U.LSL vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> arithImpl @Lsl LSL inp vn+               (STNat, _, _, _) ::&+ _) -> arithImpl @Lsl LSL inp vn uInstr     (U.LSL _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType $ (ExpectNat :| [ExpectNat]) :| []     (U.LSL _, _) -> notEnoughItemsOnStack      (U.LSR vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> arithImpl @Lsr LSR inp vn+               (STNat, _, _, _) ::&+ _) -> arithImpl @Lsr LSR inp vn uInstr     (U.LSR _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType $ (ExpectNat :| [ExpectNat]) :| []     (U.LSR _, _) -> notEnoughItemsOnStack      (U.OR vn, (STBool, _, _, _) ::&+-              (STBool, _, _, _) ::&+ _) -> arithImpl @Or OR inp vn+              (STBool, _, _, _) ::&+ _) -> arithImpl @Or OR inp vn uInstr     (U.OR vn, (STNat, _, _, _) ::&+-              (STNat, _, _, _) ::&+ _) -> arithImpl @Or OR inp vn+              (STNat, _, _, _) ::&+ _) -> arithImpl @Or OR inp vn uInstr     (U.OR _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType         $ (ExpectBool :| [ExpectBool]) :|@@ -795,11 +818,11 @@     (U.OR _, _) -> notEnoughItemsOnStack      (U.AND vn, (STInt, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> arithImpl @And AND inp vn+               (STNat, _, _, _) ::&+ _) -> arithImpl @And AND inp vn uInstr     (U.AND vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> arithImpl @And AND inp vn+               (STNat, _, _, _) ::&+ _) -> arithImpl @And AND inp vn uInstr     (U.AND vn, (STBool, _, _, _) ::&+-               (STBool, _, _, _) ::&+ _) -> arithImpl @And AND inp vn+               (STBool, _, _, _) ::&+ _) -> arithImpl @And AND inp vn uInstr     (U.AND _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType         $ (ExpectInt :| [ExpectNat]) :|@@ -809,9 +832,9 @@     (U.AND _, _) -> notEnoughItemsOnStack      (U.XOR vn, (STBool, _, _, _) ::&+-               (STBool, _, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn+               (STBool, _, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn uInstr     (U.XOR vn, (STNat, _, _, _) ::&+-               (STNat, _, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn+               (STNat, _, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn uInstr     (U.XOR _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType         $ (ExpectBool :| [ExpectBool]) :|@@ -890,33 +913,33 @@     (U.INT _, SNil) -> notEnoughItemsOnStack      (U.SELF vn fn, _) -> do-      (U.ParameterType cpType rootAnn) <- gets tcContractParam-      -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-      -- valid parameter type-      withUType cpType $ \((`ParamNotesUnsafe` rootAnn) -> notescp :: ParamNotes t) -> do-        proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)-          $ checkScope @(ParameterScope t)-        case proofScope of-          Dict -> do-            epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing $-                        epNameFromRefAnn fn `onLeft` IllegalEntryPoint-            MkEntryPointCallRes (argNotes :: Notes arg) epc <--              mkEntryPointCall epName notescp-                & maybeToRight (EntryPointNotFound epName)-                & onTypeCheckInstrErr uInstr (SomeHST inp) Nothing--            case NTContract U.noAnn argNotes of-                    (ntRes :: Notes ('TContract t1)) ->-                      withWTPInstr @('TContract t1) $-                        pure $ inp :/ SELF @arg (SomeEpc epc) ::: ((ntRes, Dict, vn) ::& inp)+      mode <- gets tcMode+      case mode of+        TypeCheckValue (value, ty) ->+          tcFailedOnValue value ty "The SELF instruction cannot appear in a lambda." Nothing+        TypeCheckContract (SomeParamType _ notescp) -> do+          epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing $+                      epNameFromRefAnn fn `onLeft` IllegalEntrypoint+          MkEntrypointCallRes (argNotes :: Notes arg) epc <-+            mkEntrypointCall epName notescp+              & maybeToRight (EntrypointNotFound epName)+              & onTypeCheckInstrErr uInstr (SomeHST inp) Nothing +          case NTContract U.noAnn argNotes of+                  (ntRes :: Notes ('TContract t1)) ->+                    withWTPInstr @('TContract t1) $+                      pure $ inp :/ SELF @arg (SomeEpc epc) ::: ((ntRes, Dict, vn) ::& inp)+        TypeCheckTest ->+          error "'SELF' appears in test typechecking."+        TypeCheckPack ->+          error "'SELF' appears in packed data."     (U.CONTRACT vn fn mt, (NTAddress{}, _, _) ::& rs) ->       withUType mt $ \(tns :: Notes t) -> do         proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)           $ checkScope @(ParameterScope t)         let ns = NTOption def $ NTContract def tns         epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing-          $ epNameFromRefAnn fn `onLeft` IllegalEntryPoint+          $ epNameFromRefAnn fn `onLeft` IllegalEntrypoint         case proofScope of           Dict ->             withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs)@@ -959,13 +982,14 @@           (Contract             (contr :: ContractCode p' g')             paramNotes-            storeNotes))+            storeNotes+            entriesOrder))           <- lift $ typeCheckContractImpl contract         Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage)           $ eqType @g @g'         void $ onTypeCheckInstrAnnErr uInstr inp (Just ContractStorage) (converge gn storeNotes)         pure-          $ inp :/ CREATE_CONTRACT (Contract contr paramNotes storeNotes)+          $ inp :/ CREATE_CONTRACT (Contract contr paramNotes storeNotes entriesOrder)           ::: ((starNotes, Dict, ovn) ::& (starNotes, Dict, avn) ::& rs)      (U.CREATE_CONTRACT {}, _ ::& _ ::& _ ::& _) ->

@@ -14,18 +14,25 @@   , runTypeCheckInstrIsolated   , mapTCError -  , tcContractParamL-  , tcContractsL   , tcExtFramesL+  , tcModeL+  , TypeCheckMode(..)+  , SomeParamType(..)+  , mkSomeParamType+  , mkSomeParamTypeUnsafe   ) where  import Control.Monad.Except (withExceptT) import Control.Monad.Reader (mapReaderT) import Data.Default (def)+import Data.Singletons (Sing)+import Fmt (Buildable, build, pretty)+import qualified Text.Show  import Michelson.ErrorPos (InstrCallStack)-import Michelson.TypeCheck.Error (TCError)+import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..)) import Michelson.TypeCheck.Types+import qualified Michelson.Typed as T import qualified Michelson.Untyped as U import Tezos.Address (ContractHash) import Util.Lens@@ -34,20 +41,65 @@   ExceptT TCError     (State TypeCheckEnv) -type TcOriginatedContracts = Map ContractHash U.ParameterType+data SomeParamType = forall t. (T.ParameterScope t) =>+  SomeParamType (Sing t) (T.ParamNotes t) +-- | @Show@ instance of @SomeParamType@, mainly used in test.+instance Show SomeParamType where+  show = show . someParamToParameterType++-- | @Eq@ instance of @SomeParamType@, mainly used in test.+instance Eq SomeParamType where+  s1 == s2 = someParamToParameterType s1 == someParamToParameterType s2++-- | @Buildable@ instance of @SomeParamType@, mainly used in test.+instance Buildable SomeParamType where+  build = build . someParamToParameterType++-- | Helper function means to provide a quick way for creating instance+-- of @SomeParamType@ needed in test.+someParamToParameterType :: SomeParamType -> U.ParameterType+someParamToParameterType (SomeParamType s T.ParamNotesUnsafe{..}) =+  U.ParameterType (T.AsUTypeExt s pnNotes) pnRootAnn++-- | Construct @SomeParamType@ from @ParameterType@, mainly used in test.+mkSomeParamTypeUnsafe :: HasCallStack => U.ParameterType -> SomeParamType+mkSomeParamTypeUnsafe p =+  case mkSomeParamType p of+    Right sp ->  sp+    Left err -> error $ "Illegal type in parameter of env contract: " <> pretty err++mkSomeParamType :: U.ParameterType -> Either TCError SomeParamType+mkSomeParamType (U.ParameterType t ann) =+  T.withUType t $ \(notescp :: T.Notes t) -> do+    case T.checkScope @(T.ParameterScope t) of+      Right T.Dict ->+        case T.mkParamNotes notescp ann of+          Right paramNotes -> Right $ SomeParamType T.sing paramNotes+          Left err ->+            Left $ TCContractError "invalid parameter declaration: " $ Just $ IllegalParamDecl err+      Left err -> Left $ TCContractError ("Parameter type is invalid: " <> pretty err) Nothing++type TcOriginatedContracts = Map ContractHash SomeParamType++-- | Typechecking mode that tells the type checker whether it is typechecking+-- contract code in actual contract, lambda, or test.+data TypeCheckMode+  = TypeCheckValue (U.Value, T.T)+  | TypeCheckContract SomeParamType+  | TypeCheckTest+  | TypeCheckPack+ -- | The typechecking state data TypeCheckEnv = TypeCheckEnv-  { tcExtFrames       :: ~TcExtFrames-  , tcContractParam   :: ~U.ParameterType-  , tcContracts       :: ~TcOriginatedContracts+  { tcExtFrames :: ~TcExtFrames+  , tcMode :: ~TypeCheckMode   }  makeLensesWith postfixLFields ''TypeCheckEnv -runTypeCheck :: U.ParameterType -> TcOriginatedContracts -> TypeCheck a -> Either TCError a-runTypeCheck param contracts act =-  evaluatingState (TypeCheckEnv [] param contracts) $ runExceptT act+runTypeCheck :: TypeCheckMode -> TypeCheck a -> Either TCError a+runTypeCheck mode = evaluatingState (TypeCheckEnv [] mode) . runExceptT  -- | Run type checker as if it worked isolated from other world - -- no access to environment of the current contract is allowed.@@ -58,14 +110,7 @@ -- contract which is being typechecked (because there is no contract -- that we are typechecking). runTypeCheckIsolated :: TypeCheck a -> Either TCError a-runTypeCheckIsolated = evaluatingState initSt . runExceptT-  where-  initSt =-    TypeCheckEnv-    { tcExtFrames = []-    , tcContractParam = error "Contract param touched"-    , tcContracts = mempty-    }+runTypeCheckIsolated = runTypeCheck TypeCheckTest  type TcResult inp = Either TCError (SomeInstr inp) @@ -87,7 +132,7 @@ -- have to be refactored too. -- Therefore, I am using ReaderT over TypeCheck. type TcInstrHandler-   = forall inp. Typeable inp+   = forall inp. (Typeable inp, HasCallStack)       => U.ExpandedInstr       -> HST inp       -> TypeCheckInstr (SomeInstr inp)

@@ -12,15 +12,17 @@     , SomeContract (..)     , BoundVars (..)     , TcExtFrames+    , NotWellTyped (..)     , getWTP     , withWTPm+    , unsafeWithWTP     , mapSomeContract     , noBoundVars     ) where  import Data.Constraint (Dict(..)) import qualified Data.Map.Lazy as Map-import Data.Singletons (Sing, SingI(..))+import Data.Singletons (Sing, SingI(..), demote) import Fmt (Buildable(..), Builder, (+|), (|+)) import Prelude hiding (EQ, GT, LT) import qualified Text.Show@@ -187,51 +189,68 @@ -- | State for type checking @nop@ type TcExtFrames = [BoundVars] -fromMDict :: Maybe (Dict a) -> (a => Maybe (Dict b)) -> Maybe (Dict b)-fromMDict ma b = ma >>= (\Dict -> b)+-- | Error type for when a value is not well-typed.+data NotWellTyped = NotWellTyped T +fromEDict :: Either e (Dict a) -> (a => Either e (Dict b)) -> Either e (Dict b)+fromEDict ma b = ma >>= (\Dict -> b)+ -- | Given a type, provide evidence that it is well typed w.r.t to the --  Michelson rules regarding where comparable types are required.-getWTP :: forall t. SingI t => Maybe (Dict (WellTyped t))+getWTP :: forall t. (SingI t) => Either NotWellTyped (Dict (WellTyped t)) getWTP = case sing @t of-  STKey -> Just Dict-  STUnit -> Just Dict-  STSignature -> Just Dict-  STChainId -> Just Dict-  STOption s -> fromMDict (getWTP_ s) (Just Dict)-  STList s -> fromMDict (getWTP_ s) (Just Dict)-  STSet s -> fromMDict (getWTP_ s) $ fromMDict (T.getComparableProofS s) (Just Dict)-  STOperation  -> Just Dict-  STContract s -> fromMDict (getWTP_ s) (Just Dict)-  STPair s1 s2 -> fromMDict (getWTP_ s1) $ fromMDict (getWTP_ s2) $ Just Dict-  STOr s1 s2 -> fromMDict (getWTP_ s1) $ fromMDict (getWTP_ s2) $ Just Dict-  STLambda s1 s2 -> fromMDict (getWTP_ s1) $ fromMDict (getWTP_ s2) $ Just Dict-  STMap s1 s2 ->-    fromMDict (getWTP_ s1) $-    fromMDict (getWTP_ s2) $-    fromMDict (T.getComparableProofS s1) $ Just Dict-  STBigMap s1 s2 ->-    fromMDict (getWTP_ s1) $-    fromMDict (getWTP_ s2) $-    fromMDict (T.getComparableProofS s1) $ Just Dict-  STInt -> Just Dict-  STNat -> Just Dict-  STString -> Just Dict-  STBytes -> Just Dict-  STMutez -> Just Dict-  STBool -> Just Dict-  STKeyHash -> Just Dict-  STTimestamp -> Just Dict-  STAddress -> Just Dict+  STKey -> Right Dict+  STUnit -> Right Dict+  STSignature -> Right Dict+  STChainId -> Right Dict+  STOption s -> fromEDict (getWTP_ s) (Right Dict)+  STList s -> fromEDict (getWTP_ s) (Right Dict)+  STSet (s :: Sing si) ->+    fromEDict (getWTP_ s) $+    fromEDict+        ( maybeToRight (NotWellTyped $ demote @si) $ T.getComparableProofS s+        ) $ Right Dict+  STOperation  -> Right Dict+  STContract s -> fromEDict (getWTP_ s) (Right Dict)+  STPair s1 s2 -> fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict+  STOr s1 s2 -> fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict+  STLambda s1 s2 -> fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict+  STMap (s1 :: Sing si) s2 ->+      fromEDict (getWTP_ s1) $+      fromEDict (getWTP_ s2) $+      fromEDict+        ( maybeToRight (NotWellTyped $ demote @si) $ T.getComparableProofS s1+        ) $ Right Dict+  STBigMap (s1 :: Sing si) s2 ->+      fromEDict (getWTP_ s1) $+      fromEDict (getWTP_ s2) $+      fromEDict+        ( maybeToRight (NotWellTyped $ demote @si) $ T.getComparableProofS s1+        ) $ Right Dict+  STInt -> Right Dict+  STNat -> Right Dict+  STString -> Right Dict+  STBytes -> Right Dict+  STMutez -> Right Dict+  STBool -> Right Dict+  STKeyHash -> Right Dict+  STTimestamp -> Right Dict+  STAddress -> Right Dict   where-    getWTP_ :: forall t1. SingI t1 => Sing t1 -> Maybe (Dict (WellTyped t1))+    getWTP_ :: forall t1. SingI t1 => Sing t1 -> Either NotWellTyped (Dict (WellTyped t1))     getWTP_ _ = getWTP @t1  -- | Given a type and an action that requires evidence that the type is well typed, --  generate the evidence and execute the action, or else fail with an error. withWTPm :: forall t m a. (MonadFail m, SingI t) => (WellTyped t => m a) -> m a withWTPm a = case getWTP @t of-  Just Dict -> a-  Nothing ->-    fail ("This type is not well typed because it has an non-comparable type in it," <>-          "where a comparable type is required")+  Right Dict -> a+  Left (NotWellTyped t) ->+    fail ("This type is not well typed because it has an non-comparable type in it: '" <> (show t) <>+      "', where a comparable type is required")++-- | Similar to @withWTPm@ but is mean to be used within tests.+unsafeWithWTP :: forall t a. SingI t => (WellTyped t => a) -> a+unsafeWithWTP fn = case getWTP @t of+  Right Dict -> fn+  Left (NotWellTyped t) -> error $ "Type is not well typed: " <> (show t)

@@ -4,6 +4,7 @@  module Michelson.TypeCheck.Value     ( typeCheckValImpl+    , tcFailedOnValue     ) where  import Control.Monad.Except (liftEither, throwError)@@ -18,16 +19,16 @@ import Michelson.Text import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..)) import Michelson.TypeCheck.Helpers-import Michelson.TypeCheck.TypeCheck (TcInstrHandler, TypeCheckEnv(..), TypeCheckInstr)+import Michelson.TypeCheck.TypeCheck (SomeParamType(..), TcInstrHandler, TcOriginatedContracts, TypeCheckInstr) import Michelson.TypeCheck.Types import Michelson.Typed-  (pattern AsUTypeExt, EpAddress(..), KnownT, Notes(..), ParamNotes(..), SingT(..), Value'(..),+  (EpAddress(..), KnownT, Notes(..), SingT(..), Value'(..),   fromSingT, starNotes) import qualified Michelson.Typed as T import qualified Michelson.Untyped as U import Tezos.Address (Address(..)) import Tezos.Core-import Tezos.Crypto (parseKeyHash, parsePublicKey, parseSignature)+import Tezos.Crypto  tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a tcFailedOnValue v t msg err = do@@ -46,167 +47,210 @@ -- 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.+--+-- @typeCheckValImpl@ also has a 'Maybe TcOriginatedContracts' argument that+-- should contain the originated contracts when typechecking a parameter and+-- 'Nothing' otherwise. typeCheckValImpl   :: forall ty.      SingI ty-  => TcInstrHandler+  => Maybe TcOriginatedContracts+  -> TcInstrHandler   -> U.Value   -> TypeCheckInstr (T.Value ty)-typeCheckValImpl tcDo uvalue = case (uvalue, sing @ty) of-  (U.ValueInt i, STInt) -> pure $ T.VInt i-  (v@(U.ValueInt i), t@STNat)-    | i >= 0 -> pure $ VNat (fromInteger i)-    | otherwise -> tcFailedOnValue v (fromSingT t) "" (Just NegativeNat)-  (v@(U.ValueInt i), t@STMutez) -> do-    case mkMutez $ fromInteger i of-      Just mtz -> pure $ VMutez mtz-      Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)-  (U.ValueString s, STString) ->-    pure $ VString s-  (v@(U.ValueString s), t@STAddress) -> do-    case T.parseEpAddress (unMText s) of-      Right addr -> pure $ VAddress addr-      Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidAddress err)-  (v@(U.ValueString s), t@STKeyHash) -> do-    case parseKeyHash (unMText s)  of-      Right kHash -> pure $ VKeyHash kHash-      Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)-  (v@(U.ValueString s), t@STTimestamp) -> do-    case parseTimestamp $ unMText s of-      Just tstamp -> pure $ VTimestamp tstamp-      Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)-  (U.ValueInt i, STTimestamp) ->-    pure $ VTimestamp (timestampFromSeconds i)-  (U.ValueBytes (U.InternalByteString s), STBytes) ->-    pure $ VBytes s-  (U.ValueTrue, STBool) -> pure $ VBool True-  (U.ValueFalse, STBool) -> pure $ VBool False+typeCheckValImpl mOriginatedContracts tcDo = doTypeCheckVal+  where+    doTypeCheckVal :: forall tz. SingI tz => U.Value -> TypeCheckInstr (T.Value tz)+    doTypeCheckVal uvalue = case (uvalue, sing @tz) of+      (U.ValueInt i, STInt) -> pure $ T.VInt i+      (v@(U.ValueInt i), t@STNat)+        | i >= 0 -> pure $ VNat (fromInteger i)+        | otherwise -> tcFailedOnValue v (fromSingT t) "" (Just NegativeNat)+      (v@(U.ValueInt i), t@STMutez) -> case mkMutez $ fromInteger i of+        Just mtz -> pure $ VMutez mtz+        Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)+      (U.ValueString s, STString) -> pure $ VString s+      (v@(U.ValueString s), t@STAddress) -> case T.parseEpAddress (unMText s) of+        Right addr -> pure $ VAddress addr+        Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidAddress err)+      (v@(U.ValueBytes b), t@STAddress) -> case T.parseEpAddressRaw (U.unInternalByteString b) of+        Right addr -> pure $ VAddress addr+        Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidAddress err)+      (v@(U.ValueString s), t@STKeyHash) -> case parseKeyHash (unMText s)  of+        Right kHash -> pure $ VKeyHash kHash+        Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)+      (v@(U.ValueBytes b), t@STKeyHash) ->+        case parseKeyHashRaw (U.unInternalByteString b) of+          Right kHash -> pure $ VKeyHash kHash+          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)+      (v@(U.ValueString s), t@STTimestamp) -> case parseTimestamp $ unMText s of+        Just tstamp -> pure $ VTimestamp tstamp+        Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)+      (U.ValueInt i, STTimestamp) -> pure $ VTimestamp (timestampFromSeconds i)+      (U.ValueBytes (U.InternalByteString s), STBytes) -> pure $ VBytes s+      (U.ValueTrue, STBool) -> pure $ VBool True+      (U.ValueFalse, STBool) -> pure $ VBool False -  (U.ValueString (parsePublicKey . unMText -> Right s), STKey) ->-    pure $ T.VKey s+      (U.ValueString (parsePublicKey . unMText -> Right s), STKey) ->+        pure $ T.VKey s+      (U.ValueBytes (parsePublicKeyRaw . U.unInternalByteString -> Right s), STKey) ->+        pure $ VKey s -  (U.ValueString (parseSignature . unMText -> Right s), STSignature) ->-    pure $ VSignature s+      (U.ValueString (parseSignature . unMText -> Right s), STSignature) ->+        pure $ VSignature s+      (U.ValueBytes (parseSignatureRaw . U.unInternalByteString  -> Right s), STSignature) ->+        pure $ VSignature s -  (U.ValueString (parseChainId . unMText -> Right ci), STChainId) ->-    pure $ VChainId ci-  (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId) ->-    pure $ VChainId ci+      (U.ValueString (parseChainId . unMText -> Right ci), STChainId) ->+        pure $ VChainId ci+      (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId) ->+        pure $ VChainId ci -  ( cv@(U.ValueString (T.parseEpAddress . unMText -> Right epAddr)),-                      STContract (pc :: Sing cp)) -> do-    instrPos <- ask-    contracts <- gets tcContracts-    let ensureTypeMatches :: forall t'. KnownT t' => TypeCheckInstr (cp :~: t')-        ensureTypeMatches =-          liftEither @_ @TypeCheckInstr $-          first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $-            eqType @cp @t'-    let unsupportedType :: T.BadTypeForScope -> TCError-        unsupportedType reason =-          TCFailedOnValue cv (fromSingT pc) ("Unsupported type in type argument of 'contract' type") instrPos $-          Just $ UnsupportedTypeForScope (fromSingT pc) reason-    let EpAddress addr epName = epAddr-    case addr of-      KeyAddress _ -> do-        Refl <- ensureTypeMatches @'T.TUnit-        pure $ VContract addr T.sepcPrimitive-      ContractAddress ca ->-        case M.lookup ca contracts of-          Just (U.ParameterType (AsUTypeExt (_ :: Sing cp') cpNotes) rootAnn) -> do-            -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-            -- valid parameter type-            let paramNotes = ParamNotesUnsafe { pnNotes = cpNotes, pnRootAnn = rootAnn }-            Dict <- liftEither $ T.checkScope @(T.ParameterScope cp')-              `onLeft` unsupportedType-            case T.mkEntryPointCall epName paramNotes of-              Nothing ->-                throwError $-                TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $-                EntryPointNotFound epName-              Just (T.MkEntryPointCallRes (_ :: Notes t') epc) -> do-                Refl <- ensureTypeMatches @t'-                pure $ VContract addr (T.SomeEpc epc)-          Nothing ->-            throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown"-              instrPos (Just $ UnknownContract addr)+      (cv@(U.ValueString (T.parseEpAddress . unMText -> Right addr))+        , STContract pc) -> typecheckContractValue cv addr pc+      (cv@(U.ValueBytes (T.parseEpAddressRaw . U.unInternalByteString -> Right addr))+        , STContract pc) -> typecheckContractValue cv addr pc -  (U.ValueUnit, STUnit) -> pure $ VUnit-  (U.ValuePair ml mr, STPair _ _) -> do-    l <- typeCheckValImpl tcDo ml-    r <- typeCheckValImpl tcDo mr-    pure $ VPair (l, r)-  (U.ValueLeft ml, STOr{}) -> do-    l <- typeCheckValImpl tcDo ml-    pure $ VOr (Left l)-  (U.ValueRight mr, STOr{}) -> do-    r <- typeCheckValImpl tcDo mr-    pure $ VOr (Right r)-  (U.ValueSome mv, STOption{}) -> do-    v <- typeCheckValImpl tcDo mv-    pure $ VOption (Just v)-  (U.ValueNone, STOption _) -> do-    pure $ VOption Nothing+      (U.ValueUnit, STUnit) -> pure $ VUnit+      (U.ValuePair ml mr, STPair _ _) -> do+        l <- doTypeCheckVal ml+        r <- doTypeCheckVal mr+        pure $ VPair (l, r)+      (U.ValueLeft ml, STOr{}) -> do+        l <- doTypeCheckVal ml+        pure $ VOr (Left l)+      (U.ValueRight mr, STOr{}) -> do+        r <- doTypeCheckVal mr+        pure $ VOr (Right r)+      (U.ValueSome mv, STOption{}) -> do+        v <- doTypeCheckVal mv+        pure $ VOption (Just v)+      (U.ValueNone, STOption _) -> do+        pure $ VOption Nothing -  (U.ValueNil, STList _) ->-    pure $ T.VList []+      (U.ValueNil, STList _) ->+        pure $ T.VList [] -  (U.ValueSeq (toList -> mels), STList _) -> do-    els <- typeCheckValsImpl tcDo mels-    pure $ VList els+      (U.ValueSeq (toList -> mels), STList _) -> do+        els <- typeCheckValsImpl mels+        pure $ VList els -  (U.ValueNil, STSet (s :: Sing st)) -> do-    instrPos <- ask-    case T.getComparableProofS s of-      Just Dict -> pure (T.VSet S.empty)-      Nothing -> throwError $ TCFailedOnValue uvalue (demote @st) "Non comparable types are not allowed in Sets"-        instrPos (Just $ UnsupportedTypeForScope (demote @st) T.BtNotComparable)+      (U.ValueNil, STSet (s :: Sing st)) -> do+        instrPos <- ask+        case T.getComparableProofS s of+          Just Dict -> pure (T.VSet S.empty)+          Nothing -> throwError $ TCFailedOnValue uvalue (demote @st) "Non comparable types are not allowed in Sets"+            instrPos (Just $ UnsupportedTypeForScope (demote @st) T.BtNotComparable) -  (sq@(U.ValueSeq (toList -> mels)), s@(STSet (vt :: Sing st))) -> withComparable vt sq s $ do-    instrPos <- ask+      (sq@(U.ValueSeq (toList -> mels)), s@(STSet (vt :: Sing st))) -> withComparable vt sq s $ do+        instrPos <- ask -    els <- typeCheckValsImpl tcDo mels-    elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els-              `onLeft` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing-    pure $ VSet elsS+        els <- typeCheckValsImpl mels+        elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els+                  `onLeft` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing+        pure $ VSet elsS -  (v@U.ValueNil, s@(STMap (st :: Sing st) _)) -> withComparable st v s $ pure $ T.VMap M.empty+      (v@U.ValueNil, s@(STMap (st :: Sing st) _)) -> withComparable st v s $ pure $ T.VMap M.empty -  (sq@(U.ValueMap (toList -> mels)), s@(STMap (kt :: Sing st) _)) -> withComparable kt sq s $ do-    keyOrderedElts <- typeCheckMapVal tcDo mels sq kt-    pure $ VMap (M.fromDistinctAscList keyOrderedElts)+      (sq@(U.ValueMap (toList -> mels)), s@(STMap (kt :: Sing st) _)) -> withComparable kt sq s $ do+        keyOrderedElts <- typeCheckMapVal mels sq kt+        pure $ VMap (M.fromDistinctAscList keyOrderedElts) -  (v@U.ValueNil, s@(STBigMap (st :: Sing st) _)) ->-    withComparable st v s $ pure $ T.VBigMap M.empty+      (v@U.ValueNil, s@(STBigMap (st :: Sing st) _)) ->+        withComparable st v s $ pure $ T.VBigMap M.empty -  (sq@(U.ValueMap (toList -> mels)), s@(STBigMap (kt :: Sing st) _)) -> withComparable kt sq s $ do-    keyOrderedElts <- typeCheckMapVal tcDo mels sq kt-    pure $ VBigMap (M.fromDistinctAscList keyOrderedElts)+      (sq@(U.ValueMap (toList -> mels)), s@(STBigMap (kt :: Sing st) _)) -> withComparable kt sq s $ do+        keyOrderedElts <- typeCheckMapVal mels sq kt+        pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) -  (v, STLambda (_ :: Sing it) (_ :: Sing ot)) -> do-    mp <- case v of-      U.ValueNil       -> pure []-      U.ValueLambda mp -> pure $ toList mp-      _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing-    _ :/ instr <- withWTP @it $ typeCheckImpl tcDo mp ((starNotes @it, Dict, def) ::& SNil)-    case instr of-      lam ::: (lo :: HST lo) -> withWTP @ot $ do-        case eqHST1 @ot lo of-          Right Refl -> do-            pure $ VLam (T.RfNormal lam)-          Left m ->-            tcFailedOnValue v (demote @ty)-                    "wrong output type of lambda's value:" (Just m)-      AnyOutInstr lam ->-        pure $ VLam (T.RfAlwaysFails lam)+      (v, STLambda (_ :: Sing it) (_ :: Sing ot)) -> do+        mp <- case v of+          U.ValueNil       -> pure []+          U.ValueLambda mp -> pure $ toList mp+          _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing+        _ :/ instr <- withWTP @it uvalue $ typeCheckImpl tcDo mp ((starNotes @it, Dict, def) ::& SNil)+        case instr of+          lam ::: (lo :: HST lo) -> withWTP @ot uvalue $ do+            case eqHST1 @ot lo of+              Right Refl -> do+                pure $ VLam (T.RfNormal lam)+              Left m ->+                tcFailedOnValue v (demote @ty)+                        "wrong output type of lambda's value:" (Just m)+          AnyOutInstr lam ->+            pure $ VLam (T.RfAlwaysFails lam) -  (v, t) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing-  where-    withWTP :: forall t a. SingI t => (T.WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a-    withWTP fn = case getWTP @t of-      Just Dict -> fn-      Nothing -> tcFailedOnValue uvalue (fromSingT $ sing @ty) "Value is not well typed" Nothing+      (v, t) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing +    withWTP+      :: forall t a. SingI t+      => U.Value+      -> (T.WellTyped t => TypeCheckInstr a)+      -> TypeCheckInstr a+    withWTP uvalue fn = case getWTP @t of+      Right Dict -> fn+      Left (NotWellTyped t) -> tcFailedOnValue uvalue (fromSingT $ sing @ty)+                  ("Value is not well typed: " <> show t) Nothing++    typeCheckValsImpl+      :: forall t . (SingI t)+      => [U.Value]+      -> TypeCheckInstr [T.Value t]+    typeCheckValsImpl mvs =+      fmap reverse $ foldM (\res mv -> (: res) <$> doTypeCheckVal @t mv) [] mvs++    -- 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+      :: forall kt vt. (SingI kt, SingI vt)+      => [U.Elt U.ExpandedOp]+      -> U.Value+      -> Sing kt+      -> TypeCheckInstr [(T.Value kt, T.Value vt)]+    typeCheckMapVal mels sq kt = withComparable kt sq kt $ do+      instrPos <- ask+      ks <- typeCheckValsImpl @kt (map (\(U.Elt k _) -> k) mels)+      vals <- typeCheckValsImpl @vt (map (\(U.Elt _ v) -> v) mels)+      ksS <- liftEither $ ensureDistinctAsc id ks+            `onLeft` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing+      pure $ zip ksS vals++    typecheckContractValue+      :: forall cp tz. (Typeable cp, SingI cp, tz ~ 'T.TContract cp)+      => U.Value -> EpAddress -> Sing cp -> TypeCheckInstr (T.Value tz)+    typecheckContractValue cv (EpAddress addr epName) pc = do++      instrPos <- ask+      let ensureTypeMatches :: forall t'. KnownT t' => TypeCheckInstr (cp :~: t')+          ensureTypeMatches = liftEither @_ @TypeCheckInstr $+            first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $+              eqType @cp @t'+      let unsupportedType :: T.BadTypeForScope -> TCError+          unsupportedType reason = TCFailedOnValue cv (fromSingT pc)+            "Unsupported type in type argument of 'contract' type" instrPos $+              Just $ UnsupportedTypeForScope (fromSingT pc) reason+      case addr of+        KeyAddress _ -> do+          Refl <- ensureTypeMatches @'T.TUnit+          pure $ VContract addr T.sepcPrimitive+        ContractAddress ca -> case mOriginatedContracts of+          Nothing -> liftEither . Left $ unsupportedType T.BtHasContract+          Just originatedContracts -> case M.lookup ca originatedContracts of+            Just (SomeParamType (_ :: Sing cp') paramNotes) ->+              case T.mkEntrypointCall epName paramNotes of+                Nothing ->+                  throwError $+                  TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $+                  EntrypointNotFound epName+                Just (T.MkEntrypointCallRes (_ :: Notes t') epc) -> do+                  Refl <- ensureTypeMatches @t'+                  pure $ VContract addr (T.SomeEpc epc)+            Nothing ->+              throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown"+                instrPos (Just $ UnknownContract addr)+ withComparable   :: forall a (t :: T.T) ty. Sing a   -> U.Value@@ -217,37 +261,5 @@   Just Dict -> act   Nothing -> do     instrPos <- ask-    liftEither $ Left $ TCFailedOnValue uv (fromSingT t) "Require a comparable type here" instrPos Nothing---- | 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-  :: forall kt vt. (SingI kt, SingI vt)-  => TcInstrHandler-  -> [U.Elt U.ExpandedOp]-  -> U.Value-  -> Sing kt-  -> TypeCheckInstr [(T.Value kt, T.Value vt)]-typeCheckMapVal tcDo mels sq kt = withComparable kt sq kt $ do-  instrPos <- ask-  ks <- typeCheckValsImpl @kt tcDo (map (\(U.Elt k _) -> k) mels)-  vals <- typeCheckValsImpl @vt tcDo (map (\(U.Elt _ v) -> v) mels)-  ksS <- liftEither $ ensureDistinctAsc id ks-        `onLeft` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing-  pure $ zip ksS vals--typeCheckValsImpl-  :: forall t . (SingI t)-  => TcInstrHandler-  -> [U.Value]-  -> TypeCheckInstr [T.Value t]-typeCheckValsImpl tcDo mvs =-  fmap reverse $ foldM check [] mvs-  where-    check :: [T.Value t] -> U.Value -> TypeCheckInstr [T.Value t]-    check res mv = do-      v <- typeCheckValImpl @t tcDo mv-      pure (v : res)+    liftEither . Left $+      TCFailedOnValue uv (fromSingT t) "Require a comparable type here" instrPos Nothing

@@ -11,7 +11,7 @@ import Michelson.Typed.Arith as Exports import Michelson.Typed.Convert as Exports import Michelson.Typed.Doc as Exports-import Michelson.Typed.EntryPoints as Exports+import Michelson.Typed.Entrypoints as Exports import Michelson.Typed.Extract as Exports import Michelson.Typed.Haskell as Exports import Michelson.Typed.Instr as Exports

@@ -37,6 +37,7 @@ import Data.Singletons (Sing, SingI(..)) import Fmt (Buildable(build)) +import Michelson.Typed.Annotation (AnnConvergeError, Notes(..), converge, convergeAnns, starNotes) import Michelson.Typed.Sing (SingT(..)) import Michelson.Typed.T (T(..)) import Michelson.Typed.Value (Comparable, Comparability(..), checkComparability, Value'(..))@@ -56,6 +57,13 @@   -- @ArithRes Add CNat CInt = CInt@.   type ArithRes aop n m :: T +  -- | Converge the notes of given operands.+  convergeArith+    :: proxy aop+    -> Notes n+    -> Notes m+    -> Either AnnConvergeError (Notes (ArithRes aop n m))+   -- | Evaluate arithmetic operation on given operands.   evalOp     :: proxy aop@@ -110,75 +118,96 @@  instance ArithOp Add 'TNat 'TInt where   type ArithRes Add 'TNat 'TInt = 'TInt+  convergeArith _ _ n2 = Right n2   evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i + j) instance ArithOp Add 'TInt 'TNat where   type ArithRes Add 'TInt 'TNat = 'TInt+  convergeArith _ n1 _ = Right n1   evalOp _ (VInt i) (VNat j) = Right $ VInt (i + toInteger j) instance ArithOp Add 'TNat 'TNat where   type ArithRes Add 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VNat i) (VNat j) = Right $ VNat (i + j) instance ArithOp Add 'TInt 'TInt where   type ArithRes Add 'TInt 'TInt = 'TInt+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VInt i) (VInt j) = Right $ VInt (i + j) instance ArithOp Add 'TTimestamp 'TInt where   type ArithRes Add 'TTimestamp 'TInt = 'TTimestamp+  convergeArith _ n1 _ = Right n1   evalOp _ (VTimestamp i) (VInt j) =     Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i + j instance ArithOp Add 'TInt 'TTimestamp where   type ArithRes Add 'TInt 'TTimestamp = 'TTimestamp+  convergeArith _ _ n2 = Right n2   evalOp _ (VInt i) (VTimestamp j) =     Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds j + i instance ArithOp Add 'TMutez 'TMutez where   type ArithRes Add 'TMutez 'TMutez = 'TMutez+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ n@(VMutez i) m@(VMutez j) = res     where       res = maybe (Left $ MutezArithError AddOverflow n m) (Right . VMutez) $ i `addMutez` j  instance ArithOp Sub 'TNat 'TInt where   type ArithRes Sub 'TNat 'TInt = 'TInt+  convergeArith _ _ n2 = Right n2   evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i - j) instance ArithOp Sub 'TInt 'TNat where   type ArithRes Sub 'TInt 'TNat = 'TInt+  convergeArith _ n1 _ = Right n1   evalOp _ (VInt i) (VNat j) = Right $ VInt (i - toInteger j) instance ArithOp Sub 'TNat 'TNat where   type ArithRes Sub 'TNat 'TNat = 'TInt+  -- | Subtraction between @Nat@ and @Nat@ does not retain annotation.+  convergeArith _ n1 n2 = (const starNotes) <$> converge n1 n2   evalOp _ (VNat i) (VNat j) = Right $ VInt (toInteger i - toInteger j) instance ArithOp Sub 'TInt 'TInt where   type ArithRes Sub 'TInt 'TInt = 'TInt+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VInt i) (VInt j) = Right $ VInt (i - j) instance ArithOp Sub 'TTimestamp 'TInt where   type ArithRes Sub 'TTimestamp 'TInt = 'TTimestamp+  convergeArith _ n1 _ = Right n1   evalOp _ (VTimestamp i) (VInt j) =     Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i - j instance ArithOp Sub 'TTimestamp 'TTimestamp where   type ArithRes Sub 'TTimestamp 'TTimestamp = 'TInt+  convergeArith _ (NTTimestamp a) (NTTimestamp b) = NTInt <$> (convergeAnns a b)   evalOp _ (VTimestamp i) (VTimestamp j) =     Right $ VInt $ timestampToSeconds i - timestampToSeconds j instance ArithOp Sub 'TMutez 'TMutez where   type ArithRes Sub 'TMutez 'TMutez = 'TMutez+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ n@(VMutez i) m@(VMutez j) = res     where       res = maybe (Left $ MutezArithError SubUnderflow n m) (Right . VMutez) $ i `subMutez` j  instance ArithOp Mul 'TNat 'TInt where   type ArithRes Mul 'TNat 'TInt = 'TInt+  convergeArith _ _ n2 = Right n2   evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i * j) instance ArithOp Mul 'TInt 'TNat where   type ArithRes Mul 'TInt 'TNat = 'TInt+  convergeArith _ n1 _ = Right n1   evalOp _ (VInt i) (VNat j) = Right $ VInt (i * toInteger j) instance ArithOp Mul 'TNat 'TNat where   type ArithRes Mul 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VNat i) (VNat j) = Right $ VNat (i * j) instance ArithOp Mul 'TInt 'TInt where   type ArithRes Mul 'TInt 'TInt = 'TInt+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VInt i) (VInt j) = Right $ VInt (i * j) instance ArithOp Mul 'TNat 'TMutez where   type ArithRes Mul 'TNat 'TMutez = 'TMutez+  convergeArith _ _ n2 = Right n2   evalOp _ n@(VNat i) m@(VMutez j) = res     where       res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ j `mulMutez` i instance ArithOp Mul 'TMutez 'TNat where   type ArithRes Mul 'TMutez 'TNat = 'TMutez+  convergeArith _ n1 _ = Right n1   evalOp _ n@(VMutez i) m@(VNat j) = res     where       res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ i `mulMutez` j@@ -196,30 +225,38 @@  instance ArithOp Or 'TNat 'TNat where   type ArithRes Or 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VNat i) (VNat j) = Right $ VNat (i .|. j) instance ArithOp Or 'TBool 'TBool where   type ArithRes Or 'TBool 'TBool = 'TBool+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VBool i) (VBool j) = Right $ VBool (i .|. j)  instance ArithOp And 'TInt 'TNat where   type ArithRes And 'TInt 'TNat = 'TNat+  convergeArith _ _ n2 = Right n2   evalOp _ (VInt i) (VNat j) = Right $ VNat ((fromInteger i) .&. j) instance ArithOp And 'TNat 'TNat where   type ArithRes And 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VNat i) (VNat j) = Right $ VNat (i .&. j) instance ArithOp And 'TBool 'TBool where   type ArithRes And 'TBool 'TBool = 'TBool+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VBool i) (VBool j) = Right $ VBool (i .&. j)  instance ArithOp Xor 'TNat 'TNat where   type ArithRes Xor 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VNat i) (VNat j) = Right $ VNat (i `xor` j) instance ArithOp Xor 'TBool 'TBool where   type ArithRes Xor 'TBool 'TBool = 'TBool+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ (VBool i) (VBool j) = Right $ VBool (i `xor` j)  instance ArithOp Lsl 'TNat 'TNat where   type ArithRes Lsl 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ n@(VNat i) m@(VNat j) =     if j > 256     then Left $ ShiftArithError LslOverflow n m@@ -227,6 +264,7 @@  instance ArithOp Lsr 'TNat 'TNat where   type ArithRes Lsr 'TNat 'TNat = 'TNat+  convergeArith _ n1 n2 = converge n1 n2   evalOp _ n@(VNat i) m@(VNat j) =     if j > 256     then Left $ ShiftArithError LsrUnderflow n m

@@ -17,7 +17,7 @@  import Michelson.Text import Michelson.Typed.Annotation (Notes(..))-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Extract (mkUType, toUType) import Michelson.Typed.Instr as Instr import Michelson.Typed.Scope@@ -38,6 +38,7 @@     { contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn     , contractStorage = untypeDemoteT @store     , contractCode = instrToOps contract+    , entriesOrder = U.canonicalEntriesOrder     }  convertContract@@ -48,6 +49,7 @@   in c { U.contractParameter = U.ParameterType (mkUType (pnNotes $ cParamNotes fc))          (pnRootAnn (cParamNotes fc))        , U.contractStorage = mkUType (cStoreNotes fc)+       , U.entriesOrder = cEntriesOrder fc        }  -- | Convert a typed 'Val' to an untyped 'Value'.

@@ -1,478 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ---- | Utilities for lightweight entrypoints support.-module Michelson.Typed.EntryPoints-  ( EpAddress (..)-  , ParseEpAddressError (..)-  , formatEpAddress-  , mformatEpAddress-  , parseEpAddress-  , unsafeParseEpAddress-  , genEpAddress--  , ParamNotes (..)-  , pattern ParamNotes-  , starParamNotes-  , ArmCoord (..)-  , ArmCoords-  , ParamEpError (..)-  , mkParamNotes--  , EpLiftSequence (..)-  , EntryPointCallT (..)-  , epcPrimitive-  , epcCallRootUnsafe-  , SomeEntryPointCallT (..)-  , sepcCallRootUnsafe-  , sepcPrimitive-  , sepcName-  , ForbidOr-  , MkEntryPointCallRes (..)-  , mkEntryPointCall--  , tyImplicitAccountParam-  , flattenEntryPoints--    -- * Re-exports-  , EpName (..)-  , pattern DefEpName-  , epNameFromParamAnn-  , epNameToParamAnn-  , epNameFromRefAnn-  , epNameToRefAnn-  , EpNameFromRefAnnError (..)-  ) where--import Control.Monad.Except (throwError)-import Data.Constraint (Dict(..))-import Data.Default (Default(..))-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import Fmt (Buildable(..), pretty, (+|), (|+))-import Hedgehog (GenBase, MonadGen)-import Test.QuickCheck (Arbitrary(..))--import Michelson.Text-import Michelson.Typed.Annotation-import Michelson.Typed.Extract-import Michelson.Typed.Scope-import Michelson.Typed.Sing-import Michelson.Typed.T-import qualified Michelson.Untyped as U-import Michelson.Untyped.Annotation-import Michelson.Untyped.EntryPoints-import Tezos.Address (Address, ParseAddressError, formatAddress, genAddress, parseAddress)-import Util.Test.Gen (genEpName)-import Util.TH-import Util.Typeable-import Util.TypeLits--------------------------------------------------------------------------------- Primitives----------------------------------------------------------------------------------- EpAddress--------------------------------------------------------------------------------- | Address with optional entrypoint name attached to it.--- TODO: come up with better name?-data EpAddress = EpAddress-  { eaAddress :: Address-    -- ^ Address itself-  , eaEntryPoint :: EpName-    -- ^ Entrypoint name (might be empty)-  } deriving stock (Show, Eq, Ord, Generic)--instance Buildable EpAddress where-  build = build . formatEpAddress--instance NFData EpAddress--formatEpAddress :: EpAddress -> Text-formatEpAddress (EpAddress addr ep)-  | ep == def = formatAddress addr-  | otherwise = formatAddress addr <> "%" <> pretty ep--mformatEpAddress :: EpAddress -> MText-mformatEpAddress ea =-  let t = formatEpAddress ea-     -- Should be safe because set of characters allowed in annotations-     -- (and thus in 'EpName') is subset of characters allowed in Michelson strings.-  in mkMTextUnsafe t--data ParseEpAddressError-  = ParseEpAddressBadAddress ParseAddressError-  | ParseEpAddressBadRefAnn Text-  | ParseEpAddressRefAnnError EpNameFromRefAnnError-  deriving stock (Show, Eq, Generic)--instance NFData ParseEpAddressError--instance Buildable ParseEpAddressError where-  build = \case-    ParseEpAddressBadAddress err -> build err-    ParseEpAddressBadRefAnn txt -> pretty $ "Invalid reference annotation: " <> txt-    ParseEpAddressRefAnnError err -> build err---- | Parse an address which can be suffixed with entrypoint name--- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").-parseEpAddress :: Text -> Either ParseEpAddressError EpAddress-parseEpAddress txt =-  let (addrTxt, mannotTxt) = T.breakOn "%" txt-  in case mannotTxt of-    "" -> do-      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt-      return $ EpAddress addr def-    annotTxt' -> do-      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt-      annot <- first ParseEpAddressBadRefAnn $ case T.stripPrefix "%" annotTxt' of-        Nothing -> error "impossible"-        Just a -> mkAnnotation a-      epName <- first ParseEpAddressRefAnnError $ epNameFromRefAnn annot-      return $ EpAddress addr epName--unsafeParseEpAddress :: HasCallStack => Text -> EpAddress-unsafeParseEpAddress = either (error . pretty) id . parseEpAddress--instance Arbitrary FieldAnn => Arbitrary EpAddress where-  arbitrary = EpAddress <$> arbitrary <*> arbitrary--genEpAddress :: (MonadGen m, GenBase m ~ Identity) => m EpAddress-genEpAddress = EpAddress <$> genAddress <*> genEpName---- ParamNotes--------------------------------------------------------------------------------- | Annotations for contract parameter declaration.------ Following the Michelson specification, this type has the following invariants:--- 1. No entrypoint name is duplicated.--- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.-data ParamNotes (t :: T) = ParamNotesUnsafe-  { pnNotes   :: Notes t-  , pnRootAnn :: RootAnn-  } deriving stock (Show, Eq, Generic)-    deriving anyclass (NFData)--pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t-pattern ParamNotes t f <- ParamNotesUnsafe t f-{-# COMPLETE ParamNotes #-}---- | Parameter without annotations.-starParamNotes :: SingI t => ParamNotes t-starParamNotes = ParamNotesUnsafe starNotes noAnn---- | Coordinates of "arm" in Or tree, used solely in error messages.-type ArmCoords = [ArmCoord]-data ArmCoord = AcLeft | AcRight-  deriving stock (Show, Eq, Generic)--instance NFData ArmCoord--instance Buildable ArmCoord where-  build = \case-    AcLeft -> "left"-    AcRight -> "right"---- | Errors specific to parameter type declaration (entrypoints).-data ParamEpError-  = ParamEpDuplicatedNames (NonEmpty EpName)-  | ParamEpUncallableArm ArmCoords-  deriving stock (Show, Eq, Generic)--instance NFData ParamEpError--instance Buildable ParamEpError where-  build = \case-    ParamEpDuplicatedNames names -> mconcat-      [ "Duplicated entrypoint names: "-      , mconcat . intersperse ", " $ map (surround "'" "'" . build) (toList names)-      ]-    ParamEpUncallableArm arm -> mconcat-      [ "Due to presence of 'default' entrypoint, one of contract \"arms\" \-        \cannot be called: \""-      , mconcat . intersperse " - " $ map build arm-      , "\""-      , if length arm > 1 then " (in top-to-bottom order)" else ""-      ]-    where-    surround pre post builder = pre <> builder <> post---- | Check whether given notes are valid parameter notes.-verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()-verifyParamNotes notes ra = do-  let allEps = appEndo (gatherEntrypoints notes) []-      duplicatedEps-        = mapMaybe (safeHead . tail)-        . NE.group-        . sort-        $ maybe allEps (: allEps) (epNameFromParamAnn $ convAnn ra)--  whenJust (nonEmpty duplicatedEps) $ \dups ->-    throwError $ ParamEpDuplicatedNames dups--  -- In case contract have explicit root entrypoint, we assume that everything is-  -- callable.-  when (ra == noAnn) $ void-    $ first ParamEpUncallableArm-    $ ensureAllCallable notes-  where-    gatherEntrypoints :: Notes t -> Endo [EpName]-    gatherEntrypoints = \case-      NTOr _ fn1 fn2 l r -> mconcat-        [ Endo $ maybe id (:) (epNameFromParamAnn fn1)-        , Endo $ maybe id (:) (epNameFromParamAnn fn2)-        , gatherEntrypoints l-        , gatherEntrypoints r-        ]-      _ -> mempty--    -- Here we can assume that there is no more than one @default@ entrypoint,-    -- because duplications check occurs earlier.-    ---    -- In case when multiple entrypoints are uncallable, the reference-    -- implementation prefers displaying (in error message) arms which are-    -- closer to the root, but here we don't do this because that would be-    -- some more complex to implement and not sure how much does it worth that.-    ensureAllCallable :: Notes t -> Either ArmCoords Bool-    ensureAllCallable = \case-      NTOr _ fnL fnR l r -> do-        let epNameL = epNameFromParamAnn fnL-        let epNameR = epNameFromParamAnn fnR-        haveDefLL <- first (AcLeft  :) $ ensureAllCallable l-        haveDefRR <- first (AcRight :) $ ensureAllCallable r--        let haveDefL = or [haveDefLL, epNameL == Just (def @EpName)]-        let haveDefR = or [haveDefRR, epNameR == Just (def @EpName)]--        when haveDefL $ first (AcRight :) $ checkAllEpsNamed epNameR r-        when haveDefR $ first (AcLeft  :) $ checkAllEpsNamed epNameL l--        return $ or [haveDefL, haveDefR]--      _ -> return False--    checkAllEpsNamed :: Maybe EpName -> Notes t -> Either ArmCoords ()-    checkAllEpsNamed epNameRoot-      | isJust epNameRoot = \_ -> pass-      | otherwise = \case-          NTOr _ fnL fnR l r -> do-            let epNameL = epNameFromParamAnn fnL-                epNameR = epNameFromParamAnn fnR--            first (AcLeft  :) $ checkAllEpsNamed epNameL l-            first (AcRight :) $ checkAllEpsNamed epNameR r--          _ -> throwError []---- | Construct 'ParamNotes' performing all necessary checks.-mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)-mkParamNotes nt fa = verifyParamNotes nt fa $> ParamNotesUnsafe nt fa--------------------------------------------------------------------------------- Entrypoint logic--------------------------------------------------------------------------------- | Describes how to construct full contract parameter from given entrypoint--- argument.------ This could be just wrapper over @Value arg -> Value param@, but we cannot--- use @Value@ type in this module easily.-data EpLiftSequence (arg :: T) (param :: T) where-  EplArgHere :: EpLiftSequence arg arg-  EplWrapLeft-    :: (KnownT subparam, KnownT r)-    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)-  EplWrapRight-    :: (KnownT l, KnownT subparam)-    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)--deriving stock instance Eq (EpLiftSequence arg param)-deriving stock instance Show (EpLiftSequence arg param)--$(deriveGADTNFData ''EpLiftSequence)--instance Buildable (EpLiftSequence arg param) where-  build = \case-    EplArgHere -> "×"-    EplWrapLeft es -> "Left (" <> build es <> ")"-    EplWrapRight es -> "Right (" <> build es <> ")"---- | Reference for calling a specific entrypoint of type @arg@.-data EntryPointCallT (param :: T) (arg :: T) =-  ParameterScope arg => EntryPointCall-  { epcName :: EpName-    -- ^ Name of entrypoint.-  , epcParamProxy :: Proxy param-    -- ^ Proxy of parameter, to make parameter type more easily fetchable.-  , epcLiftSequence :: EpLiftSequence arg param-    -- ^ How to call this entrypoint in the corresponding contract.-  }--deriving stock instance Eq (EntryPointCallT param arg)-deriving stock instance Show (EntryPointCallT param arg)-instance NFData (EntryPointCallT param arg) where-  rnf (EntryPointCall name Proxy s) = rnf (name, s)--instance Buildable (EntryPointCallT param arg) where-  build EntryPointCall{..} =-    "Call " +| epcName |+ ": " +| epcLiftSequence |+ ""---- | Construct 'EntryPointCallT' which calls no entrypoint and assumes that--- there is no explicit "default" one.------ Validity of such operation is not ensured.-epcCallRootUnsafe :: ParameterScope param => EntryPointCallT param param-epcCallRootUnsafe = EntryPointCall-  { epcName = def-  , epcParamProxy = Proxy-  , epcLiftSequence = EplArgHere-  }---- | Call parameter which has no entrypoints, always safe.-epcPrimitive-  :: forall p.-     (ParameterScope p, ForbidOr p)-  => EntryPointCallT p p-epcPrimitive = epcCallRootUnsafe-  where-  _requireNoOr = Dict @(ForbidOr p)--type family ForbidOr (t :: T) :: Constraint where-  ForbidOr ('TOr l r) =-    TypeError-    ('Text "Cannot apply to sum type parameter " ':<>: 'ShowType ('TOr l r))-  ForbidOr _ = ()---- | 'EntryPointCallT' with hidden parameter type.------ This requires argument to satisfy 'ParameterScope' constraint.--- Strictly speaking, entrypoint argument may one day start having different--- set of constraints comparing to ones applied to parameter, but this seems--- unlikely.-data SomeEntryPointCallT (arg :: T) =-  forall param. (ParameterScope param) =>-  SomeEpc (EntryPointCallT param arg)--instance Eq (SomeEntryPointCallT arg) where-  SomeEpc epc1 == SomeEpc epc2 = isJust @() $ do-    Refl <- eqP (epcParamProxy epc1) (epcParamProxy epc2)-    guard (epc1 == epc2)--deriving stock instance Show (SomeEntryPointCallT arg)-instance NFData (SomeEntryPointCallT arg) where-  rnf (SomeEpc epc) = rnf epc--instance Buildable (SomeEntryPointCallT arg) where-  build (SomeEpc epc) = build epc---- | Construct 'SomeEntryPointCallT' which calls no entrypoint and assumes that--- there is no explicit "default" one.------ Validity of such operation is not ensured.-sepcCallRootUnsafe :: ParameterScope param => SomeEntryPointCallT param-sepcCallRootUnsafe = SomeEpc epcCallRootUnsafe---- | Call parameter which has no entrypoints, always safe.-sepcPrimitive-  :: forall t.-     (ParameterScope t, ForbidOr t)-  => SomeEntryPointCallT t-sepcPrimitive = SomeEpc epcPrimitive--sepcName :: SomeEntryPointCallT arg -> EpName-sepcName (SomeEpc epc) = epcName epc---- | Build 'EpLiftSequence'.------ Here we accept entrypoint name and type information for the parameter--- of target contract.------ Returns 'Nothing' if entrypoint is not found.--- Does not treat default entrypoints specially.-withEpLiftSequence-  :: forall param r.-     (ParameterScope param)-  => EpName-  -> Notes param-  -> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)-  -> Maybe r-withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =-  case (sing @param, param) of-    (STOr lSing _, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->-      case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of-        (OpAbsent, NestedBigMapsAbsent) -> asum-          [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)-          , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)-          , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft)-          , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight)-          ]-    _ -> Nothing---- Helper datatype for 'mkEntryPointCall'.-data MkEntryPointCallRes param where-  MkEntryPointCallRes-    :: ParameterScope arg-    => Notes arg-    -> EntryPointCallT param arg-    -> MkEntryPointCallRes param---- | Build 'EntryPointCallT'.------ Here we accept entrypoint name and type information for the parameter--- of target contract.------ Returns 'Nothing' if entrypoint is not found.-mkEntryPointCall-  :: (ParameterScope param)-  => EpName-  -> ParamNotes param-  -> Maybe (MkEntryPointCallRes param)-mkEntryPointCall epName (ParamNotes paramNotes root) =-  asum-  [ do-      epName' <- epNameFromParamAnn $ convAnn root-      guard (epName == epName')-      return $ MkEntryPointCallRes-        paramNotes-        EntryPointCall-          { epcName = epName-          , epcParamProxy = Proxy-          , epcLiftSequence = EplArgHere-          }-  , withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) ->-      MkEntryPointCallRes argInfo $ EntryPointCall-        { epcName = epName-        , epcParamProxy = Proxy-        , epcLiftSequence = liftSeq-        }-  , guard (epName == def) $>-      MkEntryPointCallRes paramNotes EntryPointCall-        { epcName = def-        , epcParamProxy = Proxy-        , epcLiftSequence = EplArgHere-        }-  ]---- | "Parameter" type of implicit account.-tyImplicitAccountParam :: ParamNotes 'TUnit-tyImplicitAccountParam = ParamNotesUnsafe starNotes noAnn---- Misc--------------------------------------------------------------------------------- | Flatten a provided list of notes to a map of its entrypoints and its--- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how--- duplicate entrypoints are handled.-flattenEntryPoints :: SingI t => ParamNotes t -> Map EpName U.Type-flattenEntryPoints (pnNotes -> notes) = mkEntrypointsMap (mkUType notes)---- TODO [#35]: Root annotation is currently support as a dedicated field--- in 'ParamNotes'.------ Also it would be nice to automatically add @%root@ annotation in each parameter--- declaration when compiling Lorentz to Michelson.--- In addition to this, we should actually use @%root@ annotation in the entrypoint engine--- and not just store it.

@@ -0,0 +1,512 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for lightweight entrypoints support.+module Michelson.Typed.Entrypoints+  ( EpAddress (..)+  , ParseEpAddressError (..)+  , formatEpAddress+  , mformatEpAddress+  , parseEpAddress+  , unsafeParseEpAddress+  , parseEpAddressRaw+  , unsafeParseEpAddressRaw+  , ParamNotes (..)+  , pattern ParamNotes+  , starParamNotes+  , ArmCoord (..)+  , ArmCoords+  , ParamEpError (..)+  , mkParamNotes++  , EpLiftSequence (..)+  , EntrypointCallT (..)+  , epcPrimitive+  , epcCallRootUnsafe+  , SomeEntrypointCallT (..)+  , sepcCallRootUnsafe+  , sepcPrimitive+  , sepcName+  , ForbidOr+  , MkEntrypointCallRes (..)+  , mkEntrypointCall++  , tyImplicitAccountParam+  , flattenEntrypoints++    -- * Re-exports+  , EpName (..)+  , pattern DefEpName+  , epNameFromParamAnn+  , epNameToParamAnn+  , epNameFromRefAnn+  , epNameToRefAnn+  , EpNameFromRefAnnError (..)+  ) where++import Control.Monad.Except (throwError)+import qualified Data.ByteString as BS+import Data.Constraint (Dict(..))+import Data.Default (Default(..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import Fmt (Buildable(..), hexF, pretty, (+|), (|+))+import Test.QuickCheck (Arbitrary(..))++import Michelson.Text+import Michelson.Typed.Annotation+import Michelson.Typed.Extract+import Michelson.Typed.Scope+import Michelson.Typed.Sing+import Michelson.Typed.T+import qualified Michelson.Untyped as U+import Michelson.Untyped.Annotation+import Michelson.Untyped.Entrypoints+import Tezos.Address+import Tezos.Crypto (keyHashLengthBytes)+import Util.TH+import Util.Typeable+import Util.TypeLits++----------------------------------------------------------------------------+-- Primitives+----------------------------------------------------------------------------+--+-- EpAddress+----------------------------------------------------------------------------++-- | Address with optional entrypoint name attached to it.+-- TODO: come up with better name?+data EpAddress = EpAddress+  { eaAddress :: Address+    -- ^ Address itself+  , eaEntrypoint :: EpName+    -- ^ Entrypoint name (might be empty)+  } deriving stock (Show, Eq, Ord, Generic)++instance Buildable EpAddress where+  build = build . formatEpAddress++instance NFData EpAddress++formatEpAddress :: EpAddress -> Text+formatEpAddress (EpAddress addr ep)+  | ep == def = formatAddress addr+  | otherwise = formatAddress addr <> "%" <> pretty ep++mformatEpAddress :: EpAddress -> MText+mformatEpAddress ea =+  let t = formatEpAddress ea+     -- Should be safe because set of characters allowed in annotations+     -- (and thus in 'EpName') is subset of characters allowed in Michelson strings.+  in mkMTextUnsafe t++data ParseEpAddressError+  = ParseEpAddressBadAddress ParseAddressError+  | ParseEpAddressRawBadAddress ParseAddressRawError+  | ParseEpAddressBadEntryopint ByteString UnicodeException+  | ParseEpAddressBadRefAnn Text+  | ParseEpAddressRefAnnError EpNameFromRefAnnError+  | ParseEpAddressInvalidLength Int+  deriving stock (Show, Eq, Generic)++instance NFData ParseEpAddressError++instance Buildable ParseEpAddressError where+  build = \case+    ParseEpAddressBadAddress err -> build err+    ParseEpAddressRawBadAddress err -> build err+    ParseEpAddressBadEntryopint addr exception ->+      "Invalid entrypoint given for raw adddress " <> hexF addr <>+      " and failed with " <> build (show @Text exception)+    ParseEpAddressBadRefAnn txt -> pretty $ "Invalid reference annotation: " <> txt+    ParseEpAddressRefAnnError err -> build err+    ParseEpAddressInvalidLength len ->+      "Given raw entrypoint address has invalid length: " <> build len++-- | Parse an address which can be suffixed with entrypoint name+-- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").+parseEpAddress :: Text -> Either ParseEpAddressError EpAddress+parseEpAddress txt =+  let (addrTxt, mannotTxt) = T.breakOn "%" txt+  in case mannotTxt of+    "" -> do+      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt+      return $ EpAddress addr def+    annotTxt' -> do+      addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt+      annot <- first ParseEpAddressBadRefAnn $ case T.stripPrefix "%" annotTxt' of+        Nothing -> error "impossible"+        Just a -> mkAnnotation a+      epName <- first ParseEpAddressRefAnnError $ epNameFromRefAnn annot+      return $ EpAddress addr epName++unsafeParseEpAddress :: HasCallStack => Text -> EpAddress+unsafeParseEpAddress = either (error . pretty) id . parseEpAddress++instance Arbitrary FieldAnn => Arbitrary EpAddress where+  arbitrary = EpAddress <$> arbitrary <*> arbitrary++-- | Parses byte representation of entrypoint address.+--+-- For every address+--+-- @+-- KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo%bar+-- @+--+-- we get the following byte representation+--+-- @+-- 01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f25626172+-- \________________________________________/\/\____/\/\____/+--               address                     %   ep1  % ep2+-- @+--+parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress+parseEpAddressRaw raw = do+  let (bytes, eps) = BS.splitAt (keyHashLengthBytes + 2) raw+  eaAddress <- first ParseEpAddressRawBadAddress $ parseAddressRaw bytes+  decodedEntrypoint <- first (ParseEpAddressBadEntryopint raw) $ decodeUtf8' eps+  decodedAnnotation <- first ParseEpAddressBadRefAnn $ mkAnnotation decodedEntrypoint+  eaEntrypoint <- first ParseEpAddressRefAnnError $ epNameFromRefAnn decodedAnnotation+  pure $ EpAddress {..}++unsafeParseEpAddressRaw :: ByteString -> EpAddress+unsafeParseEpAddressRaw = either (error . pretty) id . parseEpAddressRaw++-- ParamNotes+----------------------------------------------------------------------------++-- | Annotations for contract parameter declaration.+--+-- Following the Michelson specification, this type has the following invariants:+-- 1. No entrypoint name is duplicated.+-- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.+data ParamNotes (t :: T) = ParamNotesUnsafe+  { pnNotes   :: Notes t+  , pnRootAnn :: RootAnn+  } deriving stock (Show, Eq, Generic)+    deriving anyclass (NFData)++pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t+pattern ParamNotes t f <- ParamNotesUnsafe t f+{-# COMPLETE ParamNotes #-}++-- | Parameter without annotations.+starParamNotes :: SingI t => ParamNotes t+starParamNotes = ParamNotesUnsafe starNotes noAnn++-- | Coordinates of "arm" in Or tree, used solely in error messages.+type ArmCoords = [ArmCoord]+data ArmCoord = AcLeft | AcRight+  deriving stock (Show, Eq, Generic)++instance NFData ArmCoord++instance Buildable ArmCoord where+  build = \case+    AcLeft -> "left"+    AcRight -> "right"++-- | Errors specific to parameter type declaration (entrypoints).+data ParamEpError+  = ParamEpDuplicatedNames (NonEmpty EpName)+  | ParamEpUncallableArm ArmCoords+  deriving stock (Show, Eq, Generic)++instance NFData ParamEpError++instance Buildable ParamEpError where+  build = \case+    ParamEpDuplicatedNames names -> mconcat+      [ "Duplicated entrypoint names: "+      , mconcat . intersperse ", " $ map (surround "'" "'" . build) (toList names)+      ]+    ParamEpUncallableArm arm -> mconcat+      [ "Due to presence of 'default' entrypoint, one of contract \"arms\" \+        \cannot be called: \""+      , mconcat . intersperse " - " $ map build arm+      , "\""+      , if length arm > 1 then " (in top-to-bottom order)" else ""+      ]+    where+    surround pre post builder = pre <> builder <> post++-- | Check whether given notes are valid parameter notes.+verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()+verifyParamNotes notes ra = do+  let allEps = appEndo (gatherEntrypoints notes) []+      duplicatedEps+        = mapMaybe (safeHead . tail)+        . NE.group+        . sort+        $ maybe allEps (: allEps) (epNameFromParamAnn $ convAnn ra)++  whenJust (nonEmpty duplicatedEps) $ \dups ->+    throwError $ ParamEpDuplicatedNames dups++  -- In case contract have explicit root entrypoint, we assume that everything is+  -- callable.+  when (ra == noAnn) $ void+    $ first ParamEpUncallableArm+    $ ensureAllCallable notes+  where+    gatherEntrypoints :: Notes t -> Endo [EpName]+    gatherEntrypoints = \case+      NTOr _ fn1 fn2 l r -> mconcat+        [ Endo $ maybe id (:) (epNameFromParamAnn fn1)+        , Endo $ maybe id (:) (epNameFromParamAnn fn2)+        , gatherEntrypoints l+        , gatherEntrypoints r+        ]+      _ -> mempty++    -- Here we can assume that there is no more than one @default@ entrypoint,+    -- because duplications check occurs earlier.+    --+    -- In case when multiple entrypoints are uncallable, the reference+    -- implementation prefers displaying (in error message) arms which are+    -- closer to the root, but here we don't do this because that would be+    -- some more complex to implement and not sure how much does it worth that.+    ensureAllCallable :: Notes t -> Either ArmCoords Bool+    ensureAllCallable = \case+      NTOr _ fnL fnR l r -> do+        let epNameL = epNameFromParamAnn fnL+        let epNameR = epNameFromParamAnn fnR+        haveDefLL <- first (AcLeft  :) $ ensureAllCallable l+        haveDefRR <- first (AcRight :) $ ensureAllCallable r++        let haveDefL = or [haveDefLL, epNameL == Just (def @EpName)]+        let haveDefR = or [haveDefRR, epNameR == Just (def @EpName)]++        when haveDefL $ first (AcRight :) $ checkAllEpsNamed epNameR r+        when haveDefR $ first (AcLeft  :) $ checkAllEpsNamed epNameL l++        return $ or [haveDefL, haveDefR]++      _ -> return False++    checkAllEpsNamed :: Maybe EpName -> Notes t -> Either ArmCoords ()+    checkAllEpsNamed epNameRoot+      | isJust epNameRoot = \_ -> pass+      | otherwise = \case+          NTOr _ fnL fnR l r -> do+            let epNameL = epNameFromParamAnn fnL+                epNameR = epNameFromParamAnn fnR++            first (AcLeft  :) $ checkAllEpsNamed epNameL l+            first (AcRight :) $ checkAllEpsNamed epNameR r++          _ -> throwError []++-- | Construct 'ParamNotes' performing all necessary checks.+mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)+mkParamNotes nt fa = verifyParamNotes nt fa $> ParamNotesUnsafe nt fa++----------------------------------------------------------------------------+-- Entrypoint logic+----------------------------------------------------------------------------++-- | Describes how to construct full contract parameter from given entrypoint+-- argument.+--+-- This could be just wrapper over @Value arg -> Value param@, but we cannot+-- use @Value@ type in this module easily.+data EpLiftSequence (arg :: T) (param :: T) where+  EplArgHere :: EpLiftSequence arg arg+  EplWrapLeft+    :: (KnownT subparam, KnownT r)+    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)+  EplWrapRight+    :: (KnownT l, KnownT subparam)+    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)++deriving stock instance Eq (EpLiftSequence arg param)+deriving stock instance Show (EpLiftSequence arg param)++$(deriveGADTNFData ''EpLiftSequence)++instance Buildable (EpLiftSequence arg param) where+  build = \case+    EplArgHere -> "×"+    EplWrapLeft es -> "Left (" <> build es <> ")"+    EplWrapRight es -> "Right (" <> build es <> ")"++-- | Reference for calling a specific entrypoint of type @arg@.+data EntrypointCallT (param :: T) (arg :: T) =+  ParameterScope arg => EntrypointCall+  { epcName :: EpName+    -- ^ Name of entrypoint.+  , epcParamProxy :: Proxy param+    -- ^ Proxy of parameter, to make parameter type more easily fetchable.+  , epcLiftSequence :: EpLiftSequence arg param+    -- ^ How to call this entrypoint in the corresponding contract.+  }++deriving stock instance Eq (EntrypointCallT param arg)+deriving stock instance Show (EntrypointCallT param arg)+instance NFData (EntrypointCallT param arg) where+  rnf (EntrypointCall name Proxy s) = rnf (name, s)++instance Buildable (EntrypointCallT param arg) where+  build EntrypointCall{..} =+    "Call " +| epcName |+ ": " +| epcLiftSequence |+ ""++-- | Construct 'EntrypointCallT' which calls no entrypoint and assumes that+-- there is no explicit "default" one.+--+-- Validity of such operation is not ensured.+epcCallRootUnsafe :: ParameterScope param => EntrypointCallT param param+epcCallRootUnsafe = EntrypointCall+  { epcName = def+  , epcParamProxy = Proxy+  , epcLiftSequence = EplArgHere+  }++-- | Call parameter which has no entrypoints, always safe.+epcPrimitive+  :: forall p.+     (ParameterScope p, ForbidOr p)+  => EntrypointCallT p p+epcPrimitive = epcCallRootUnsafe+  where+  _requireNoOr = Dict @(ForbidOr p)++type family ForbidOr (t :: T) :: Constraint where+  ForbidOr ('TOr l r) =+    TypeError+    ('Text "Cannot apply to sum type parameter " ':<>: 'ShowType ('TOr l r))+  ForbidOr _ = ()++-- | 'EntrypointCallT' with hidden parameter type.+--+-- This requires argument to satisfy 'ParameterScope' constraint.+-- Strictly speaking, entrypoint argument may one day start having different+-- set of constraints comparing to ones applied to parameter, but this seems+-- unlikely.+data SomeEntrypointCallT (arg :: T) =+  forall param. (ParameterScope param) =>+  SomeEpc (EntrypointCallT param arg)++instance Eq (SomeEntrypointCallT arg) where+  SomeEpc epc1 == SomeEpc epc2 = isJust @() $ do+    Refl <- eqP (epcParamProxy epc1) (epcParamProxy epc2)+    guard (epc1 == epc2)++deriving stock instance Show (SomeEntrypointCallT arg)+instance NFData (SomeEntrypointCallT arg) where+  rnf (SomeEpc epc) = rnf epc++instance Buildable (SomeEntrypointCallT arg) where+  build (SomeEpc epc) = build epc++-- | Construct 'SomeEntrypointCallT' which calls no entrypoint and assumes that+-- there is no explicit "default" one.+--+-- Validity of such operation is not ensured.+sepcCallRootUnsafe :: ParameterScope param => SomeEntrypointCallT param+sepcCallRootUnsafe = SomeEpc epcCallRootUnsafe++-- | Call parameter which has no entrypoints, always safe.+sepcPrimitive+  :: forall t.+     (ParameterScope t, ForbidOr t)+  => SomeEntrypointCallT t+sepcPrimitive = SomeEpc epcPrimitive++sepcName :: SomeEntrypointCallT arg -> EpName+sepcName (SomeEpc epc) = epcName epc++-- | Build 'EpLiftSequence'.+--+-- Here we accept entrypoint name and type information for the parameter+-- of target contract.+--+-- Returns 'Nothing' if entrypoint is not found.+-- Does not treat default entrypoints specially.+withEpLiftSequence+  :: forall param r.+     (ParameterScope param)+  => EpName+  -> Notes param+  -> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)+  -> Maybe r+withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =+  case (sing @param, param) of+    (STOr lSing _, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->+      case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of+        (OpAbsent, NestedBigMapsAbsent) -> asum+          [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)+          , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)+          , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft)+          , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight)+          ]+    _ -> Nothing++-- Helper datatype for 'mkEntrypointCall'.+data MkEntrypointCallRes param where+  MkEntrypointCallRes+    :: ParameterScope arg+    => Notes arg+    -> EntrypointCallT param arg+    -> MkEntrypointCallRes param++-- | Build 'EntrypointCallT'.+--+-- Here we accept entrypoint name and type information for the parameter+-- of target contract.+--+-- Returns 'Nothing' if entrypoint is not found.+mkEntrypointCall+  :: (ParameterScope param)+  => EpName+  -> ParamNotes param+  -> Maybe (MkEntrypointCallRes param)+mkEntrypointCall epName (ParamNotes paramNotes root) =+  asum+  [ do+      epName' <- epNameFromParamAnn $ convAnn root+      guard (epName == epName')+      return $ MkEntrypointCallRes+        paramNotes+        EntrypointCall+          { epcName = epName+          , epcParamProxy = Proxy+          , epcLiftSequence = EplArgHere+          }+  , withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) ->+      MkEntrypointCallRes argInfo $ EntrypointCall+        { epcName = epName+        , epcParamProxy = Proxy+        , epcLiftSequence = liftSeq+        }+  , guard (epName == def) $>+      MkEntrypointCallRes paramNotes EntrypointCall+        { epcName = def+        , epcParamProxy = Proxy+        , epcLiftSequence = EplArgHere+        }+  ]++-- | "Parameter" type of implicit account.+tyImplicitAccountParam :: ParamNotes 'TUnit+tyImplicitAccountParam = ParamNotesUnsafe starNotes noAnn++-- Misc+----------------------------------------------------------------------------++-- | Flatten a provided list of notes to a map of its entrypoints and its+-- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how+-- duplicate entrypoints are handled.+flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName U.Type+flattenEntrypoints (pnNotes -> notes) = mkEntrypointsMap (mkUType notes)++-- TODO [#35]: Root annotation is currently support as a dedicated field+-- in 'ParamNotes'.+--+-- Also it would be nice to automatically add @%root@ annotation in each parameter+-- declaration when compiling Lorentz to Michelson.+-- In addition to this, we should actually use @%root@ annotation in the entrypoint engine+-- and not just store it.

@@ -30,6 +30,7 @@   , homomorphicTypeDocHaskellRep   , concreteTypeDocHaskellRep   , concreteTypeDocHaskellRepUnsafe+  , haskellAddNewtypeField   , haskellRepNoFields   , haskellRepStripFieldPrefix   , homomorphicTypeDocMichelsonRep@@ -64,7 +65,7 @@ import Michelson.Doc import Michelson.Text import Michelson.Typed.Aliases-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Haskell.ValidateDescription import Michelson.Typed.Haskell.Value import Michelson.Typed.T@@ -106,9 +107,11 @@ buildADTRep buildField = \case   ConstructorRep{..} :| [] -> renderProduct (WithinParens False) crFields   ps -> (mappend (mdItalic "one of" <> " \n")) $-        mconcat . map (("+ " <> ) . (<> "\n")) $-        map (renderNamedProduct (WithinParens True)) (toList ps)+        foldMap+        (toListItem . renderNamedProduct (WithinParens True)) (toList ps)   where+    toListItem item = "+ " <> item <> "\n"+     renderNamedProduct :: WithinParens -> ConstructorRep a -> Markdown     renderNamedProduct wp ConstructorRep{..} =       mdBold (build crName) <>@@ -314,8 +317,8 @@   DType a1 `compare` DType a2 = a1 `compareExt` a2  instance DocItem DType where-  type DocItemPosition DType = 5000   type DocItemPlacement DType = 'DocItemInDefinitions+  docItemPos = 5000    docItemSectionName = Just "Types" @@ -372,7 +375,7 @@   deriving stock Generic  instance DocItem DStorageType where-  type DocItemPosition DStorageType = 835+  docItemPos = 835   docItemSectionName = Just "Storage"   docItemToMarkdown lvl (DStorageType t) = docItemToMarkdown lvl t   docItemDependencies (DStorageType t) = docItemDependencies t@@ -512,6 +515,14 @@ haskellRepNoFields mkRep =   \p descr -> second (mapADTRepFields (const Nothing)) <$> mkRep p descr +-- | Add field name for @newtype@.+--+-- Since @newtype@ field is automatically erased. Use this function+-- to add the desired field name.+haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellAddNewtypeField fieldName mkRep =+  \p descr -> second (mapADTRepFields (const (Just fieldName))) <$> mkRep p descr+ -- | Cut fields prefixes which we use according to the style guide. -- -- E.g. @cmMyField@ field will be transformed to @myField@.@@ -572,8 +583,12 @@ class GTypeHasDoc (x :: Kind.Type -> Kind.Type) where   gTypeDocHaskellRep :: FieldDescriptionsV -> ADTRep SomeTypeWithDoc -instance GTypeHasDoc x => GTypeHasDoc (G.D1 i x) where+instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'False) x) where   gTypeDocHaskellRep = gTypeDocHaskellRep @x++instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'True) x) where+  gTypeDocHaskellRep descr =+    mapADTRepFields (const Nothing) $ gTypeDocHaskellRep @x descr  instance (GTypeHasDoc x, GTypeHasDoc y) => GTypeHasDoc (x :+: y) where   gTypeDocHaskellRep descr = gTypeDocHaskellRep @x descr <> gTypeDocHaskellRep @y descr

@@ -50,7 +50,7 @@ import Unsafe.Coerce (unsafeCoerce)  import Michelson.Text (MText, mt)-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Haskell.Instr.Helpers import Michelson.Typed.Haskell.Value import Michelson.Typed.Instr

@@ -22,8 +22,8 @@   , Dict(..) -- * Re-exporting to use in tests.      -- * Missing Haskell analogies to Michelson values-  , EntryPointCall-  , SomeEntryPointCall+  , EntrypointCall+  , SomeEntrypointCall   , ContractRef (..)   , coerceContractRef   , contractRefToAddr@@ -35,9 +35,6 @@   , IsoValuesStack (..)   , totsKnownLemma   , totsAppendLemma--    -- * Generators-  , genBigMap   ) where  import Data.Constraint ((:-)(..), Dict(..))@@ -49,15 +46,12 @@ import Fmt (Buildable(..)) import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G-import Hedgehog (MonadGen)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range import Named (NamedF(..)) import Test.QuickCheck (Arbitrary(..))  import Michelson.Text import Michelson.Typed.Aliases-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Sing import Michelson.Typed.T import Michelson.Typed.Value@@ -230,9 +224,9 @@ -- Types used specifically for conversion ---------------------------------------------------------------------------- -type EntryPointCall param arg = EntryPointCallT (ToT param) (ToT arg)+type EntrypointCall param arg = EntrypointCallT (ToT param) (ToT arg) -type SomeEntryPointCall arg = SomeEntryPointCallT (ToT arg)+type SomeEntrypointCall arg = SomeEntrypointCallT (ToT arg)  type WellTypedToT a = WellTyped (ToT a) type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)@@ -246,7 +240,7 @@ -- type argument. data ContractRef (arg :: Kind.Type) = ContractRef   { crAddress :: Address-  , crEntryPoint :: SomeEntryPointCall arg+  , crEntrypoint :: SomeEntrypointCall arg   } deriving stock (Eq, Show)  instance (WellTypedToT arg) => Buildable (ContractRef arg) where@@ -254,7 +248,7 @@  instance (WellTypedToT arg) => IsoValue (ContractRef arg) where   type ToT (ContractRef arg) = 'TContract (ToT arg)-  toVal ContractRef{..} = VContract crAddress crEntryPoint+  toVal ContractRef{..} = VContract crAddress crEntrypoint   fromVal (VContract addr epc) = ContractRef addr epc  -- | Replace type argument of 'ContractAddr' with isomorphic one.@@ -262,7 +256,7 @@ coerceContractRef ContractRef{..} = ContractRef{..}  contractRefToAddr :: ContractRef cp -> EpAddress-contractRefToAddr ContractRef{..} = EpAddress crAddress (sepcName crEntryPoint)+contractRefToAddr ContractRef{..} = EpAddress crAddress (sepcName crEntrypoint)  newtype BigMap k v = BigMap { unBigMap :: Map k v }   deriving stock (Eq, Show)@@ -282,12 +276,6 @@   ) => Arbitrary (BigMap k v) where   arbitrary = BigMap <$> arbitrary -genBigMap-  :: forall k v m.-     (MonadGen m, Ord k, WellTypedToT k, WellTypedToT v, Comparable (ToT k))-  => m k -> m v -> m (BigMap k v)-genBigMap genK genV = BigMap <$> Gen.map (Range.linear 0 100) (liftA2 (,) genK genV)- -- Generic magic ---------------------------------------------------------------------------- @@ -299,6 +287,9 @@ -- 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.+--+-- In case an unbalanced tree is needed, the Generic instance can be derived by+-- using the utilities in the 'Util.Generics' module. class KnownT (GValueType x) =>       GIsoValue (x :: Kind.Type -> Kind.Type) where   type GValueType x :: T

@@ -17,6 +17,7 @@   , ContractCode   , Contract (..)   , mapContractCode+  , mapEntriesOrdered   , pattern CAR   , pattern CDR   , pattern UNPAIR@@ -38,13 +39,13 @@ import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, needsParens, printDocS) import Michelson.Typed.Annotation (Notes(..)) import Michelson.Typed.Arith-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Polymorphic import Michelson.Typed.Scope import Michelson.Typed.Sing (KnownT) import Michelson.Typed.T (T(..)) import Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..))-import Michelson.Untyped (Annotation(..), FieldAnn, VarAnn)+import Michelson.Untyped (Annotation(..), EntriesOrder(..), FieldAnn, VarAnn, entriesOrderToInt) import Util.Peano import Util.TH import Util.Type (type (++), KnownList)@@ -316,7 +317,7 @@   SELF     :: forall (arg :: T) s .        (ParameterScope arg)-    => SomeEntryPointCallT arg+    => SomeEntrypointCallT arg     -> Instr s ('TContract arg ': s)   CONTRACT     :: (ParameterScope p)@@ -453,17 +454,36 @@   { cCode       :: ContractCode cp st   , cParamNotes :: ParamNotes cp   , cStoreNotes :: Notes st+  , cEntriesOrder :: EntriesOrder   }  deriving stock instance Show (Contract cp st) deriving stock instance Eq (ContractCode cp st) => Eq (Contract cp st) instance NFData (Contract cp st) where-  rnf (Contract a b c) = rnf (a, b, c)+  rnf (Contract a b c d) = rnf (a, b, c, d)  mapContractCode   :: (ContractCode cp st -> ContractCode cp st)   -> Contract cp st   -> Contract cp st mapContractCode f contract = contract { cCode = f $ cCode contract }++-- | Map each typed contract fields by the given function and sort the output+-- based on the 'EntriesOrder'.+mapEntriesOrdered+  :: Contract cp st+  -> (ParamNotes cp -> a)+  -> (Notes st -> a)+  -> (ContractCode cp st -> a)+  -> [a]+mapEntriesOrdered Contract{..} fParam fStorage fCode =+  fmap snd+    $ sortWith fst+        [ (paramPos, fParam cParamNotes)+        , (storagePos, fStorage cStoreNotes)+        , (codePos, fCode cCode)+        ]+  where+    (paramPos, storagePos, codePos) = entriesOrderToInt cEntriesOrder  $(deriveGADTNFData ''Instr)

@@ -22,9 +22,11 @@ import qualified Data.Set as S  import Michelson.Text+import Michelson.Typed.Annotation import Michelson.Typed.Sing (KnownT) import Michelson.Typed.T (T(..)) import Michelson.Typed.Value (Value'(..))+import Michelson.Untyped.Annotation (noAnn)  import Tezos.Core (divModMutez, divModMutezInt) @@ -174,6 +176,15 @@ class EDivOp (n :: T) (m :: T) where   type EDivOpRes n m :: T   type EModOpRes n m :: T++  -- | Converge the notes of given operands.+  convergeEDiv+    :: Notes n+    -> Notes m+    -> Either AnnConvergeError+        (Notes ('TOption ('TPair (EDivOpRes n m)+                                  (EModOpRes n m))))+   evalEDivOp     :: Value' instr n     -> Value' instr m@@ -183,6 +194,9 @@ instance EDivOp 'TInt 'TInt where   type EDivOpRes 'TInt 'TInt = 'TInt   type EModOpRes 'TInt 'TInt = 'TNat+  convergeEDiv n1 n2 =+    (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn a $ NTNat noAnn)+      <$> converge n1 n2   evalEDivOp (VInt i) (VInt j) =     if j == 0       then VOption $ Nothing@@ -191,6 +205,8 @@ instance EDivOp 'TInt 'TNat where   type EDivOpRes 'TInt 'TNat = 'TInt   type EModOpRes 'TInt 'TNat = 'TNat+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn n1+    $ NTNat noAnn   evalEDivOp (VInt i) (VNat j) =     if j == 0       then VOption $ Nothing@@ -199,6 +215,8 @@ instance EDivOp 'TNat 'TInt where   type EDivOpRes 'TNat 'TInt = 'TInt   type EModOpRes 'TNat 'TInt = 'TNat+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn+    (NTInt noAnn) n1   evalEDivOp (VNat i) (VInt j) =     if j == 0       then VOption $ Nothing@@ -207,6 +225,8 @@ instance EDivOp 'TNat 'TNat where   type EDivOpRes 'TNat 'TNat = 'TNat   type EModOpRes 'TNat 'TNat = 'TNat+  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn a a)+    <$> converge n1 n2   evalEDivOp (VNat i) (VNat j) =     if j == 0       then VOption $ Nothing@@ -215,6 +235,8 @@ instance EDivOp 'TMutez 'TMutez where   type EDivOpRes 'TMutez 'TMutez = 'TNat   type EModOpRes 'TMutez 'TMutez = 'TMutez+  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn (NTNat noAnn) a)+    <$> converge n1 n2   evalEDivOp (VMutez i) (VMutez j) =     VOption $     i `divModMutez` j <&> \case@@ -224,6 +246,7 @@ instance EDivOp 'TMutez 'TNat where   type EDivOpRes 'TMutez 'TNat = 'TMutez   type EModOpRes 'TMutez 'TNat = 'TMutez+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn n1 n1   evalEDivOp (VMutez i) (VNat j) =     VOption $     i `divModMutezInt` j <&> \case

@@ -7,6 +7,7 @@ module Michelson.Typed.Util   ( DfsSettings (..)   , CtorEffectsApp (..)+  , ceaBottomToTop   , dfsInstr   , dfsFoldInstr   , dfsModifyInstr@@ -105,12 +106,32 @@     LOOP_LEFT i1 -> recursion1 LOOP_LEFT i1     DIP i1 -> recursion1 DIP i1     DIPN s i1 -> recursion1 (DIPN s) i1-    PUSH v -> case v of-      VLam i1 | dsGoToValues ->-        -- Using 'analyzeInstrFailure' here (and in case below) is cheap-        -- (O(n) in total) because we never make it run over the same code twice-        recursion1 (PUSH . VLam . analyzeInstrFailure) (rfAnyInstr i1)-      _ -> step i++    -- This case is more complex so we duplicate @recursion1@ a bit.+    -- We have to traverse the pushed value because a lambda can be+    -- somewhere inside of it (e. g. one item of a pair).+    PUSH v -> fromMaybe (step i) do+        guard dsGoToValues+        let+          valueStep :: forall t . Value t -> (Value t, Maybe x)+          valueStep = \case+            -- Using 'analyzeInstrFailure' here (and in case below) is cheap+            -- (O(n) in total) because we never make it run over the same code twice+            VLam lambda -> bimap (VLam . analyzeInstrFailure) Just $+              dfsInstr settings step (rfAnyInstr lambda)+            otherV -> (otherV, Nothing)+        -- Note that @dfsValue@ does not respect 'CtorEffectsApp',+        -- so if we encounter a value that contains more than one lambda+        -- this function may misbehave.+        -- That's very unlikely in practice.+        -- In #264 we will support this feature in @dfsValue@.+        let+          (innerV, innerXMaybe) = dfsValue valueStep v++        innerX <- innerXMaybe+        let (outerI, outerX) = step $ PUSH innerV+        pure $ ceaApplyEffects dsCtorEffectsApp innerX outerX outerI+     LAMBDA (VLam i1)       | dsGoToValues ->           recursion1 (LAMBDA . VLam . analyzeInstrFailure) (rfAnyInstr i1)

@@ -45,7 +45,7 @@ import qualified Data.Kind as Kind  import Michelson.Text (MText)-import Michelson.Typed.EntryPoints+import Michelson.Typed.Entrypoints import Michelson.Typed.Sing import Michelson.Typed.Scope (BadTypeForScope(..), CheckScope(..), ParameterScope, StorageScope) import Michelson.Typed.T (T(..))@@ -340,7 +340,7 @@     :: Operation' instr -> Value' instr 'TOperation   VContract     :: forall arg instr.-       Address -> SomeEntryPointCallT arg -> Value' instr ('TContract arg)+       Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)   VPair     :: forall l r instr.        (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)@@ -423,7 +423,7 @@  -- | Lift entrypoint argument to full parameter. liftCallArg-  :: EntryPointCallT param arg+  :: EntrypointCallT param arg   -> Value' instr arg   -> Value' instr param liftCallArg epc = compileEpLiftSequence (epcLiftSequence epc)@@ -447,7 +447,7 @@   VList{} -> Dict   VSet{} -> Dict   VOp{} -> Dict-  VContract _ (SomeEpc EntryPointCall{}) -> Dict+  VContract _ (SomeEpc EntrypointCall{}) -> Dict   VPair (l, r) -> case (valueTypeSanity l, valueTypeSanity r) of     (Dict, Dict) -> Dict   VOr{} -> Dict

@@ -9,7 +9,7 @@ import Michelson.Untyped.Aliases as Exports import Michelson.Untyped.Annotation as Exports import Michelson.Untyped.Contract as Exports-import Michelson.Untyped.EntryPoints as Exports+import Michelson.Untyped.Entrypoints as Exports import Michelson.Untyped.Ext as Exports import Michelson.Untyped.Instr as Exports import Michelson.Untyped.Type as Exports

@@ -5,36 +5,123 @@ -- | Michelson contract in untyped model.  module Michelson.Untyped.Contract-  ( Storage+  ( EntriesOrder (..)+  , canonicalEntriesOrder+  , entriesOrderToInt+  , mapEntriesOrdered++  , ContractBlock (..)+  , orderContractBlock+   , Contract' (..)+  , Storage   ) where  import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..))-import Formatting.Buildable (Buildable(build))-import Text.PrettyPrint.Leijen.Text (nest, semi, (<$$>), (<+>))+import Data.Default (Default(..))+import Fmt (Buildable(build))+import Text.PrettyPrint.Leijen.Text (nest, semi, text, (<$$>), (<+>))  import Michelson.Printer.Util   (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList) import Michelson.Untyped.Type (ParameterType(..), Type(..)) import Util.Aeson +-- | Top-level entries order of the contract.+-- This is preserved due to the fact that it affects+-- the output of pretty-printing and serializing contract.++-- Each constructors is created by the order of the first letter of+-- @parameter@, @storage@, and @code@.+--+-- For example, @PSC@ would be @parameter@, @storage@ and @code@,+-- @CPS@ would be @code@, @parameter@,and @storage@, and so on.+data EntriesOrder+  = PSC+  | PCS+  | SPC+  | SCP+  | CSP+  | CPS+  deriving stock (Bounded, Data, Enum, Eq, Generic, Show)++instance Default EntriesOrder where+  def = canonicalEntriesOrder+instance NFData EntriesOrder++-- | The canonical entries order which is ordered as follow:+-- @parameter@, @storage@, and @code@.+canonicalEntriesOrder :: EntriesOrder+canonicalEntriesOrder = PSC++-- | @(Int, Int, Int)@ is the positions of @parameter@, @storage@, and @code@+-- respectively.+entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)+entriesOrderToInt = \case+  PSC -> (0, 1, 2)+  PCS -> (0, 2, 1)+  SPC -> (1, 0, 2)+  SCP -> (1, 2, 0)+  CSP -> (2, 1, 0)+  CPS -> (2, 0, 1)++-- | Contract block, convenient when parsing+data ContractBlock op+  = CBParam ParameterType+  | CBStorage Type+  | CBCode [op]+  deriving stock (Eq, Show)++orderContractBlock :: (ContractBlock op, ContractBlock op, ContractBlock op) -> Maybe (Contract' op)+orderContractBlock = \case+  (CBParam   p, CBStorage s, CBCode    c) -> Just $ Contract p s c PSC+  (CBParam   p, CBCode    c, CBStorage s) -> Just $ Contract p s c PCS+  (CBStorage s, CBParam   p, CBCode    c) -> Just $ Contract p s c SPC+  (CBStorage s, CBCode    c, CBParam   p) -> Just $ Contract p s c SCP+  (CBCode    c, CBStorage s, CBParam   p) -> Just $ Contract p s c CSP+  (CBCode    c, CBParam   p, CBStorage s) -> Just $ Contract p s c CPS+  _                                       -> Nothing++-- | Map each contract fields by the given function and sort the output+-- based on the 'EntriesOrder'.+mapEntriesOrdered+  :: Contract' op+  -> (ParameterType -> a)+  -> (Storage -> a)+  -> ([op] -> a)+  -> [a]+mapEntriesOrdered Contract{..} fParam fStorage fCode =+  fmap snd+    $ sortWith fst+        [ (paramPos, fParam contractParameter)+        , (storagePos, fStorage contractStorage)+        , (codePos, fCode contractCode)+        ]+  where+    (paramPos, storagePos, codePos) = entriesOrderToInt entriesOrder+ type Storage = Type data Contract' op = Contract   { contractParameter :: ParameterType   , contractStorage :: Storage   , contractCode :: [op]+  , entriesOrder :: EntriesOrder   } deriving stock (Eq, Show, Functor, Data, Generic)  instance NFData op => NFData (Contract' op)  instance (RenderDoc op) => RenderDoc (Contract' op) where-  renderDoc pn (Contract parameter storage code) = assertParensNotNeeded pn $-    "parameter" <+> renderDoc needsParens (Prettier parameter)  <> semi <$$>-    "storage"   <+> renderDoc needsParens (Prettier storage)    <> semi <$$>-    "code"      <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi)+  renderDoc pn contract =+    assertParensNotNeeded pn+      $ foldr (<$$>) (text "")+      $ mapEntriesOrdered contract+        (\parameter -> "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi)+        (\storage -> "storage" <+> renderDoc needsParens (Prettier storage) <> semi)+        (\code -> "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi))  instance RenderDoc op => Buildable (Contract' op) where   build = buildRenderDoc +deriveJSON morleyAesonOptions ''EntriesOrder deriveJSON morleyAesonOptions ''Contract'