morley 0.6.0 → 0.7.0

raw patch · 86 files changed

+3158/−1894 lines, 86 filesdep +tasty-hunit-compatdep −tasty-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit-compat

Dependencies removed: tasty-hunit

API changes (from Hackage documentation)

Files

• CHANGES.md +32/−0
• README.md +1/−1
• morley.cabal +12/−4
• src/Lorentz.hs +2/−0
• src/Lorentz/Base.hs +24/−0
• src/Lorentz/Coercions.hs +9/−12
• src/Lorentz/Constraints/Derivative.hs +1/−2
• src/Lorentz/ContractRegistry.hs +109/−0
• src/Lorentz/Doc.hs +1/−1
• src/Lorentz/Empty.hs +51/−0
• src/Lorentz/EntryPoints.hs +9/−1
• src/Lorentz/EntryPoints/Core.hs +74/−20
• src/Lorentz/EntryPoints/Doc.hs +167/−37
• src/Lorentz/EntryPoints/Helpers.hs +20/−19
• src/Lorentz/EntryPoints/Impl.hs +148/−103
• src/Lorentz/EntryPoints/Manual.hs +1/−1
• src/Lorentz/Errors.hs +1/−1
• src/Lorentz/Errors/Numeric.hs +42/−7
• src/Lorentz/Instr.hs +43/−21
• src/Lorentz/Macro.hs +20/−21
• src/Lorentz/Rebinded.hs +119/−19
• src/Lorentz/Referenced.hs +1/−1
• src/Lorentz/Run.hs +34/−7
• src/Lorentz/Test.hs +5/−1
• src/Lorentz/Test/Integrational.hs +56/−37
• src/Lorentz/Test/Unit.hs +28/−0
• src/Lorentz/UParam.hs +12/−10
• src/Lorentz/UStore/Haskell.hs +5/−4
• src/Lorentz/UStore/Instr.hs +1/−1
• src/Lorentz/UStore/Migration/Base.hs +0/−1
• src/Lorentz/UStore/Types.hs +30/−10
• src/Lorentz/Value.hs +125/−35
• src/Lorentz/Zip.hs +0/−9
• src/Michelson/Doc/Test.hs +30/−1
• src/Michelson/FailPattern.hs +18/−10
• src/Michelson/Interpret.hs +5/−4
• src/Michelson/Interpret/Pack.hs +77/−47
• src/Michelson/Interpret/Unpack.hs +22/−12
• src/Michelson/Macro.hs +44/−41
• src/Michelson/Parser.hs +3/−0
• src/Michelson/Parser/Error.hs +2/−0
• src/Michelson/Parser/Ext.hs +5/−5
• src/Michelson/Parser/Helpers.hs +2/−2
• src/Michelson/Parser/Instr.hs +65/−73
• src/Michelson/Parser/Lexer.hs +9/−1
• src/Michelson/Parser/Macro.hs +22/−23
• src/Michelson/Parser/Type.hs +62/−52
• src/Michelson/Parser/Value.hs +13/−21
• src/Michelson/Printer/Util.hs +6/−1
• src/Michelson/Test.hs +1/−0
• src/Michelson/Test/Import.hs +2/−1
• src/Michelson/Test/Integrational.hs +29/−15
• src/Michelson/Test/Unit.hs +6/−2
• src/Michelson/Test/Util.hs +6/−4
• src/Michelson/Text.hs +1/−1
• src/Michelson/TypeCheck/Error.hs +23/−22
• src/Michelson/TypeCheck/Helpers.hs +45/−39
• src/Michelson/TypeCheck/Instr.hs +600/−626
• src/Michelson/TypeCheck/TypeCheck.hs +10/−3
• src/Michelson/TypeCheck/Value.hs +137/−155
• src/Michelson/Typed/Annotation.hs +30/−29
• src/Michelson/Typed/Arith.hs +11/−15
• src/Michelson/Typed/Convert.hs +223/−122
• src/Michelson/Typed/EntryPoints.hs +46/−11
• src/Michelson/Typed/Haskell/Doc.hs +11/−1
• src/Michelson/Typed/Haskell/Value.hs +9/−0
• src/Michelson/Typed/Instr.hs +4/−1
• src/Michelson/Typed/Scope.hs +97/−7
• src/Michelson/Typed/Sing.hs +67/−64
• src/Michelson/Typed/Util.hs +6/−0
• src/Michelson/Typed/Value.hs +2/−3
• src/Michelson/Untyped/Ext.hs +5/−4
• src/Tezos/Crypto/Ed25519.hs +8/−0
• src/Util/ByteString.hs +20/−0
• src/Util/Exception.hs +15/−0
• src/Util/Fcf.hs +8/−1
• src/Util/Lens.hs +1/−5
• src/Util/Type.hs +30/−6
• test/Test/Ext.hs +2/−2
• test/Test/Interpreter.hs +9/−10
• test/Test/Lorentz/Conditionals.hs +28/−0
• test/Test/Lorentz/EntryPoints.hs +47/−12
• test/Test/Lorentz/Pack.hs +43/−0
• test/Test/Parser.hs +7/−0
• test/Test/Serialization/Michelson.hs +1/−2
• test/Test/Tasty/HUnit.hs +0/−52

@@ -1,5 +1,37 @@ Unreleased ==========+<!-- Append new entries here -->++0.7.0+=====++* [!237](https://gitlab.com/morley-framework/morley/merge_requests/237)+  The `option (nat %foo)` is now accepted syntax. The `%foo` is ignored.+* [!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,+    for previous behaviour with nice error message use+    `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.+  + Added pseudo `Empty` type.+* [!219](https://gitlab.com/morley-framework/morley/merge_requests/219)+  Various entrypoints-related updates.+  + Integrational tests now carry `TAddress` as a reference to contract.+    Make sure that parameters of the originated contracts are clear;+    e.g. origination of `consumer` contract may require explicit type+    annotation to specify parameter type.+    If you passed a reference to the originated contract to `View` constructor,+    consider using `mkView` instead or applying `callingDefTAddress` to the+    reference.+  + 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+     one of explicit versions: `epcPrimitive`, `epcCallRootUnsafe`.+  + Reworked `FutureContract` type.  0.6.0 =====

@@ -33,7 +33,7 @@ Workflow is the following:  1. If your contract is called `foo.mtz`, use `morley print --contract foo.mtz --output foo.tz`. Note that normally you should not use `morley` directly, you should use `morley.sh` or `stack exec -- morley`. See usage instructions below.-2. After that, you can use existing Tezos tools to deploy your contract. You can also typecheck or interpret it using a reference implementation. If you are not familiar with the Tezos tooling, please read [Tezos documentation](http://tezos.gitlab.io/zeronet/index.html) or [Michelson tutorial](https://gitlab.com/morley-framework/michelson-tutorial).+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: Lorentz EDSL 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 25e54f1a413ad3939b12a42f0d567c222976bcba8316ef34c07ddaa0a477d608+-- hash: 33cc1385806c0bba34d30ab3ced63fed49ed649195dbcaa6e240edf9cbe6cd01  name:           morley-version:        0.6.0+version:        0.7.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@@ -39,7 +39,9 @@       Lorentz.Constraints       Lorentz.Constraints.Derivative       Lorentz.Constraints.Scopes+      Lorentz.ContractRegistry       Lorentz.Doc+      Lorentz.Empty       Lorentz.EntryPoints       Lorentz.EntryPoints.Core       Lorentz.EntryPoints.Doc@@ -66,6 +68,7 @@       Lorentz.Test.Consumer       Lorentz.Test.Doc       Lorentz.Test.Integrational+      Lorentz.Test.Unit       Lorentz.TestScenario       Lorentz.TypeAnns       Lorentz.UParam@@ -171,7 +174,9 @@       Tezos.Crypto.Secp256k1       Tezos.Crypto.Util       Util.Alternative+      Util.ByteString       Util.Default+      Util.Exception       Util.Fcf       Util.Generic       Util.Instances@@ -227,6 +232,7 @@     , morley-prelude >=0.3.0     , mtl     , named+    , optparse-applicative     , parser-combinators >=1.0.0     , pretty-terminal     , quickcheck-arbitrary-adt@@ -236,7 +242,7 @@     , syb     , tasty     , tasty-ant-xml-    , tasty-hunit+    , tasty-hunit-compat     , template-haskell     , text     , th-lift@@ -291,11 +297,13 @@       Test.Interpreter.EnvironmentSpec       Test.Interpreter.StringCaller       Test.Lorentz.Base+      Test.Lorentz.Conditionals       Test.Lorentz.DeadCode       Test.Lorentz.EntryPoints       Test.Lorentz.Errors       Test.Lorentz.Extensible       Test.Lorentz.Macro+      Test.Lorentz.Pack       Test.Lorentz.Print       Test.Lorentz.UParam       Test.Lorentz.UStore.Behaviour@@ -319,7 +327,6 @@       Test.Printer.Michelson       Test.Serialization.Aeson       Test.Serialization.Michelson-      Test.Tasty.HUnit       Test.Tasty.TypeSpec       Test.Tezos.Address       Test.Tezos.Core@@ -371,6 +378,7 @@     , syb     , tasty     , tasty-hspec+    , tasty-hunit-compat     , tasty-quickcheck     , text     , type-spec

@@ -9,6 +9,7 @@ import Lorentz.Common as Exports import Lorentz.Constraints as Exports import Lorentz.Doc as Exports+import Lorentz.Empty as Exports import Lorentz.EntryPoints as Exports import Lorentz.EntryPoints.Doc as Exports import Lorentz.Errors as Exports@@ -25,6 +26,7 @@ import Lorentz.Referenced as Exports import Lorentz.Run as Exports import Lorentz.StoreClass as Exports+import Lorentz.TypeAnns as Exports import Lorentz.UParam as Exports import Lorentz.UStore as Exports import Lorentz.Value as Exports

@@ -6,12 +6,15 @@   , type (%>)   , type (&)   , (#)+  , (##)   , pattern I   , pattern FI   , iGenericIf   , iAnyCode   , iNonFailingCode   , iMapAnyCode+  , iForceNotFail+  , iWithVarAnnotations    , parseLorentzValue   , transformStringsLorentz@@ -27,6 +30,7 @@  import Data.Default (def) import qualified Data.Kind as Kind+import qualified Data.List.NonEmpty as NE (fromList) import Data.Singletons (SingI(..)) import Fmt (Buildable(..)) @@ -79,6 +83,18 @@   -> (i2 :-> o) iMapAnyCode f (LorentzInstr i) = LorentzInstr $ rfMapAnyInstr f i +iForceNotFail :: (i :-> o) -> (i :-> o)+iForceNotFail = I . iAnyCode++-- | Wrap Lorentz instruction with variable annotations, @annots@ list has to be+-- non-empty, otherwise this function raises an error.+iWithVarAnnotations :: HasCallStack => [Text] -> inp :-> out -> inp :-> out+iWithVarAnnotations annots (LorentzInstr i) = case i of+  RfNormal instr -> LorentzInstr $ RfNormal $+    InstrWithVarNotes (NE.fromList $ map U.AnnotationUnsafe annots) instr+  RfAlwaysFails instr -> LorentzInstr $ RfAlwaysFails $+    InstrWithVarNotes (NE.fromList $ map U.AnnotationUnsafe annots) instr+ -- There is also @instance IsoValue (i :-> o)@ in a separate module.  -- | Alias for ':->', seems to make signatures more readable sometimes.@@ -104,6 +120,14 @@ I l # FI r = FI (l `Seq` r) FI l # _ = FI l infixl 8 #++-- | Version of '#' which performs some optimizations immediately.+(##) :: (a :-> b) -> (b :-> c) -> (a :-> c)+l ## r = case (l, r) of+  (I Nop, I x) -> I x+  (I x, I Nop) -> I x+  _ -> l # r+  type Lambda i o = '[i] :-> '[o] 

@@ -19,10 +19,7 @@   , forcedCoerce_   , gForcedCoerce_   , fakeCoerce--    -- * Coercions for some basic types-  , futureContract-  , unFutureContract+  , fakeCoercing      -- * Re-exports   , Wrapped (..)@@ -76,6 +73,9 @@ fakeCoerce :: s1 :-> s2 fakeCoerce = unit # I FAILWITH +fakeCoercing :: (s1 :-> s2) -> s1' :-> s2'+fakeCoercing i = fakeCoerce # iForceNotFail i # fakeCoerce+ ---------------------------------------------------------------------------- -- Safe coercions ----------------------------------------------------------------------------@@ -134,6 +134,8 @@   -- That's magic, having default impl for 'castDummy' disables   -- -Wredundant-constraints automatically +instance CanCastTo a b => CanCastTo (Maybe a) (Maybe b)+ -- | Coercion from @a@ to @b@ is permitted and safe. type Castable_ a b = (MichelsonCoercible a b, CanCastTo a b) @@ -188,12 +190,7 @@ -- Coercions for some basic types ---------------------------------------------------------------------------- --- | Make up a 'FutureContract'.-futureContract :: Address : s :-> FutureContract p : s-futureContract = forcedCoerce_---- | Get address referred by 'FutureContract'.-unFutureContract :: FutureContract p : s :-> Address : s-unFutureContract = forcedCoerce_+instance TAddress p `CanCastTo` Address+instance Address `CanCastTo` TAddress p -instance FutureContract p `CanCastTo` Address+instance FutureContract p `CanCastTo` EpAddress

@@ -6,8 +6,7 @@   ( NiceParameterFull   ) where -import Lorentz.Constraints.Scopes import Lorentz.EntryPoints.Core  -- | Constraint applied to a whole parameter type.-type NiceParameterFull cp = (NiceParameter cp, ParameterDeclaresEntryPoints cp)+type NiceParameterFull cp = (Typeable cp, ParameterDeclaresEntryPoints cp)

@@ -0,0 +1,109 @@+-- | This module contains various datatypes and functions which are+-- common for contract registry packages (e.g. morley-ledgers and morley-multisig).+module Lorentz.ContractRegistry+  ( ContractInfo (..)+  , ContractRegistry (..)+  , getContract+  , printContractFromRegistryDoc+  , (?::)+  -- Common CLI stuff+  , CmdLnArgs (..)+  , argParser+  ) where++import qualified Data.Map as Map+import qualified Data.Text.Lazy.IO as TL+import Fmt (Buildable(..), blockListF, nameF, (+|), (|+))+import qualified Options.Applicative as Opt++import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Doc+import Util.IO++data ContractInfo =+  forall cp st.+    (NiceParameterFull cp, NiceStorage st) =>+  ContractInfo+  { ciContract :: Contract cp st+  , ciIsDocumented :: Bool+  }++(?::) :: Text -> a -> (Text, a)+(?::) = (,)++newtype ContractRegistry = ContractRegistry+  { unContractRegistry :: Map Text ContractInfo }++getContract :: Text -> ContractRegistry -> Either String ContractInfo+getContract name registry =+  case Map.lookup name (unContractRegistry registry) of+    Nothing ->+      Left $ "No contract with name '" +| name |+ "' found\n" +| registry |+ ""+    Just c -> Right c++instance Buildable ContractRegistry where+  build registry =+    nameF "Available contracts" (blockListF $ keys (unContractRegistry registry))++printContractFromRegistryDoc :: Text -> ContractRegistry -> Maybe FilePath -> IO ()+printContractFromRegistryDoc name contracts mOutput = do+  ContractInfo{..} <- either die pure $ getContract name contracts+  let writeFunc = case mOutput of+        Nothing -> TL.putStrLn+        Just "def" -> writeFileUtf8 $ toString name <> ".md"+        Just output -> writeFileUtf8 output+  if ciIsDocumented+  then writeFunc $ contractDocToMarkdown $ buildLorentzDoc ciContract+  else die "This contract is not documented"++data CmdLnArgs+  = List+  | Print Text (Maybe FilePath) Bool+  | Document Text (Maybe FilePath)++argParser :: Opt.Parser CmdLnArgs+argParser = Opt.subparser $ mconcat+  [ listSubCmd+  , printSubCmd+  , documentSubCmd+  ]+  where+    mkCommandParser commandName parser desc =+      Opt.command commandName $+      Opt.info (Opt.helper <*> parser) $+      Opt.progDesc desc++    listSubCmd =+      mkCommandParser "list"+      (pure List)+      "Show all available contracts"++    printSubCmd =+      mkCommandParser "print"+      (Print <$> printOptions <*> outputOptions <*> onelineOption)+      "Dump a contract in form of Michelson code"++    documentSubCmd =+      mkCommandParser "document"+      (Document <$> printOptions <*> outputOptions)+      "Dump contract documentation in Markdown"++    printOptions = Opt.strOption $ mconcat+      [ Opt.short 'n'+      , Opt.long "name"+      , Opt.metavar "IDENTIFIER"+      , Opt.help "Name of a contract returned by `list` command."+      ]++    outputOptions = optional . Opt.strOption $ mconcat+      [ Opt.short 'o'+      , Opt.long "output"+      , Opt.metavar "FILEPATH"+      , Opt.help "File to use as output. If not specified, stdout is used."+      ]++    onelineOption :: Opt.Parser Bool+    onelineOption = Opt.switch (+      Opt.long "oneline" <>+      Opt.help "Force single line output")

@@ -68,7 +68,7 @@ doc = I . Ext . DOC_ITEM . SomeDocItem  -- | Group documentation built in the given piece of code--- into block dedicated to one thing, e.g. to one entry point.+-- into block dedicated to one thing, e.g. to one entrypoint. docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out) docGroup gr = iMapAnyCode (DocGroup gr) 

@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Support for uninhabited type.+--+-- Currently they are not supported my Michelson, so we provide+-- a sort of replacement.+--+-- This module should be removed once the proposal is implemented:+-- https://gitlab.com/tezos/tezos/issues/662+module Lorentz.Empty+  ( Empty+  , absurd_+  ) where++import Fmt (Buildable(..))++import Lorentz.Base+import Lorentz.Doc+import Lorentz.Errors+import Lorentz.Value+import Michelson.Typed.Haskell.Doc++-- | Replacement for uninhabited type.+newtype Empty = Empty ()+  deriving stock Generic+  deriving anyclass IsoValue++instance TypeHasDoc Empty where+  typeDocMdDescription =+    "Type which should never be constructed.\n\n\+    \If appears as part of entrypoint argument, this means that the entrypoint \+    \should never be called."++-- | Someone constructed 'Empty' type.+type instance ErrorArg "emptySupplied" = ()++instance Buildable (CustomError "emptySupplied") where+  build (CustomError _ ()) =+    "'Empty' value was passed to the contract."++instance CustomErrorHasDoc "emptySupplied" where+  customErrClass = ErrClassBadArgument+  customErrDocMdCause =+    "Value of type " <> typeDocMdReference (Proxy @Empty) (WithinParens False)+    <> " has been supplied."++-- | Witness of that this code is unreachable.+absurd_ :: Empty : s :-> s'+absurd_ =+  failCustom_ #emptySupplied #+  doc (DDescription "Should never be called")

@@ -17,7 +17,9 @@   , parameterEntryPointCall   , GetDefaultEntryPointArg   , parameterEntryPointCallDefault+  , ForbidExplicitDefaultEntryPoint   , NoExplicitDefaultEntryPoint+  , sepcCallRootChecked   , EntryPointRef (..)   , eprName   , GetEntryPointArgCustom@@ -25,14 +27,20 @@   , HasDefEntryPointArg   , TrustEpName (..)   , parameterEntryPointCallCustom+  , RequireAllUniqueEntryPoints      -- * Implementations-  , ParameterWrapper (..)   , EpdNone   , EpdPlain   , EpdRecursive+  , EpdDelegate++    -- * Behaviour modifiers+  , ParameterWrapper (..)+  , ShouldHaveEntryPoints (..)   ) where  import Lorentz.EntryPoints.Core+import Lorentz.EntryPoints.Helpers import Lorentz.EntryPoints.Impl import Lorentz.EntryPoints.Manual

@@ -2,10 +2,15 @@  -- | Primitives supplying entrypoints declarations and lookup. module Lorentz.EntryPoints.Core-  ( EntryPointsDerivation (..)+  ( CanHaveEntryPoints+  , EntryPointsDerivation (..)   , EpConstructionRes (..)+  , RequireAllUniqueEntryPoints   , ParameterHasEntryPoints (..)   , ParameterDeclaresEntryPoints+  , GetParameterEpDerivation+  , pepNotes+  , pepCall   , AllParameterEntryPoints   , LookupParameterEntryPoint   , parameterEntryPointsToNotes@@ -14,8 +19,11 @@   , GetDefaultEntryPointArg   , parameterEntryPointCallDefault   , flattenEntryPoints+  , ForbidExplicitDefaultEntryPoint   , NoExplicitDefaultEntryPoint+  , sepcCallRootChecked   , EntryPointRef (..)+  , NiceEntryPointName   , eprName   , GetEntryPointArgCustom   , TrustEpName (..)@@ -25,13 +33,14 @@   , EpdNone      -- * Internals-  , RequireAllUniqueEntryPoints+  , RequireAllUniqueEntryPoints'   ) where  import Data.Constraint (Dict(..), (\\)) import qualified Data.Kind as Kind import Data.Map (Map, insert) import Data.Singletons (SingI, sing)+import Data.Typeable (typeRep) import Data.Vinyl.Derived (Label) import Fcf (Eval, Exp) import qualified Fcf@@ -51,7 +60,8 @@ -- When defining instances of this typeclass, set concrete @deriv@ argument -- and leave variable @cp@ argument. -- Also keep in mind, that in presence of explicit default entrypoint, all other--- 'Or' arms should be callable.+-- 'Or' arms should be callable, though you can put this burden on user if very+-- necessary. class EntryPointsDerivation deriv cp where   -- | Name and argument of each entrypoint.   -- This may include intermediate ones, even root if necessary.@@ -66,6 +76,8 @@   --   -- This method is implementation detail, for actual notes construction   -- use 'parameterEntryPointsToNotes'.+  --+  -- TODO [#35]: Should also return field annotation   epdNotes :: Notes (ToT cp)    -- | Construct entrypoint caller.@@ -79,12 +91,15 @@     => Label name     -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name)) --- | Ensure that all declared entrypoints are unique.-type RequireAllUniqueEntryPoints deriv cp =+type RequireAllUniqueEntryPoints' deriv cp =   RequireAllUnique     "entrypoint name"     (Eval (Fcf.Map Fcf.Fst $ EpdAllEntryPoints deriv cp)) +-- | Ensure that all declared entrypoints are unique.+type RequireAllUniqueEntryPoints cp =+  RequireAllUniqueEntryPoints' (ParameterEntryPointsDerivation cp) cp+ -- | Result of entrypoint lookup at term level. data EpConstructionRes (param :: T) (marg :: Maybe Kind.Type) where   EpConstructed@@ -98,7 +113,7 @@ -- Note that usually this function should not be used as constraint, use -- 'ParameterDeclaresEntryPoints' for this purpose. class ( EntryPointsDerivation (ParameterEntryPointsDerivation cp) cp-      , RequireAllUniqueEntryPoints (ParameterEntryPointsDerivation cp) cp+      , RequireAllUniqueEntryPoints cp       ) =>       ParameterHasEntryPoints cp where   type ParameterEntryPointsDerivation cp :: Kind.Type@@ -126,6 +141,24 @@      (ParameterEntryPointsDerivation cp)      EpdNone +-- | Version of 'epdNotes' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepNotes :: forall cp. ParameterDeclaresEntryPoints cp => Notes (ToT cp)+pepNotes = epdNotes @(GetParameterEpDerivation cp) @cp++-- | Version of 'epdCall' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepCall+  :: forall cp name deriv.+     ( ParameterDeclaresEntryPoints cp, ParameterScope (ToT cp)+     , KnownSymbol name, deriv ~ GetParameterEpDerivation cp+     )+  => Label name+  -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))+pepCall = epdCall @(GetParameterEpDerivation cp) @cp+ -- Derived methods and type families ---------------------------------------------------------------------------- @@ -138,28 +171,31 @@ -- | Lookup for entrypoint type by name. -- -- Does not treat default entrypoints in a special way.-type family LookupParameterEntryPoint (cp :: Kind.Type) (name :: Symbol)-             :: Exp (Maybe Kind.Type) where-  LookupParameterEntryPoint cp name =-    EpdLookupEntryPoint (GetParameterEpDerivation cp) cp name+type family LookupParameterEntryPoint (cp :: Kind.Type)+             :: Symbol -> Exp (Maybe Kind.Type) where+  LookupParameterEntryPoint cp =+    EpdLookupEntryPoint (GetParameterEpDerivation cp) cp  -- | Derive annotations for given parameter. parameterEntryPointsToNotes   :: forall cp.-     ParameterDeclaresEntryPoints cp+     (Typeable cp, ParameterDeclaresEntryPoints cp)   => ParamNotes (ToT cp) parameterEntryPointsToNotes =-  let notes = epdNotes @(GetParameterEpDerivation cp) @cp+  let notes = pepNotes @cp   in case mkParamNotes notes of        -- Normally this should be valid because        -- 1. Constraint in superclass of 'ParameterHasEntryPoints' ensures that        -- no entrypoint is duplicated.        -- 2. Each entrypoint is callable by laws of 'EntryPointsDerivation'.        Right n -> n-       Left e -> error $-        "Lorentz unexpectedly compiled into contract with \-        \illegal parameter declaration: " <> show notes <> "\n" <>-        "Reason: " <> pretty e+       Left e -> error $ mconcat+        [ "Lorentz unexpectedly compiled into contract with \+          \illegal parameter declaration.\n"+        , "Parameter: " <> show (typeRep (Proxy @cp)) <> "\n"+        , "Derived annotations: " <> show notes <> "\n"+        , "Failure reason: " <> pretty e+        ]  -- | Prepare call to given entrypoint. --@@ -174,7 +210,7 @@   -> EntryPointCall cp (GetEntryPointArg cp name) parameterEntryPointCall label =   withDict (niceParameterEvi @cp) $-  case epdCall @(GetParameterEpDerivation cp) @cp label of+  case pepCall @cp label of     EpConstructed liftSeq -> EntryPointCall       { epcName = epNameFromParamAnn (ctorNameToAnn @name)                ?: error "Empty constructor-entrypoint name"@@ -203,7 +239,7 @@   => EntryPointCall cp (GetDefaultEntryPointArg cp) parameterEntryPointCallDefault =   withDict (niceParameterEvi @cp) $-  case epdCall @(GetParameterEpDerivation cp) @cp (fromLabel @DefaultEpName) of+  case pepCall @cp (fromLabel @DefaultEpName) of     EpConstructed liftSeq -> EntryPointCall       { epcName = DefEpName       , epcParamProxy = Proxy@@ -225,7 +261,7 @@   )  -- | Ensure that there is no explicit "default" entrypoint.-type NoExplicitDefaultEntryPoint cp = Eval+type ForbidExplicitDefaultEntryPoint cp = Eval   (Fcf.LiftM3       Fcf.UnMaybe       (Fcf.Pure (Fcf.Pure (() :: Constraint)))@@ -237,6 +273,21 @@       (LookupParameterEntryPoint cp DefaultEpName)   ) +-- | Similar to 'ForbidExplicitDefaultEntryPoint', but in a version which+-- the compiler can work with (and which produces errors confusing for users :/)+type NoExplicitDefaultEntryPoint cp =+  Eval (LookupParameterEntryPoint cp DefaultEpName) ~ 'Nothing++-- | Call root entrypoint safely.+sepcCallRootChecked+  :: forall cp.+     (NiceParameter cp, ForbidExplicitDefaultEntryPoint cp)+  => SomeEntryPointCall cp+sepcCallRootChecked = sepcCallRootUnsafe \\ niceParameterEvi @cp+  where+    -- Avoiding redundant-constraints warning.+    _validUsage = Dict @(ForbidExplicitDefaultEntryPoint cp)+ -- | Which entrypoint to call. -- -- We intentionally distinguish default and non-default cases because@@ -252,7 +303,10 @@   -- entrypoints begin from capital letter (being derived from constructor name),   -- while labels must start from a lower-case letter, and there is no way to   -- make a conversion at type-level.-  Call :: (KnownSymbol name, ForbidDefaultName name) => EntryPointRef ('Just name)+  Call :: NiceEntryPointName name => EntryPointRef ('Just name)++-- | Constraint on type-level entrypoint name specifier.+type NiceEntryPointName name = (KnownSymbol name, ForbidDefaultName name)  type family ForbidDefaultName (name :: Symbol) :: Constraint where   ForbidDefaultName "Default" =

@@ -1,36 +1,52 @@ -- | Utilities for declaring and documenting entry points. module Lorentz.EntryPoints.Doc   ( DEntryPoint (..)+  , EntryArrow (..)   , PlainEntryPointsKind   , diEntryPointToMarkdown   , DEntryPointArg (..)+  , DType (..)   , DeriveCtorFieldDoc (..)   , ParamBuildingStep (..)   , clarifyParamBuildingSteps+  , constructDEpArg+  , emptyDEpArg+  , mkUType+  , mkDEpUType   , mkDEntryPointArgSimple   , DocumentEntryPoints+  , documentEntryPoint   , entryCase   , entryCase_   ) where +import Control.Lens.Cons (_head)+import Data.Char (toLower) import qualified Data.Kind as Kind+import Data.Singletons (sing) import Data.Vinyl.Core (RMap, Rec(..), rappend)+import Data.Vinyl.Derived (Label) import Fmt (build) import GHC.Generics ((:+:)) import qualified GHC.Generics as G-import GHC.TypeLits (KnownSymbol, symbolVal)+import GHC.TypeLits (AppendSymbol, KnownSymbol, symbolVal)  import Lorentz.ADT import Lorentz.Base+import Lorentz.Constraints.Scopes import Lorentz.Doc+import Lorentz.TypeAnns+import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)+import Michelson.Typed (mkUType) import Michelson.Typed.Doc import Michelson.Typed.Haskell.Doc import Michelson.Typed.Haskell.Instr+import qualified Michelson.Untyped as Untyped import Util.Markdown import Util.Type import Util.TypeTuple --- | Gathers information about single entry point.+-- | Gathers information about single entrypoint. -- -- We assume that entry points might be of different kinds, -- which is designated by phantom type parameter.@@ -47,7 +63,7 @@ diEntryPointToMarkdown :: HeaderLevel -> DEntryPoint level -> Markdown diEntryPointToMarkdown lvl (DEntryPoint name block) =   mdSeparator <>-  mdHeader lvl (mdTicked $ build name) <>+  mdHeader lvl (mdTicked . build . over _head toLower $ name) <>   subDocToMarkdown (nextHeaderLevel lvl) block  -- | Default value for 'DEntryPoint' type argument.@@ -55,7 +71,7 @@  instance DocItem (DEntryPoint PlainEntryPointsKind) where   type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000-  docItemSectionName = Just "Entry points"+  docItemSectionName = Just "Entrypoints"   docItemToMarkdown = diEntryPointToMarkdown  -- | During incremental assembly of parameter building steps -@@ -75,24 +91,66 @@     -- ^ How to construct parameter working on raw Michelson.   } --- | Describes argument of an entry point.-data DEntryPointArg = DEntryPointArg+-- | Describes argument of an entrypoint.+data DEntryPointArg =+  DEntryPointArg   { epaArg :: Maybe DType-    -- ^ Argument of the entry point. Pass 'Nothing' if no argument is required.+    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.+  , epaHasAnnotation :: Bool+    -- ^ Whether this entrypoint has a field annotation (and thus is+    -- callable using the standard "lightweigth entrypoints"+    -- mechanism) or is a virtual entrypoint which requires+    -- constructing a value of the full parameter type.   , epaBuilding :: [ParamBuildingStep]-    -- ^ Describes a way to lift an entry point argument into full parameter+    -- ^ Describes a way to lift an entrypoint argument into full parameter     -- which can be passed to the contract.     --     -- Steps are supposed to be applied in the order in which they are given.-    -- E.g. suppose that an entry point is called as @Run (Service1 arg)@;+    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;     -- then the first step should describe wrapping into @Service1@ constructor,     -- and the second step should be about wrapping into @Run@ constructor.+  , epaType :: Untyped.Type+    -- ^ Untyped representation of entrypoint, used for printing its michelson+    -- type representation.   } -mkDEntryPointArgSimple :: forall t. TypeHasDoc t => DEntryPointArg+constructDEpArg+  :: forall arg.+     ( TypeHasDoc arg+     , HasTypeAnn arg+     , KnownValue arg+     )+  => Bool -> DEntryPointArg+constructDEpArg epaHasAnnotation = DEntryPointArg+  { epaArg = Just $ DType (Proxy @arg)+  , epaHasAnnotation = epaHasAnnotation+  , epaBuilding = []+  , epaType = mkDEpUType @arg+  }++emptyDEpArg :: Bool -> DEntryPointArg+emptyDEpArg epaHasAnnotation = DEntryPointArg+  { epaArg = Nothing+  , epaHasAnnotation = epaHasAnnotation+  , epaBuilding = []+  , epaType = Untyped.Type Untyped.TUnit Untyped.noAnn+  }++mkDEpUType :: forall t. (KnownValue t, HasTypeAnn t) => Untyped.Type+mkDEpUType = mkUType sing (getTypeAnn @t)++mkDEntryPointArgSimple+  :: forall t.+     ( KnownValue t+     , HasTypeAnn t+     , TypeHasDoc t+     )+  => DEntryPointArg mkDEntryPointArgSimple = DEntryPointArg   { epaArg = Just $ DType (Proxy @t)+  , epaHasAnnotation = False   , epaBuilding = []+  , epaType = mkDEpUType @t   }  -- | Go over contract code and update every occurrence of 'DEntryPointArg'@@ -106,39 +164,75 @@ instance DocItem DEntryPointArg where   type DocItemPosition DEntryPointArg = 20   docItemSectionName = Nothing-  docItemDependencies (DEntryPointArg mdty _) =+  docItemDependencies (DEntryPointArg mdty _ _ _) =     [SomeDocDefinitionItem dty | Just dty <- pure mdty]-  docItemToMarkdown _ (DEntryPointArg mdty psteps) =+  docItemToMarkdown _ (DEntryPointArg mdty hasAnnotation psteps et) =     mconcat . Prelude.map (<> "\n\n") $-      [ mdSubsection "Parameter" $+      [ mdSubsection "Argument" $           case mdty of             Nothing -> "none (pass unit)"-            Just (DType dty) -> typeDocMdReference dty (WithinParens False)--      , mdSpoiler "How to call this entry point" . mconcat $-          [ "\n0. Construct parameter for the entry point.\n"-          , mconcat . Prelude.intersperse "\n" $-              psteps <&> \ParamBuildingStep{..} ->-                mconcat . Prelude.intersperse "\n" $-                [ -- Markdown re-enumerates enumerated lists automatically-                  "1. " <> pbsEnglish-                , "    + " <>-                  mdSubsection "In Haskell" (mdTicked $ pbsHaskell "·")-                , "    + " <>-                  mdSubsection "In Michelson" (mdTicked $ pbsMichelson "·")-                ]-          , "\n\nPass resulting value as parameter to the contract.\n"-          ]+            Just (DType (dty :: Proxy ep)) -> mconcat . Prelude.intersperse "\n" $+              [ mempty+              , "  + " <>+                mdSubsection "In Haskell"+                  (typeDocMdReference dty (WithinParens False))+              , "  + " <>+                mdSubsection "In Michelson"+                  (mdTicked $ printDocB False . renderDoc needsParens $ et)+              ],+          mdSpoiler "How to call this entrypoint" $+            "\n0. Construct an argument for the entrypoint.\n" <>+            mconcat howToCall       ]+    where+      howToCall+        | hasAnnotation = howToCallAnnotatedEntrypoint+        | otherwise = howToCallVirtualEntrypoint +      -- TODO: currently we always set @hasAnnotation@ to @True@,+      -- hence this case in unreachable.  It is still useful, we+      -- should set @hasAnnotation@ properly and improve handling of+      -- this case.  Specifically, for virtual entrypoints we should+      -- wrap them into constructors until we reach one having a field+      -- annotation. As soon as it is reached, we can call the+      -- contract by an entrypoint name.+      howToCallVirtualEntrypoint =+        [ mconcat . Prelude.intersperse "\n" $+            psteps <&> \ParamBuildingStep{..} ->+              mconcat . Prelude.intersperse "\n" $+              [ -- Markdown re-enumerates enumerated lists automatically+                "1. " <> pbsEnglish+              , "  + " <>+                mdSubsection "In Haskell" (mdTicked $ pbsHaskell "·")+              , "  + " <>+                mdSubsection "In Michelson" (mdTicked $ pbsMichelson "·")+              ]+        , "\n\nPass resulting value as parameter to the contract.\n"+        ]++      howToCallAnnotatedEntrypoint =+        [ "1. Make a transfer to the contract passing this entrypoint's name " <>+          "and the constructed value as an argument."+        ]+ -- | Pick a type documentation from 'CtorField'.-class DeriveCtorFieldDoc (cf :: CtorField) where-  deriveCtorFieldDoc :: Maybe DType-instance DeriveCtorFieldDoc 'NoFields where-  deriveCtorFieldDoc = Nothing-instance TypeHasDoc ty => DeriveCtorFieldDoc ('OneField ty) where-  deriveCtorFieldDoc = Just $ DType (Proxy @ty)+class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where+  deriveCtorFieldDoc :: DEntryPointArg +instance+    (KnownSymbol con)+  =>+    DeriveCtorFieldDoc con 'NoFields+  where+  deriveCtorFieldDoc = emptyDEpArg True++instance+    (TypeHasDoc ty, HasTypeAnn ty, KnownValue ty, KnownSymbol con)+  =>+    DeriveCtorFieldDoc con ('OneField ty)+  where+  deriveCtorFieldDoc = constructDEpArg @ty True+ -- | Add necessary documentation to entry points. documentEntryPoints   :: forall a kind inp out.@@ -183,7 +277,7 @@ instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x          , KnownSymbol ctor          , DocItem (DEntryPoint kind)-         , DeriveCtorFieldDoc cf+         , DeriveCtorFieldDoc ctor cf          ) =>          GDocumentEntryPoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where   gDocumentEntryPoints michDesc (CaseClauseL clause :& RNil) =@@ -196,7 +290,7 @@         addDoc instr =           clarifyParamBuildingSteps psteps $           docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $-          doc (DEntryPointArg (deriveCtorFieldDoc @cf) []) # instr+          doc (deriveCtorFieldDoc @ctor @cf) # instr     in CaseClauseL (addDoc clause) :& RNil  -- | Like 'case_', to be used for pattern-matching on parameter.@@ -223,3 +317,39 @@      )   => Proxy entryPointKind -> IsoRecTuple clauses -> dt & inp :-> out entryCase p = entryCase_ p . recFromTuple++-- | Wrapper for documenting single entrypoint which parameter+-- isn't going to be unwrapped from some datatype.+--+-- @entryCase@ unwraps a datatype, however, sometimes we want to+-- have entrypoint parameter to be not wrapped into some datatype.+documentEntryPoint+  :: forall kind epName param s out.+     ( KnownSymbol epName+     , DocItem (DEntryPoint kind)+     , TypeHasDoc param+     , HasTypeAnn param+     , KnownValue param+     )+  => param & s :-> out -> param & s :-> out+documentEntryPoint instr =+  let entryPointName = toText $ symbolVal (Proxy @epName) in+    docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $+    doc (constructDEpArg @param True) # instr++-- | Provides arror for convenient entrypoint documentation+class EntryArrow kind name body where+  -- | Lift entrypoint implementation.+  --+  -- Entrypoint names should go with "e" prefix.+  (#->) :: (Label name, Proxy kind) -> body -> body++instance ( name ~ ("e" `AppendSymbol` epName)+         , body ~ (param & s :-> out)+         , KnownSymbol epName+         , DocItem (DEntryPoint kind)+         , TypeHasDoc param+         , HasTypeAnn param+         , KnownValue param+         ) => EntryArrow kind name body where+  (#->) _ = documentEntryPoint @kind @epName

@@ -1,13 +1,14 @@ module Lorentz.EntryPoints.Helpers   ( ctorNameToAnn   , CanHaveEntryPoints+  , ShouldHaveEntryPoints (..)   , RequireSumType   ) where  import qualified Data.Kind as Kind-import qualified GHC.Generics as G -import Michelson.Typed.Haskell.Instr.Sum (IsPrimitiveValue)+import Michelson.Typed.Haskell+import Michelson.Typed.T import Michelson.Untyped (FieldAnn, ann) import Util.Text import Util.Type@@ -16,25 +17,25 @@ ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn ctorNameToAnn = ann . headToLower $ (symbolValT' @ctor) --- | Used to understand whether a type can potentially declare any entrypoints.+-- | A special type which wraps over a primitive type and states that it has+-- entrypoints (one). ----- This type family is conservative, if we are not sure, we suppose that type--- /may/ have entrypoints.-type CanHaveEntryPoints a =-  If (IsPrimitiveValue a)-     'False-     (GCanHaveEntryPoints (G.Rep a))+-- Assuming that any type can have entrypoints makes use of Lorentz entrypoints+-- too annoying, so for declaring entrypoints for not sum types we require an+-- explicit wrapper.+newtype ShouldHaveEntryPoints a = ShouldHaveEntryPoints { unHasEntryPoints :: a }+  deriving stock Generic+  deriving anyclass IsoValue -type family GCanHaveEntryPoints (x :: Kind.Type -> Kind.Type) :: Bool where-  GCanHaveEntryPoints (G.M1 _ _ x) = GCanHaveEntryPoints x-  GCanHaveEntryPoints (_ G.:+: _) = 'True-  GCanHaveEntryPoints G.V1 =-    TypeError ('Text "Void-like type cannot be a parameter")-  GCanHaveEntryPoints (_ G.:*: _) = 'False-  GCanHaveEntryPoints G.U1 = 'False-  GCanHaveEntryPoints (G.Rec0 _) = 'True-    --- ^ Returning True for the sake of newtypes+-- | Used to understand whether a type can potentially declare any entrypoints.+type family CanHaveEntryPoints (p :: Kind.Type) :: Bool where+  CanHaveEntryPoints (ShouldHaveEntryPoints _) = 'True+  CanHaveEntryPoints p = CanHaveEntryPointsT (ToT p) +type family CanHaveEntryPointsT (t :: T) :: Bool where+  CanHaveEntryPointsT ('TOr _ _) = 'True+  CanHaveEntryPointsT _ = 'False+ -- | Ensure that given type is a sum type. -- -- This helps to prevent attempts to apply a function to, for instance, a pair.@@ -42,4 +43,4 @@   RequireSumType a =     If (CanHaveEntryPoints a)        (() :: Constraint)-       (TypeError ('Text "Expected sum type"))+       (TypeError ('Text "Expected Michelson sum type"))

@@ -2,6 +2,7 @@ module Lorentz.EntryPoints.Impl   ( EpdPlain   , EpdRecursive+  , EpdDelegate   ) where  import qualified Data.Kind as Kind@@ -35,14 +36,14 @@ -- have only one field). -- Constructor called 'Default' will designate the default entrypoint. data EpdPlain-instance PlainEntryPointsC 'False cp => EntryPointsDerivation EpdPlain cp where-  type EpdAllEntryPoints EpdPlain cp = PlainAllEntryPointsExt 'False cp-  type EpdLookupEntryPoint EpdPlain cp = PlainLookupEntryPointExt 'False cp-  epdNotes = plainEpdNotesExt @'False @cp-  epdCall = plainEpdCallExt @'False @cp+instance PlainEntryPointsC EpdPlain cp => EntryPointsDerivation EpdPlain cp where+  type EpdAllEntryPoints EpdPlain cp = PlainAllEntryPointsExt EpdPlain cp+  type EpdLookupEntryPoint EpdPlain cp = PlainLookupEntryPointExt EpdPlain cp+  epdNotes = plainEpdNotesExt @EpdPlain @cp+  epdCall = plainEpdCallExt @EpdPlain @cp --- | Similar to 'EpdPlain', but for case of parameter being defined as--- several nested datatypes.+-- | Extension of 'EpdPlain' on parameters being defined as several nested+-- datatypes. -- -- In particular, this will traverse sum types recursively, stopping at -- Michelson primitives (like 'Natural') and constructors with number of@@ -50,33 +51,59 @@ -- -- It does not assign names to intermediate nodes of 'Or' tree, only to the very -- leaves.+--+-- If some entrypoint arguments have custom 'IsoValue' instance, this+-- derivation way will not work. As a workaround, you can wrap your+-- argument into some primitive (e.g. ':!'). data EpdRecursive-instance PlainEntryPointsC 'True cp => EntryPointsDerivation EpdRecursive cp where-  type EpdAllEntryPoints EpdRecursive cp = PlainAllEntryPointsExt 'True cp-  type EpdLookupEntryPoint EpdRecursive cp = PlainLookupEntryPointExt 'True cp-  epdNotes = plainEpdNotesExt @'True @cp-  epdCall = plainEpdCallExt @'True @cp+instance PlainEntryPointsC EpdRecursive cp => EntryPointsDerivation EpdRecursive cp where+  type EpdAllEntryPoints EpdRecursive cp = PlainAllEntryPointsExt EpdRecursive cp+  type EpdLookupEntryPoint EpdRecursive cp = PlainLookupEntryPointExt EpdRecursive cp+  epdNotes = plainEpdNotesExt @EpdRecursive @cp+  epdCall = plainEpdCallExt @EpdRecursive @cp -type PlainAllEntryPointsExt deep cp = AllEntryPoints deep (BuildEPTree deep cp) cp+-- | Extension of 'EpdPlain' on parameters being defined as several nested+-- datatypes.+--+-- In particular, it will traverse the immediate sum type, and require another+-- 'ParameterHasEntryPoints' for the inner complex datatypes. Only those+-- inner types are considered which are the only fields in their respective+-- constructors.+-- Inner types should not themselves declare default entrypoint, we enforce+-- this for better modularity.+-- Each top-level constructor will be treated as entrypoint even if it contains+-- a complex datatype within, in such case that would be an entrypoint+-- corresponding to intermediate node in @or@ tree.+--+-- Comparing to 'EpdRecursive' this gives you more control over where and how+-- entrypoints will be derived.+data EpdDelegate+instance (PlainEntryPointsC EpdDelegate cp) => EntryPointsDerivation EpdDelegate cp where+  type EpdAllEntryPoints EpdDelegate cp = PlainAllEntryPointsExt EpdDelegate cp+  type EpdLookupEntryPoint EpdDelegate cp = PlainLookupEntryPointExt EpdDelegate cp+  epdNotes = plainEpdNotesExt @EpdDelegate @cp+  epdCall = plainEpdCallExt @EpdDelegate @cp -type PlainLookupEntryPointExt deep cp = LookupEntryPoint deep (BuildEPTree deep cp) cp+type PlainAllEntryPointsExt mode cp = AllEntryPoints mode (BuildEPTree mode cp) cp +type PlainLookupEntryPointExt mode cp = LookupEntryPoint mode (BuildEPTree mode cp) cp+ plainEpdNotesExt-  :: forall deep cp.-     (PlainEntryPointsC deep cp, HasCallStack)+  :: forall mode cp.+     (PlainEntryPointsC mode cp, HasCallStack)   => Notes (ToT cp)-plainEpdNotesExt = mkEntryPointsNotes @deep @(BuildEPTree deep cp) @cp+plainEpdNotesExt = mkEntryPointsNotes @mode @(BuildEPTree mode cp) @cp  plainEpdCallExt-  :: forall deep cp name.-     (PlainEntryPointsC deep cp, ParameterScope (ToT cp), KnownSymbol name)+  :: forall mode cp name.+     (PlainEntryPointsC mode cp, ParameterScope (ToT cp), KnownSymbol name)   => Label name-  -> EpConstructionRes (ToT cp) (Eval (LookupEntryPoint deep (BuildEPTree deep cp) cp name))-plainEpdCallExt = mkEpLiftSequence @deep @(BuildEPTree deep cp) @cp+  -> EpConstructionRes (ToT cp) (Eval (LookupEntryPoint mode (BuildEPTree mode cp) cp name))+plainEpdCallExt = mkEpLiftSequence @mode @(BuildEPTree mode cp) @cp -type PlainEntryPointsC deep cp =+type PlainEntryPointsC mode cp =   ( GenericIsoValue cp-  , EntryPointsNotes deep (BuildEPTree deep cp) cp+  , EntryPointsNotes mode (BuildEPTree mode cp) cp   , RequireSumType cp   ) @@ -85,63 +112,72 @@ -- a whole pack of entrypoints. data EPTree   = EPNode EPTree EPTree+    -- ^ We are in the intermediate node and need to go deeper.   | EPLeaf+    -- ^ We reached entrypoint argument.+  | EPDelegate+    -- ^ We reached complex parameter part and will need to ask how to process it.  -- | Build 'EPTree' by parameter type.-type BuildEPTree deep a = GBuildEntryPointsTree deep (G.Rep a)+type BuildEPTree mode a = GBuildEntryPointsTree mode (G.Rep a) -type family GBuildEntryPointsTree (deep :: Bool) (x :: Kind.Type -> Kind.Type)+type family GBuildEntryPointsTree (mode :: Kind.Type) (x :: Kind.Type -> Kind.Type)              :: EPTree where-  GBuildEntryPointsTree deep (G.D1 _ x) =-    GBuildEntryPointsTree deep x-  GBuildEntryPointsTree deep (x G.:+: y) =-    'EPNode (GBuildEntryPointsTree deep x) (GBuildEntryPointsTree deep y)-  GBuildEntryPointsTree 'False (G.C1 _ _) =+  GBuildEntryPointsTree mode (G.D1 _ x) =+    GBuildEntryPointsTree mode x+  GBuildEntryPointsTree mode (x G.:+: y) =+    'EPNode (GBuildEntryPointsTree mode x) (GBuildEntryPointsTree mode y)++  GBuildEntryPointsTree EpdPlain (G.C1 _ _) =     'EPLeaf-  GBuildEntryPointsTree 'True (G.C1 _ x) =-    GBuildEntryPointsTree 'True x-  GBuildEntryPointsTree deep (G.S1 _ x) =-    GBuildEntryPointsTree deep x+  GBuildEntryPointsTree EpdRecursive (G.C1 _ x) =+    GBuildEntryPointsTree EpdRecursive x+  GBuildEntryPointsTree EpdDelegate (G.C1 _ (G.S1 _ (G.Rec0 _))) =+    'EPDelegate+  GBuildEntryPointsTree EpdDelegate (G.C1 _ _) =+    'EPLeaf+  GBuildEntryPointsTree mode (G.S1 _ x) =+    GBuildEntryPointsTree mode x   GBuildEntryPointsTree _ G.U1 =     'EPLeaf   GBuildEntryPointsTree _ (_ G.:*: _) =     'EPLeaf-  GBuildEntryPointsTree deep (G.Rec0 a) =+  GBuildEntryPointsTree mode (G.Rec0 a) =     If (IsPrimitiveValue a)        'EPLeaf-       (BuildEPTree deep a)+       (BuildEPTree mode a)  -- | Traverses sum type and constructs 'Notes' which report -- constructor names via field annotations.-type EntryPointsNotes deep ep a = (Generic a, GEntryPointsNotes deep ep (G.Rep a))+type EntryPointsNotes mode ep a = (Generic a, GEntryPointsNotes mode ep (G.Rep a))  -- | Makes up notes with proper field annotations for given parameter. mkEntryPointsNotes-  :: forall deep ep a.-      (EntryPointsNotes deep ep a, GenericIsoValue a, HasCallStack)+  :: forall mode ep a.+      (EntryPointsNotes mode ep a, GenericIsoValue a, HasCallStack)   => Notes (ToT a)-mkEntryPointsNotes = fst $ gMkEntryPointsNotes @deep @ep @(G.Rep a)+mkEntryPointsNotes = fst $ gMkEntryPointsNotes @mode @ep @(G.Rep a)  -- | Makes up a way to lift entrypoint argument to full parameter. mkEpLiftSequence-  :: forall deep ep a name.-      ( EntryPointsNotes deep ep a, ParameterScope (ToT a)+  :: forall mode ep a name.+      ( EntryPointsNotes mode ep a, ParameterScope (ToT a)       , GenericIsoValue a, KnownSymbol name       )   => Label name-  -> EpConstructionRes (ToT a) (Eval (LookupEntryPoint deep ep a name))-mkEpLiftSequence = gMkEpLiftSequence @deep @ep @(G.Rep a)+  -> EpConstructionRes (ToT a) (Eval (LookupEntryPoint mode ep a name))+mkEpLiftSequence = gMkEpLiftSequence @mode @ep @(G.Rep a)  -- | Fetches information about all entrypoints - leaves of 'Or' tree.-type AllEntryPoints deep ep a = GAllEntryPoints deep ep (G.Rep a)+type AllEntryPoints mode ep a = GAllEntryPoints mode ep (G.Rep a)  -- | Fetches information about all entrypoints - leaves of 'Or' tree.-type LookupEntryPoint deep ep a = GLookupEntryPoint deep ep (G.Rep a)+type LookupEntryPoint mode ep a = GLookupEntryPoint mode ep (G.Rep a)  -- | Generic traversal for 'EntryPointsNotes'.-class GEntryPointsNotes (deep :: Bool) (ep :: EPTree) (x :: Kind.Type -> Kind.Type) where-  type GAllEntryPoints deep ep x :: [(Symbol, Kind.Type)]-  type GLookupEntryPoint deep ep x :: Symbol -> Exp (Maybe Kind.Type)+class GEntryPointsNotes (mode :: Kind.Type) (ep :: EPTree) (x :: Kind.Type -> Kind.Type) where+  type GAllEntryPoints mode ep x :: [(Symbol, Kind.Type)]+  type GLookupEntryPoint mode ep x :: Symbol -> Exp (Maybe Kind.Type)    {- | Returns:     1. Notes corresponding to this level;@@ -152,42 +188,42 @@   gMkEpLiftSequence     :: (KnownSymbol name, ParameterScope (GValueType x))     => Label name-    -> EpConstructionRes (GValueType x) (Eval (GLookupEntryPoint deep ep x name))+    -> EpConstructionRes (GValueType x) (Eval (GLookupEntryPoint mode ep x name)) -instance GEntryPointsNotes deep ep x => GEntryPointsNotes deep ep (G.D1 i x) where-  type GAllEntryPoints deep ep (G.D1 i x) = GAllEntryPoints deep ep x-  type GLookupEntryPoint deep ep (G.D1 i x) = GLookupEntryPoint deep ep x-  gMkEntryPointsNotes = gMkEntryPointsNotes @deep @ep @x-  gMkEpLiftSequence = gMkEpLiftSequence @deep @ep @x+instance GEntryPointsNotes mode ep x => GEntryPointsNotes mode ep (G.D1 i x) where+  type GAllEntryPoints mode ep (G.D1 i x) = GAllEntryPoints mode ep x+  type GLookupEntryPoint mode ep (G.D1 i x) = GLookupEntryPoint mode ep x+  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x -instance (GEntryPointsNotes deep epx x, GEntryPointsNotes deep epy y) =>-         GEntryPointsNotes deep ('EPNode epx epy) (x G.:+: y) where-  type GAllEntryPoints deep ('EPNode epx epy) (x G.:+: y) =-    GAllEntryPoints deep epx x ++ GAllEntryPoints deep epy y-  type GLookupEntryPoint deep ('EPNode epx epy) (x G.:+: y) =-    Over2 (<|>) (GLookupEntryPoint deep epx x) (GLookupEntryPoint deep epy y)+instance (GEntryPointsNotes mode epx x, GEntryPointsNotes mode epy y) =>+         GEntryPointsNotes mode ('EPNode epx epy) (x G.:+: y) where+  type GAllEntryPoints mode ('EPNode epx epy) (x G.:+: y) =+    GAllEntryPoints mode epx x ++ GAllEntryPoints mode epy y+  type GLookupEntryPoint mode ('EPNode epx epy) (x G.:+: y) =+    Over2 (<|>) (GLookupEntryPoint mode epx x) (GLookupEntryPoint mode epy y)   gMkEntryPointsNotes =-    let (xnotes, xann) = gMkEntryPointsNotes @deep @epx @x-        (ynotes, yann) = gMkEntryPointsNotes @deep @epy @y+    let (xnotes, xann) = gMkEntryPointsNotes @mode @epx @x+        (ynotes, yann) = gMkEntryPointsNotes @mode @epy @y     in (NTOr noAnn xann yann xnotes ynotes, noAnn)   gMkEpLiftSequence label =     case sing @(GValueType (x G.:+: y)) of       STOr sl _ -> case (checkOpPresence sl, checkNestedBigMapsPresence sl) of         (OpAbsent, NestedBigMapsAbsent) ->-          case gMkEpLiftSequence @deep @epx @x label of+          case gMkEpLiftSequence @mode @epx @x label of             EpConstructed liftSeq -> EpConstructed (EplWrapLeft liftSeq)             EpConstructionFailed ->-              case gMkEpLiftSequence @deep @epy @y label of+              case gMkEpLiftSequence @mode @epy @y label of                 EpConstructed liftSeq -> EpConstructed (EplWrapRight liftSeq)                 EpConstructionFailed -> EpConstructionFailed  instance ( GHasTypeAnn x, KnownSymbol ctor          , ToT (GExtractField x) ~ GValueType x          ) =>-         GEntryPointsNotes 'False ep (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GAllEntryPoints 'False ep (G.C1 ('G.MetaCons ctor _1 _2) x) =+         GEntryPointsNotes mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntryPoints mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =     '[ '(ctor, GExtractField x) ]-  type GLookupEntryPoint 'False ep (G.C1 ('G.MetaCons ctor _1 _2) x) =+  type GLookupEntryPoint mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =     JustOnEq ctor (GExtractField x)   gMkEntryPointsNotes =     (gGetTypeAnn @x, ctorNameToAnn @ctor)@@ -196,53 +232,62 @@       STrue -> EpConstructed EplArgHere       SFalse -> EpConstructionFailed -instance ( GHasTypeAnn x, KnownSymbol ctor-         , ToT (GExtractField x) ~ GValueType x+instance (ep ~ 'EPNode epx epy, GEntryPointsNotes mode ep x) =>+         GEntryPointsNotes mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntryPoints mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =+    GAllEntryPoints mode ('EPNode epx epy) x+  type GLookupEntryPoint mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =+    GLookupEntryPoint mode ('EPNode epx epy) x+  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x++instance ( ep ~ 'EPDelegate, GEntryPointsNotes mode ep x+         , KnownSymbol ctor, ToT (GExtractField x) ~ GValueType x          ) =>-         GEntryPointsNotes 'True 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GAllEntryPoints 'True 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =-    '[ '(ctor, GExtractField x) ]-  type GLookupEntryPoint 'True 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =-    JustOnEq ctor (GExtractField x)+         GEntryPointsNotes mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntryPoints mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =+    '(ctor, GExtractField x) ': GAllEntryPoints mode 'EPDelegate x+  type GLookupEntryPoint mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =+    Over2 (<|>) (JustOnEq ctor (GExtractField x)) (GLookupEntryPoint mode 'EPDelegate x)   gMkEntryPointsNotes =-    (gGetTypeAnn @x, ctorNameToAnn @ctor)-  gMkEpLiftSequence (_ :: Label name) =+    let (notes, _rootAnn) = gMkEntryPointsNotes @mode @ep @x+    in (notes, ctorNameToAnn @ctor)+  gMkEpLiftSequence (label :: Label name) =     case sing @ctor %== sing @name of       STrue -> EpConstructed EplArgHere-      SFalse -> EpConstructionFailed+      SFalse -> gMkEpLiftSequence @mode @ep @x label -instance (ep ~ 'EPNode epx epy, GEntryPointsNotes 'True ep x) =>-         GEntryPointsNotes 'True ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) where-  type GAllEntryPoints 'True ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =-    GAllEntryPoints 'True ('EPNode epx epy) x-  type GLookupEntryPoint 'True ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =-    GLookupEntryPoint 'True ('EPNode epx epy) x-  gMkEntryPointsNotes = gMkEntryPointsNotes @'True @ep @x-  gMkEpLiftSequence = gMkEpLiftSequence @'True @ep @x+instance GEntryPointsNotes mode ep x => GEntryPointsNotes mode ep (G.S1 i x) where+  type GAllEntryPoints mode ep (G.S1 i x) = GAllEntryPoints mode ep x+  type GLookupEntryPoint mode ep (G.S1 i x) = GLookupEntryPoint mode ep x+  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x -instance GEntryPointsNotes deep ep x => GEntryPointsNotes deep ep (G.S1 i x) where-  type GAllEntryPoints deep ep (G.S1 i x) = GAllEntryPoints deep ep x-  type GLookupEntryPoint deep ep (G.S1 i x) = GLookupEntryPoint deep ep x-  gMkEntryPointsNotes = gMkEntryPointsNotes @deep @ep @x-  gMkEpLiftSequence = gMkEpLiftSequence @deep @ep @x+instance (EntryPointsNotes EpdRecursive ep a, GenericIsoValue a) =>+         GEntryPointsNotes EpdRecursive ep (G.Rec0 a) where+  type GAllEntryPoints EpdRecursive ep (G.Rec0 a) = AllEntryPoints EpdRecursive ep a+  type GLookupEntryPoint EpdRecursive ep (G.Rec0 a) = LookupEntryPoint EpdRecursive ep a+  gMkEntryPointsNotes = (mkEntryPointsNotes @EpdRecursive @ep @a, noAnn)+  gMkEpLiftSequence = mkEpLiftSequence @EpdRecursive @ep @a -instance (EntryPointsNotes deep ep a, GenericIsoValue a) =>-         GEntryPointsNotes deep ep (G.Rec0 a) where-  type GAllEntryPoints deep ep (G.Rec0 a) = AllEntryPoints deep ep a-  type GLookupEntryPoint deep ep (G.Rec0 a) = LookupEntryPoint deep ep a-  gMkEntryPointsNotes = (mkEntryPointsNotes @deep @ep @a, noAnn)-  gMkEpLiftSequence = mkEpLiftSequence @deep @ep @a+instance (ParameterDeclaresEntryPoints a) =>+         GEntryPointsNotes EpdDelegate 'EPDelegate (G.Rec0 a) where+  type GAllEntryPoints EpdDelegate 'EPDelegate (G.Rec0 a) = AllParameterEntryPoints a+  type GLookupEntryPoint EpdDelegate 'EPDelegate (G.Rec0 a) = LookupParameterEntryPoint a+  gMkEntryPointsNotes = (pepNotes @a, noAnn)+  -- TODO [#35]: should use field ann ^^^^^ returned by 'epdNotes'+  gMkEpLiftSequence = pepCall @a -instance GEntryPointsNotes deep 'EPLeaf G.U1 where-  type GAllEntryPoints deep 'EPLeaf G.U1 = '[]-  type GLookupEntryPoint deep 'EPLeaf G.U1 = Fcf.ConstFn 'Nothing+instance GEntryPointsNotes mode 'EPLeaf G.U1 where+  type GAllEntryPoints mode 'EPLeaf G.U1 = '[]+  type GLookupEntryPoint mode 'EPLeaf G.U1 = Fcf.ConstFn 'Nothing   gMkEntryPointsNotes = (starNotes, noAnn)   gMkEpLiftSequence _ = EpConstructionFailed  instance Each [Typeable, SingI] [GValueType x, GValueType y] =>-         GEntryPointsNotes deep 'EPLeaf (x G.:*: y) where-  type GAllEntryPoints deep 'EPLeaf (x G.:*: y) = '[]-  type GLookupEntryPoint deep 'EPLeaf (x G.:*: y) = Fcf.ConstFn 'Nothing+         GEntryPointsNotes mode 'EPLeaf (x G.:*: y) where+  type GAllEntryPoints mode 'EPLeaf (x G.:*: y) = '[]+  type GLookupEntryPoint mode 'EPLeaf (x G.:*: y) = Fcf.ConstFn 'Nothing   gMkEntryPointsNotes = (starNotes, noAnn)   gMkEpLiftSequence _ = EpConstructionFailed 

@@ -32,7 +32,7 @@  instance ( NiceParameter cp          , EntryPointsDerivation epd cp-         , RequireAllUniqueEntryPoints epd cp+         , RequireAllUniqueEntryPoints' epd cp          ) =>          ParameterHasEntryPoints (ParameterWrapper epd cp) where   type ParameterEntryPointsDerivation (ParameterWrapper epd cp) = PwDeriv epd

@@ -284,7 +284,7 @@ instance (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag))) =>          ErrorHasDoc (CustomError tag) where   errorDocName = errorTagToText @tag-  errorDocDependencies = typeDocDependencies' (Proxy @(ErrorArg tag))+  errorDocDependencies = [SomeDocDefinitionItem $ DType $ Proxy @(ErrorArg tag)]   errorDocMdCause = customErrDocMdCause @tag   errorDocMdCauseInEntrypoint = customErrDocMdCauseInEntrypoint @tag   errorDocClass = customErrClass @tag

@@ -13,10 +13,13 @@  module Lorentz.Errors.Numeric   ( ErrorTagMap+  , ErrorTagExclusions   , gatherErrorTags   , addNewErrorTags   , buildErrorTagMap+  , excludeErrorTags   , applyErrorTagMap+  , applyErrorTagMapWithExclusions   , useNumericErrors    , errorFromValNumeric@@ -40,6 +43,9 @@ -- and textual error tags. type ErrorTagMap = Bimap Natural MText +-- | Tags excluded from map.+type ErrorTagExclusions = HashSet MText+ -- | Find all textual error tags that are used in typical -- @FAILWITH@ patterns within given instruction. -- Map them to natural numbers.@@ -67,6 +73,23 @@ buildErrorTagMap :: HashSet MText -> ErrorTagMap buildErrorTagMap = addNewErrorTags Bimap.empty +-- | Remove some error tags from map.+-- This way you say to remain these string tags intact, while others will be+-- converted to numbers when this map is applied.+--+-- Note that later you have to apply this map using+-- 'applyErrorTagMapWithExclusions', otherwise an error would be raised.+excludeErrorTags+  :: HasCallStack+  => ErrorTagExclusions -> ErrorTagMap -> ErrorTagMap+excludeErrorTags toExclude errMap =+  foldl' (flip deleteExistingR) errMap toExclude+  where+    deleteExistingR k m = case Bimap.lookupR k m of+      Just _ -> Bimap.deleteR k m+      Nothing ->+        error $ "Tag " <> show k <> " does not appear in the contract"+ -- | For each typical 'FAILWITH' that uses a string to represent error -- tag this function changes error tag to be a number using the -- supplied conversion map.@@ -75,8 +98,18 @@ -- It will always be the case if you gather all error tags using -- 'gatherErrorTags' and build 'ErrorTagMap' from them using 'addNewErrorTags'. applyErrorTagMap :: HasCallStack => ErrorTagMap -> inp :-> out -> inp :-> out-applyErrorTagMap errorTagMap = iMapAnyCode (applyErrorTagMapT errorTagMap)+applyErrorTagMap errorTagMap = applyErrorTagMapWithExclusions errorTagMap mempty +-- | Similar to 'applyErrorTagMap', but for case when you have excluded some+-- tags from map via 'excludeErrorTags'.+-- Needed, because both 'excludeErrorTags' and this function do not tolerate+-- unknown errors in contract code (for your safety).+applyErrorTagMapWithExclusions+  :: HasCallStack+  => ErrorTagMap -> ErrorTagExclusions -> inp :-> out -> inp :-> out+applyErrorTagMapWithExclusions errorTagMap exclusions =+  iMapAnyCode (applyErrorTagMapWithExcT errorTagMap exclusions)+ -- | This function implements the simplest scenario of using this -- module's functionality: -- 1. Gather all error tags from a single instruction.@@ -89,12 +122,13 @@     errorTagMap = buildErrorTagMap $ gatherErrorTags instr  -- This function works with 'Michelson.Typed' representation, not with Lorentz.-applyErrorTagMapT ::+applyErrorTagMapWithExcT ::      HasCallStack   => ErrorTagMap+  -> ErrorTagExclusions   -> Instr inp out   -> Instr inp out-applyErrorTagMapT errorTagMap instr =+applyErrorTagMapWithExcT errorTagMap exclusions instr =   dfsModifyInstr dfsSettings step instr   where     dfsSettings :: DfsSettings ()@@ -102,16 +136,17 @@       { dsGoToValues = True       } -    tagToNatValue :: HasCallStack => MText -> Value ('Tc 'CNat)+    tagToNatValue :: HasCallStack => MText -> SomeConstrainedValue ConstantScope'     tagToNatValue tag =-      case Bimap.lookupR tag errorTagMap of+      case (HS.member tag exclusions, Bimap.lookupR tag errorTagMap) of+        (True, _) -> SomeConstrainedValue (VC $ CvString tag)         -- It will be applied to textual tags detected by 'modifyTypicalFailWith'.         -- Here we assume that all of them are discovered by the analyzer.         -- If this error ever happens, it means that someone used         -- 'applyErrorTagMap' with incomplete 'ErrorTagMap' or there is an         -- internal bug somewhere.-        Nothing -> error $ "Can't find a tag: " <> pretty tag-        Just n -> VC $ CvNat n+        (False, Nothing) -> error $ "Can't find a tag: " <> pretty tag+        (False, Just n) -> SomeConstrainedValue (VC $ CvNat n)      step :: HasCallStack => Instr inp out -> Instr inp out     step = modifyTypicalFailWith tagToNatValue

@@ -65,11 +65,13 @@   , le0   , ge0   , int+  , toTAddress_   , self   , selfCalling   , contract   , contractCalling   , contractCallingUnsafe+  , runFutureContract   , epAddressToContract   , transferTokens   , setDelegate@@ -112,7 +114,7 @@ import Michelson.Typed   (pattern CAR, pattern CDR, ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN',   ConstraintDUG, ConstraintDUG', pattern DefEpName, EntryPointCallT(..), Instr(..), RemFail(..),-  SomeEntryPointCallT(..), ToTs, Value'(..), starNotes)+  SomeEntryPointCallT(..), ToTs, Value'(..), sepcName, starNotes) import Michelson.Typed.Arith import Michelson.Typed.Haskell.Value import Util.Peano@@ -457,6 +459,16 @@ int :: Natural & s :-> Integer & s int = I INT +-- | Cast something appropriate to 'TAddress'.+-- TODO [TM-280]: try to move somewhere+toTAddress_+  :: (ToTAddress_ cp addr)+  => addr : s :-> TAddress cp : s+toTAddress_ = I Nop++-- | Something coercible to 'TAddress cp'.+type ToTAddress_ cp addr = (ToTAddress cp addr, ToT addr ~ ToT Address)+ -- | Get a reference to the current contract. -- -- Note that, similar to 'CONTRACT' instruction, in Michelson 'SELF' instruction@@ -471,12 +483,9 @@ -- If you are going to call a specific entrypoint of the contract, see 'selfCalling'. self   :: forall p s.-      (NiceParameterFull p, NoExplicitDefaultEntryPoint p)+      (NiceParameterFull p, ForbidExplicitDefaultEntryPoint p)   => s :-> ContractRef p & s-self = I (SELF def) \\ niceParameterEvi @p-  where-    -- Avoiding redundant-constraints warning.-    _validUsage = Dict @(NoExplicitDefaultEntryPoint p)+self = I (SELF $ sepcCallRootChecked @p) \\ niceParameterEvi @p  -- | Make a reference to the current contract, maybe a specific entrypoint. --@@ -501,22 +510,25 @@ -- -- If you are going to call a specific entrypoint of the contract, see 'contractCalling'. contract-  :: forall p s.-      (NiceParameterFull p, NoExplicitDefaultEntryPoint p)-  => Address & s :-> Maybe (ContractRef p) & s-contract = I (CONTRACT starNotes DefEpName) \\ niceParameterEvi @p+  :: forall p addr s.+      ( NiceParameterFull p, ForbidExplicitDefaultEntryPoint p+      , ToTAddress_ p addr+      )+  => addr & s :-> Maybe (ContractRef p) & s+contract = I (CONTRACT starNotes epName) \\ niceParameterEvi @p   where-    -- Avoiding redundant-constraints warning.-    _validUsage = Dict @(NoExplicitDefaultEntryPoint p)+    epName = sepcName (sepcCallRootChecked @p)  -- | Make a reference to a contract, maybe a specific entrypoint. ----- Note that in most cases you need to specify parameter type as type argument @p@.+-- When calling this function, make sure that parameter type is known.+-- It's recommended that you supply 'TAddress' with a concrete parameter as the+-- stack argument. contractCalling-  :: forall cp epRef epArg s.-     (HasEntryPointArg cp epRef epArg)+  :: forall cp epRef epArg addr s.+     (HasEntryPointArg cp epRef epArg, ToTAddress_ cp addr)   => epRef-  -> Address & s :-> Maybe (ContractRef epArg) & s+  -> addr & s :-> Maybe (ContractRef epArg) & s contractCalling epRef = I $   case useHasEntryPointArg @cp @epRef @epArg epRef of     (Dict, epName) -> CONTRACT starNotes epName@@ -533,10 +545,20 @@   -> Address & s :-> Maybe (ContractRef arg) & s contractCallingUnsafe epName = contractCalling (TrustEpName epName) --- | Version of 'contract' which may accept address with already specified--- entrypoint name.--- Validity of such operation cannot be ensured at compile time. Also you cannot--- provide entrypoint name here because this could result in conflict.+-- | Version of 'contract' instruction which may accept address with already+-- specified entrypoint name.+--+-- Also you cannot specify entrypoint name here because this could result in+-- conflict.+runFutureContract+  :: forall p s. (NiceParameter p)+  => FutureContract p & s :-> Maybe (ContractRef p) & s+runFutureContract =+  I Nop # epAddressToContract++-- | Similar to 'runFutureContract', works with 'EpAddress'.+--+-- Validity of such operation cannot be ensured at compile time. epAddressToContract   :: forall p s. (NiceParameter p)   => EpAddress & s :-> Maybe (ContractRef p) & s@@ -552,7 +574,7 @@ setDelegate = I SET_DELEGATE  createContract-  :: forall p g s. (NiceStorage g, ParameterDeclaresEntryPoints p)+  :: forall p g s. (NiceStorage g, NiceParameterFull p)   => Contract p g   -> Maybe KeyHash & Mutez & g & s   :-> Operation & Address & s

@@ -64,6 +64,9 @@   , cddr   , ifRight   , ifSome+  , when_+  , unless_+  , whenSome   , mapCar   , mapCdr   , papair@@ -96,13 +99,12 @@   -- * Macros for working with @address@ and @contract@-like types   , addressToEpAddress   , pushContractRef-  , pickFutureContract   ) where  import Prelude hiding (compare, drop, some, swap)  import qualified Data.Kind as Kind-import Data.Singletons(SingI(..))+import Data.Singletons (SingI(..)) import Data.Vinyl.TypeLevel (Nat(..)) import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+)) import Fmt.Internal.Tuple (TupleF)@@ -114,7 +116,6 @@ import Lorentz.Coercions import Lorentz.Constraints import Lorentz.Doc-import Lorentz.EntryPoints import Lorentz.Errors import Lorentz.Ext (stackType) import Lorentz.Instr@@ -122,7 +123,6 @@ import Michelson.Typed (ConstraintDIG', ConstraintDIPN', T, typeDocDependencies') import Michelson.Typed.Arith import Michelson.Typed.Haskell.Value-import Michelson.Typed (sepcName) import Util.Markdown import Util.Peano import Util.Type@@ -440,6 +440,15 @@   :: (a & s :-> s') -> (s :-> s') -> (Maybe a & s :-> s') ifSome s n = ifNone n s +when_ :: (s :-> s) -> (Bool : s :-> s)+when_ i = if_ i nop++unless_ :: (s :-> s) -> (Bool : s :-> s)+unless_ i = if_ nop i++whenSome :: (a : s :-> s) -> (Maybe a : s :-> s)+whenSome i = ifSome i nop+ -- | Various convenient instructions on maps. class MapInstrs map where   -- | Specialized version of 'update'.@@ -507,7 +516,7 @@   typeDocMdDescription =     "`View a r` accepts an argument of type `a` and callback contract \     \which accepts `r` and returns result via calling that contract.\n\-    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/blob/master/A/A1.md#view-entry-points)."+    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md#view-entrypoints)."   typeDocMdReference = poly2TypeDocMdReference   typeDocDependencies p =     genericTypeDocDependencies p <>@@ -561,7 +570,7 @@     -- ^ Entry point argument.   , voidResProxy :: Lambda b b     -- ^ Type of result reported via 'failWith'.-  } deriving stock Generic+  } deriving stock (Generic, Show)     deriving anyclass IsoValue  instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (Void_ a r) where@@ -572,7 +581,7 @@     \custom errors, void entrypoints execute `FAILWITH` instruction on \     \`(\"VoidResult\", r)` value, where `r` is the actual return value of the \     \entrypoint.\n\-    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/blob/master/A/A1.md#void-entry-points)."+    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md#void-entrypoints)."   typeDocMdReference tp =     -- Avoiding trailing underscore     customTypeDocMdReference@@ -660,16 +669,6 @@ addressToEpAddress :: Address : s :-> EpAddress : s addressToEpAddress = forcedCoerce_ --- | Turn 'FutureContract' into actual 'contract'.------ This requires contracts lookup and may fail.-pickFutureContract-  :: forall p mname arg s.-     (ParameterDeclaresEntryPoints p, arg ~ GetEntryPointArgCustom p mname)-  => EntryPointRef mname-  -> FutureContract p : s :-> Maybe (ContractRef arg) : s-pickFutureContract epRef = checkedCoerce_ # contractCalling @p epRef- -- | Push a value of @contract@ type. -- -- Doing this via 'push' instruction is not possible, so we need to perform@@ -679,10 +678,10 @@ -- throw in case this value is not valid. pushContractRef   :: NiceParameter arg-  => (forall s0. EpAddress : s :-> s0)+  => (forall s0. FutureContract arg : s :-> s0)   -> ContractRef arg   -> (s :-> ContractRef arg : s)-pushContractRef onContractNotFound (ContractRef addr sepc :: ContractRef arg) =+pushContractRef onContractNotFound (contractRef :: ContractRef arg) =   withDict (niceParameterEvi @arg) $-    push (EpAddress addr (sepcName sepc)) # dup #-    epAddressToContract # ifNone onContractNotFound (dip drop)+    push (FutureContract contractRef) # dup #+    runFutureContract # ifNone onContractNotFound (dip drop)

@@ -12,6 +12,13 @@   , return   , ifThenElse   , Condition (..)+  , (<.)+  , (>.)+  , (<=.)+  , (>=.)+  , (==.)+  , (/=.)+  , keepIfArgs      -- * Re-exports required for RebindableSyntax   , fromInteger@@ -20,10 +27,14 @@   ) where  -import Prelude hiding ((>>), (>>=))+import Prelude hiding (drop, swap, (>>), (>>=)) +import Data.Vinyl.Derived (Label)+import Named ((:!))+ import Lorentz.Arith import Lorentz.Base+import Lorentz.Coercions import Lorentz.Instr import Lorentz.Macro import Michelson.Typed.Arith@@ -34,31 +45,50 @@  -- | Predicate for @if ... then .. else ...@ construction, -- defines a kind of operation applied to the top elements of the current stack.-data Condition arg argl argr where-  Holds :: Condition (Bool ': s) s s-  IsSome :: Condition (Maybe a ': s) (a ': s) s-  IsNone :: Condition (Maybe a ': s) s (a ': s)-  IsLeft :: Condition (Either l r ': s) (l ': s) (r ': s)-  IsRight :: Condition (Either l r ': s) (r ': s) (l ': s)-  IsCons :: Condition ([a] ': s) (a ': [a] ': s) s-  IsNil :: Condition ([a] ': s) s (a ': [a] ': s)+--+-- Type arguments mean:+-- 1. Input of @if@+-- 2. Left branch input+-- 3. Right branch input+-- 4. Output of branches+-- 5. Output of @if@+data Condition arg argl argr outb out where+  Holds :: Condition (Bool ': s) s s o o+  IsSome :: Condition (Maybe a ': s) (a ': s) s o o+  IsNone :: Condition (Maybe a ': s) s (a ': s) o o+  IsLeft :: Condition (Either l r ': s) (l ': s) (r ': s) o o+  IsRight :: Condition (Either l r ': s) (r ': s) (l ': s) o o+  IsCons :: Condition ([a] ': s) (a ': [a] ': s) s o o+  IsNil :: Condition ([a] ': s) s (a ': [a] ': s) o o    IsZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool)-         => Condition (a ': s) s s+         => Condition (a ': s) s s o o   IsNotZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool)-         => Condition (a ': s) s s+         => Condition (a ': s) s s o o -  IsEq :: NiceComparable a => Condition (a ': a ': s) s s-  IsNeq :: NiceComparable a => Condition (a ': a ': s) s s-  IsLt :: NiceComparable a => Condition (a ': a ': s) s s-  IsGt :: NiceComparable a => Condition (a ': a ': s) s s-  IsLe :: NiceComparable a => Condition (a ': a ': s) s s-  IsGe :: NiceComparable a => Condition (a ': a ': s) s s+  IsEq :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsNeq :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsLt :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsGt :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsLe :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsGe :: NiceComparable a => Condition (a ': a ': s) s s o o +  -- | Explicitly named binary condition, to ensure proper order of+  -- stack arguments.+  NamedBinCondition ::+    Condition (a ': a ': s) s s o o ->+    Label n1 -> Label n2 ->+    Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o++  -- | Provide the compared arguments to @if@ branches.+  PreserveArgsBinCondition ::+    (forall st o. Condition (a ': b ': st) st st o o) ->+    Condition (a ': b ': s) (a ': b ': s) (a ': b ': s) (a ': b ': s) s+ -- | Defines semantics of @if ... then ... else ...@ construction. ifThenElse-  :: Condition arg argl argr-  -> (argl :-> o) -> (argr :-> o) -> (arg :-> o)+  :: Condition arg argl argr outb out+  -> (argl :-> outb) -> (argr :-> outb) -> (arg :-> out) ifThenElse = \case   Holds -> if_   IsSome -> flip ifNone@@ -77,3 +107,73 @@   IsGt -> ifGt   IsLe -> ifLe   IsGe -> ifGe++  NamedBinCondition condition l1 l2 -> \l r ->+    fromNamed l1 # dip (fromNamed l2) # ifThenElse condition l r++  PreserveArgsBinCondition condition -> \l r ->+    dip dup # swap # dip dup # swap #+    ifThenElse condition+      -- since this pattern is commonly used when one of the branches fails,+      -- it's essential to @drop@ within branches, not after @if@ - @drop@s+      -- appearing to be dead code will be cut off+      (l # drop # drop)+      (r # drop # drop)++-- | Named version of 'IsLt'.+--+-- In this and similar operators you provide names of accepted stack operands as+-- a safety measure of that they go in the expected order.+infix 4 <.+(<.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(<.) = NamedBinCondition IsLt++-- | Named version of 'IsGt'.+infix 4 >.+(>.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(>.) = NamedBinCondition IsGt++-- | Named version of 'IsLe'.+infix 4 <=.+(<=.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(<=.) = NamedBinCondition IsLe++-- | Named version of 'IsGe'.+infix 4 >=.+(>=.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(>=.) = NamedBinCondition IsGe++-- | Named version of 'IsEq'.+infix 4 ==.+(==.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(==.) = NamedBinCondition IsEq++-- | Named version of 'IsNeq'.+infix 4 /=.+(/=.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(/=.) = NamedBinCondition IsNeq++-- | Condition modifier, makes stack operands of binary comparison to be+-- available within @if@ branches.+keepIfArgs+  :: (forall st o. Condition (a ': b ': st) st st o o)+  -> Condition (a ': b ': s) (a ': b ': s) (a ': b ': s) (a ': b ': s) s+keepIfArgs = PreserveArgsBinCondition

@@ -5,7 +5,7 @@ -- They allow to "dip" into stack or copy elements of stack referring them -- by type. Their use is justified, because in most cases there is only -- one element of each type of stack, and in cases when this does not hold--- (e.g. entry point with multiple parameters of the same type), it might be+-- (e.g. entrypoint with multiple parameters of the same type), it might be -- a good idea to wrap those types into a newtype or to use primitives from -- 'named' package. --

@@ -1,6 +1,8 @@ module Lorentz.Run-  ( compileLorentz+  ( CompilationOptions(..)+  , compileLorentz   , compileLorentzContract+  , compileLorentzContractWithOptions   , interpretLorentzInstr   , interpretLorentzLambda   , analyzeLorentz@@ -15,8 +17,8 @@ import Michelson.Analyzer (AnalyzerRes, analyze) import Michelson.Interpret import Michelson.Typed-  (FullContract(..), Instr(..), IsoValue, IsoValuesStack(..), ToT, ToTs, isStar, starNotes,-  unParamNotes)+  (FullContract(..), Instr(..), IsoValue, IsoValuesStack(..), ParamNotes(..), ToT, ToTs, isStar,+  starNotes, unParamNotes)  -- | For use outside of Lorentz. compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out)@@ -28,12 +30,37 @@   :: forall cp st.      (NiceParameterFull cp, NiceStorage st)   => Contract cp st -> FullContract (ToT cp) (ToT st)-compileLorentzContract contract =+compileLorentzContract =+  compileLorentzContractWithOptions defaultCompilationOptions++data CompilationOptions = CompilationOptions+  { coDisableInitialCast :: Bool+  -- ^ Flag which defines, whether compiled Michelson contract+  -- will have @CAST@ (which drops parameter annotations)+  -- as a first instruction. Note, that when+  -- flag is false, there still can be no @CAST@ (in case+  -- when parameter type has no annotations).+  }++defaultCompilationOptions :: CompilationOptions+defaultCompilationOptions = CompilationOptions { coDisableInitialCast = False }++-- | Version on 'compileLorentzContract' which accepts @CompilationOptions@.+--+-- Note that compiled contract can be ill-typed in terms of Michelson code+-- when some of the compilation options are used (e.g. when coDoInitialCast+-- is False, resulted contract can be ill-typed).+-- However, compilation with @defaultCompilationOptions@ should be valid.+compileLorentzContractWithOptions+  :: forall cp st.+     (NiceParameterFull cp, NiceStorage st)+  => CompilationOptions -> Contract cp st -> FullContract (ToT cp) (ToT st)+compileLorentzContractWithOptions CompilationOptions{..} contract =   FullContract-  { fcCode = if isStar (unParamNotes cpNotes)-      then  -- We have no annotations. Print contract as such.+  { fcCode = if (isStar (unParamNotes cpNotes) || coDisableInitialCast)+      then -- If contract parameter type has no annotations or explicitly asked, we drop CAST.         compileLorentz contract-      else  -- If we have some annotations, erase them.+      else -- Perform CAST otherwise.         compileLorentz (I CAST # contract :: Contract cp st)   , fcParamNotesSafe = cpNotes   , fcStoreNotes = starNotes

@@ -9,6 +9,7 @@   , ContractPropValidator   , contractProp   , contractPropVal+  , expectContractEntrypoints    -- * Integrational testing   -- ** Testing engine@@ -24,6 +25,7 @@   , lTransfer   , lCall   , lCallEP+  , EntryPointRef (..)   , lCallDef   , validate   , integrationalFail@@ -44,6 +46,7 @@   , expectNoStorageUpdates   , lExpectStorageUpdate   , lExpectBalance+  , lExpectStorage   , lExpectStorageConst   , lExpectMichelsonFailed   , lExpectFailWith@@ -99,4 +102,5 @@  import Lorentz.Test.Consumer import Lorentz.Test.Doc-import Lorentz.Test.Integrational as Exports+import Lorentz.Test.Integrational+import Lorentz.Test.Unit

@@ -31,6 +31,7 @@   , lTransfer   , lCall   , lCallEP+  , EntryPointRef (..)   , lCallDef   , I.validate   , I.integrationalFail@@ -51,6 +52,7 @@   , I.expectNoStorageUpdates   , lExpectStorageUpdate   , lExpectBalance+  , lExpectStorage   , lExpectStorageConst   -- * Errors   , lExpectMichelsonFailed@@ -83,11 +85,12 @@ import Michelson.Interpret (InterpretError(..), MichelsonFailed(..)) import Michelson.Runtime import Michelson.Runtime.GState-import Michelson.Test.Integrational (IntegrationalScenarioM, SuccessValidator)+import Michelson.Test.Integrational import qualified Michelson.Test.Integrational as I import Michelson.TypeCheck (typeVerifyValue) import qualified Michelson.Typed as T import Michelson.Typed.Scope+import qualified Michelson.Untyped as U import Tezos.Core import Util.Named ((.!)) @@ -111,24 +114,24 @@ -- | Like 'originate', but for Lorentz contracts. lOriginate   :: forall cp st.-     (L.ParameterDeclaresEntryPoints cp, NiceStorage st)+     (L.NiceParameterFull cp, NiceStorage st)   => L.Contract cp st   -> Text   -> st   -> Mutez-  -> IntegrationalScenarioM (ContractRef cp)+  -> IntegrationalScenarioM (TAddress cp) lOriginate contract name value balance =   withDict (niceParameterEvi @cp) $   withDict (niceStorageEvi @st) $ do     addr <- tOriginate (compileLorentzContract contract) name (T.toVal value) balance-    return (L.ContractRef addr def)+    return (L.TAddress addr)  -- | Originate a contract with empty balance and default storage. lOriginateEmpty-  :: (L.ParameterDeclaresEntryPoints cp, NiceStorage st, Default st)+  :: (L.NiceParameterFull cp, NiceStorage st, Default st)   => L.Contract cp st   -> Text-  -> IntegrationalScenarioM (ContractRef cp)+  -> IntegrationalScenarioM (TAddress cp) lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)  -- | Similar to 'transfer', for typed values.@@ -159,15 +162,15 @@  -- | Similar to 'transfer', for Lorentz values. lTransfer-  :: forall cp epRef epArg contract.-     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToContractRef cp contract)+  :: forall cp epRef epArg addr.+     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)   => "from" :! Address-  -> "to" :! contract+  -> "to" :! addr   -> Mutez   -> epRef   -> epArg   -> IntegrationalScenarioM ()-lTransfer from (convertContractRef @cp @Address . arg #to -> to) money epRef param =+lTransfer from (toTAddress @cp . arg #to -> TAddress to) money epRef param =   case useHasEntryPointArg @cp @epRef @epArg epRef of     (Dict, epName) -> tTransfer from (#to .! to) money epName (T.toVal param) @@ -178,35 +181,35 @@ -- -- This function is DEPRECATED and exists only for backwards compatibility. lCall-  :: forall cp defEpName contract.+  :: forall cp defEpName addr.      ( HasDefEntryPointArg cp defEpName cp      , IsoValue cp-     , ToContractRef cp contract+     , ToTAddress cp addr      )-  => contract -> cp -> IntegrationalScenarioM ()-lCall = lCallDef @cp @defEpName @cp @contract+  => addr -> cp -> IntegrationalScenarioM ()+lCall = lCallDef @cp @defEpName @cp @addr  -- | Call an entrypoint of a contract without caring about the source -- address. Transfers 0 mutez. lCallEP-  :: forall cp epRef epArg contract.-     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToContractRef cp contract)-  => contract -> epRef -> epArg -> IntegrationalScenarioM ()-lCallEP contract epRef param =+  :: forall cp epRef epArg addr.+     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)+  => addr -> epRef -> epArg -> IntegrationalScenarioM ()+lCallEP addr epRef param =   lTransfer @cp @epRef @epArg-    (#from .! genesisAddress) (#to .! contract)+    (#from .! genesisAddress) (#to .! addr)     (unsafeMkMutez 0) epRef param  -- | 'lCallEP' for default entrypoint. lCallDef-  :: forall cp defEpName defArg contract.+  :: forall cp defEpName defArg addr.      ( HasDefEntryPointArg cp defEpName defArg      , IsoValue defArg-     , ToContractRef cp contract+     , ToTAddress cp addr      )-  => contract -> defArg -> IntegrationalScenarioM ()-lCallDef contract =-  lCallEP @cp @defEpName @defArg contract CallDefault+  => addr -> defArg -> IntegrationalScenarioM ()+lCallDef addr =+  lCallEP @cp @defEpName @defArg addr CallDefault  ---------------------------------------------------------------------------- -- Validators to be used within 'IntegrationalValidator'@@ -214,13 +217,15 @@  -- Expect something successful --- | Similar to 'expectStorageUpdate', for Lorentz values.-lExpectStorageUpdate+-- | Internal function that proceeds storage validation from by untyping+-- the value passed to callback.+validateStorageCb   :: forall st addr.      (NiceStorage st, ToAddress addr, HasCallStack)-  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator-lExpectStorageUpdate (toAddress -> addr) predicate =-  I.expectStorageUpdate addr $ \got -> do+  => (Address -> (U.Value -> Either ValidationError ()) -> SuccessValidator)+  -> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+validateStorageCb validator (toAddress -> addr) predicate =+  validator addr $ \got -> do     val <- first I.UnexpectedTypeCheckError $ typeCheck got     predicate $ T.fromVal val   where@@ -230,6 +235,20 @@       typeVerifyValue uval     initSt = error "Typechecker state unavailable" +-- | Similar to 'expectStorage', but for Lorentz values.+lExpectStorage+  :: forall st addr.+     (NiceStorage st, ToAddress addr, HasCallStack)+  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectStorage = validateStorageCb I.expectStorage++-- | Similar to 'expectStorageUpdate', but for Lorentz values.+lExpectStorageUpdate+  :: forall st addr.+     (NiceStorage st, ToAddress addr, HasCallStack)+  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate+ -- | Like 'expectBalance', for Lorentz values. lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator lExpectBalance (toAddress -> addr) money = I.expectBalance addr money@@ -238,9 +257,9 @@ tExpectStorageConst   :: forall st.      (StorageScope st)-  => Address -> Value st -> SuccessValidator+  => Address -> T.Value st -> SuccessValidator tExpectStorageConst addr expected =-  I.expectStorageConst addr (T.untypeValue expected)+  expectStorageConst addr (T.untypeValue expected)  -- | Similar to 'expectStorageConst', for Lorentz values. lExpectStorageConst@@ -345,10 +364,10 @@ -- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract -- (see 'Lorentz.Contracts.Consumer.contractConsumer'). lExpectConsumerStorage-  :: forall cp st contract.-     (st ~ [cp], NiceStorage st, ToContractRef cp contract)-  => contract -> (st -> Either I.ValidationError ()) -> SuccessValidator-lExpectConsumerStorage = lExpectStorageUpdate . toContractRef @cp+  :: forall cp st addr.+     (st ~ [cp], NiceStorage st, ToTAddress cp addr)+  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr)  -- | Assuming that "consumer" contract receives a value from 'View', expect -- this view return value to be the given one.@@ -360,9 +379,9 @@   :: ( st ~ [cp]      , Eq cp, Buildable cp      , NiceStorage st-     , ToContractRef cp contract+     , ToTAddress cp addr      )-  => contract -> [cp] -> SuccessValidator+  => addr -> [cp] -> SuccessValidator lExpectViewConsumerStorage addr expected =   lExpectConsumerStorage addr (matchExpected . reverse)   where

@@ -0,0 +1,28 @@+-- | Unit tests for Lorentz.+module Lorentz.Test.Unit+    ( expectContractEntrypoints+    ) where++import Test.HUnit (Assertion, assertFailure)++import Lorentz hiding (contract)+import Michelson.Test.Unit (matchContractEntryPoints)+import Michelson.Typed (convertFullContract)++-- | Expect the given contract to have some specific entrypoints.+expectContractEntrypoints+  :: forall expectedEps contractEps st.+     ( NiceParameterFull expectedEps+     , NiceParameterFull contractEps+     , NiceStorage st+     )+  => Contract contractEps st -> Assertion+expectContractEntrypoints contract =+  withDict (niceParameterEvi @expectedEps) $+  withDict (niceParameterEvi @contractEps) $+  withDict (niceStorageEvi @st) $ do+    let entrypoints = flattenEntryPoints $ parameterEntryPointsToNotes @expectedEps+        contract' = convertFullContract . compileLorentzContract $ contract+    case matchContractEntryPoints contract' entrypoints of+      Left eps -> assertFailure $ "Some entrypoints were not found " <> show eps+      Right _ -> pass

@@ -71,14 +71,14 @@ import Util.TypeTuple import Util.Markdown --- | An entry point is described by two types: its name and type of argument.+-- | An entrypoint is described by two types: its name and type of argument. type EntryPointKind = (Symbol, Kind.Type)  -- | A convenient alias for type-level name-something pair. type (n :: Symbol) ?: (a :: k) = '(n, a)  -- | Encapsulates parameter for one of entry points.--- It keeps entry point name and corresponding argument serialized.+-- It keeps entrypoint name and corresponding argument serialized. -- -- In Haskell world, we keep an invariant of that contained value relates -- to one of entry points from @entries@ list.@@ -112,7 +112,7 @@ -- Common type-level stuff ---------------------------------------------------------------------------- --- | Get type of entry point argument by its name.+-- | Get type of entrypoint argument by its name. type family LookupEntryPoint (name :: Symbol) (entries :: [EntryPointKind])              :: Kind.Type where   LookupEntryPoint name ('(name, a) ': _) = a@@ -125,7 +125,7 @@ type family RequireUniqueEntryPoints (entries :: [EntryPointKind])              :: Constraint where   RequireUniqueEntryPoints entries =-    RequireAllUnique "entry point" (Fcf.Eval (Fcf.Map Fcf.Fst entries))+    RequireAllUnique "entrypoint" (Fcf.Eval (Fcf.Map Fcf.Fst entries))  ---------------------------------------------------------------------------- -- Construction@@ -241,12 +241,12 @@ -- | Implementations of some entry points. -- -- Note that this thing inherits properties of 'Rec', e.g. you can--- @Data.Vinyl.Core.rappend@ implementations for two entry point sets+-- @Data.Vinyl.Core.rappend@ implementations for two entrypoint sets -- when assembling scattered parts of a contract. type EntryPointsImpl inp out entries =   Rec (CaseClauseU inp out) entries --- | An action invoked when user-provided entry point is not found.+-- | An action invoked when user-provided entrypoint is not found. type UParamFallback inp out = ((MText, ByteString) : inp) :-> out  -- | Default implementation for 'UParamFallback', simply reports an error.@@ -259,7 +259,7 @@   -- | Pattern-match on given @UParam entries@.   --   -- You have to provide all case branches and a fallback action on case-  -- when entry point is not found.+  -- when entrypoint is not found.   --   -- This function is unsafe because it does not make sure at type-level   -- that entry points' names do not repeat.@@ -289,7 +289,7 @@ -- | Pattern-match on given @UParam entries@. -- -- You have to provide all case branches and a fallback action on case--- when entry point is not found.+-- when entrypoint is not found. caseUParam   :: (CaseUParam entries, RequireUniqueEntryPoints entries)   => Rec (CaseClauseU inp out) entries@@ -397,7 +397,9 @@ instance Typeable interface => TypeHasDoc (UParam interface) where   typeDocName _ = "Upgradable parameter"   typeDocMdReference p = customTypeDocMdReference ("UParam", DType p) []-  typeDocMdDescription = "<UParam description>"+  typeDocMdDescription =+    "This type encapsulates parameter for one of entry points. \+    \It keeps entry point name and corresponding argument serialized."   typeDocHaskellRep = homomorphicTypeDocHaskellRep   typeDocMichelsonRep = homomorphicTypeDocMichelsonRep @@ -407,7 +409,7 @@   let ctor = build $ symbolValT' @ctorName   in ParamBuildingStep       { pbsEnglish =-          "Wrap into *UParam* as " <> mdTicked ctor <> " entry point."+          "Wrap into *UParam* as " <> mdTicked ctor <> " entrypoint."       , pbsHaskell =           \a -> "mkUParam #" <> ctor <> " (" <> a <> ")"       , pbsMichelson =

@@ -236,7 +236,7 @@       -> (ByteString, ByteString)       -> Either Text (UStoreContent, Map k v)     parseEntry (entries, !acc) entry@(key, val) =-      case lUnpackValue key of+      case lUnpackValue @(UStoreSubmapKey _) key of         Left _ -> Right (entry : entries, acc)         Right (name :: MText, keyValue :: k)           | toText name /= toText (symbolVal $ Proxy @fieldName) ->@@ -263,7 +263,8 @@       -- or       -- TODO: add necessary rules to optimizer       L.push v # L.pack # L.some #-      L.push k # L.push (fieldNameToMText @fieldName) # L.pair # L.pack #+      L.push k # L.push (fieldNameToMText @fieldName) # L.pair #+      L.pack @(UStoreSubmapKey _) #       L.update  -- | Case of 'UStoreField'.@@ -271,7 +272,7 @@          GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3)                                   (G.Rec0 (UStoreFieldExt m v))) where   gUstoreToVal (G.M1 (G.K1 (UStoreField val))) =-    one ( mkFieldMarkerUKey @m (fromLabel @fieldName)+    one ( mkFieldMarkerUKeyL @m (fromLabel @fieldName)         , lPackValue val         ) @@ -299,7 +300,7 @@       -- TODO: make optimizer compress this to @push (Just $ lPackValue val)@       L.push val # L.pack # L.some # -      L.push (mkFieldMarkerUKey @m (fromLabel @fieldName)) #+      L.push (mkFieldMarkerUKeyL @m (fromLabel @fieldName)) #       L.update  -- Examples

@@ -65,7 +65,7 @@   :: forall (field :: Symbol) k s.      (KnownSymbol field, NicePackedValue k)   => (k : s) :-> (ByteString : s)-packSubMapUKey = push submapName # pair # pack+packSubMapUKey = push submapName # pair # pack @(UStoreSubmapKey _)   where     submapName = fieldNameToMText @field 

@@ -162,7 +162,6 @@   typeDocMdReference tp = customTypeDocMdReference ("MigrationScript", DType tp) []   typeDocHaskellRep = homomorphicTypeDocHaskellRep   typeDocMichelsonRep = homomorphicTypeDocMichelsonRep-  typeDocDependencies = typeDocDependencies . unwrappedP  instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) =>          MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2

@@ -10,7 +10,10 @@      -- ** Extras   , KnownUStoreMarker (..)+  , mkFieldMarkerUKeyL   , mkFieldUKey+  , UStoreSubmapKey+  , UStoreSubmapKeyT      -- ** Type-lookup-by-name   , GetUStoreKey@@ -42,8 +45,10 @@ import Lorentz.Pack import Lorentz.Doc import Lorentz.Polymorphic+import Michelson.Typed.T import Michelson.Typed.Haskell.Value import Lorentz.UStore.Common+import Lorentz.Value import Util.Type  -- | Gathers multple fields and 'BigMap's under one object.@@ -92,12 +97,19 @@   typeDocName _ = "Upgradeable storage"   typeDocMdDescription =     "Storage with not hardcoded structure, which allows upgrading the contract \-    \in place."+    \in place. UStore is capable of storing simple fields and multiple submaps. \+    \For simple fields key is serialized field name. For submap element big_map \+    \key is serialized `(submapName, keyValue)`."   typeDocMdReference tp =     customTypeDocMdReference ("UStore", DType tp) []   typeDocHaskellRep = homomorphicTypeDocHaskellRep   typeDocMichelsonRep = homomorphicTypeDocMichelsonRep +-- | What do we serialize when constructing big_map key for accessing+-- an UStore submap.+type UStoreSubmapKey k = (MText, k)+type UStoreSubmapKeyT k = 'TPair (ToT MText) k+ -- Extra attributes of fields ---------------------------------------------------------------------------- @@ -105,9 +117,9 @@ -- Useful to avoid collisions. class KnownUStoreMarker (marker :: UStoreMarkerType) where   -- | By field name derive key under which field should be stored.-  mkFieldMarkerUKey :: KnownSymbol name => Label name -> ByteString-  default mkFieldMarkerUKey :: KnownSymbol name => Label name -> ByteString-  mkFieldMarkerUKey (_ :: Label field) = lPackValue $ fieldNameToMText @field+  mkFieldMarkerUKey :: MText -> ByteString+  default mkFieldMarkerUKey :: MText -> ByteString+  mkFieldMarkerUKey = lPackValue    -- | Display type-level information about UStore field with given marker and   -- field value type.@@ -115,13 +127,21 @@   type ShowUStoreField marker v :: ErrorMessage   type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v --- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store type and--- name of entry.+-- | Version of 'mkFieldMarkerUKey' which accepts label.+mkFieldMarkerUKeyL+  :: forall marker field.+     (KnownUStoreMarker marker, KnownSymbol field)+  => Label field -> ByteString+mkFieldMarkerUKeyL _ =+  mkFieldMarkerUKey @marker (fieldNameToMText @field)++-- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store template+-- and name of entry. mkFieldUKey-  :: forall (store :: Kind.Type) name.-     (KnownSymbol name, KnownUStoreMarker (GetUStoreFieldMarker store name))-  => Label name -> ByteString-mkFieldUKey = mkFieldMarkerUKey @(GetUStoreFieldMarker store name)+  :: forall (store :: Kind.Type) field.+     (KnownSymbol field, KnownUStoreMarker (GetUStoreFieldMarker store field))+  => Label field -> ByteString+mkFieldUKey = mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)  instance KnownUStoreMarker UMarkerPlainField where 

@@ -1,6 +1,33 @@ -- | Re-exports typed Value, CValue, some core types, some helpers and -- defines aliases for constructors of typed values.+-- +{-+TODO [TM-280]: Move this mess somewhere (in the last MR)++This module also introduces several types for safe work with @address@ and+@contract@ types, all available types for that are represented in the following+table:+++------------------------+------------+-------------------+----------------------++| Type                   | Type safe? | What it refers to | Michelson reflection |++========================+============+===================+======================++| Address                | No         | Whole contract    | address              |++------------------------+------------+-------------------+----------------------++| EpAddress              | No         | Entrypoint        | address              |++------------------------+------------+-------------------+----------------------++| TAddress               | Yes        | Whole contract    | address              |++------------------------+------------+-------------------+----------------------++| FutureContract         | Yes        | Entrypoint        | address              |++------------------------+------------+-------------------+----------------------++| ContractRef            | Yes        | Entrypoint        | contract             |++------------------------+------------+-------------------+----------------------+++This module also provides functions for converting between this types in Haskell+world.+In Michelson world, you can use coercions and dedicated instructions from+"Lorentz.Instr".+-} module Lorentz.Value   ( Value   , IsoValue (..)@@ -28,6 +55,7 @@   , Maybe (..)   , List   , ContractRef (..)+  , TAddress (..)   , FutureContract (..)    , M.EpName@@ -44,8 +72,10 @@      -- * Conversions   , M.coerceContractRef-  , embodyFutureContract+  , callingTAddress+  , callingDefTAddress   , ToAddress (..)+  , ToTAddress (..)   , ToContractRef (..)   , FromContractRef (..)   , convertContractRef@@ -56,6 +86,7 @@   ) where  import Data.Default (Default(..))+import Data.Type.Bool (type (&&), Not) import Data.Kind as Kind import Data.Vinyl.Derived (Label(..)) @@ -65,39 +96,71 @@   (ContractRef(..), EntryPointCall, IsoCValue(..), IsoValue(..), SomeEntryPointCall, Value) import qualified Michelson.Typed as M import Michelson.Typed.CValue (CValue(..))+import qualified Lorentz.EntryPoints.Core as Ep import Michelson.Typed.EntryPoints (EpAddress(..)) import Tezos.Address (Address) import Tezos.Core   (ChainId, Mutez, Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampQuote, toMutez) import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Util.TypeLits+import Util.Type  type List = [] --- | Address associated with the contract of given type.------ Places where 'ContractAddr' can appear are now severely limited,--- this type gives you type-safety of 'ContractAddr' but still can be used everywhere.------ This may be refer to specific entrypoint of the contract, in such case--- type parameter @p@ stands for argument of that entrypoint like in--- 'ContractAddr'.+-- TODO (this MR): Add appropriate 'CanCastTo' instances++-- | Address which remembers the parameter type of the contract it refers to. ----- You still cannot be sure that the referred contract exists though.-newtype FutureContract p = FutureContract { futureContractAddress :: EpAddress }+-- It differs from Michelson's @contract@ type because it cannot contain+-- entrypoint, and it always refers to entire contract parameter even if this+-- contract has explicit default entrypoint.+newtype TAddress p = TAddress { unTAddress :: Address }   deriving stock Generic   deriving anyclass IsoValue --- | Turn future contract into actual @contract@.-embodyFutureContract-  :: forall arg.-     (NiceParameter arg, HasCallStack)-  => FutureContract arg -> ContractRef arg-embodyFutureContract (FutureContract (EpAddress addr M.DefEpName)) =-  withDict (niceParameterEvi @arg) $ ContractRef addr def-embodyFutureContract _ =-  -- TODO [TM-280]: implement-  error "not implemented for specific entrypoints"+-- | Turn 'TAddress' to 'ContractRef' in /Haskell/ world.+--+-- This is an analogy of @address@ to @contract@ convertion in Michelson world,+-- thus you have to supply an entrypoint (or call the default one explicitly).+callingTAddress+  :: forall cp mname.+     (NiceParameterFull cp)+  => TAddress cp+  -> Ep.EntryPointRef mname+  -> ContractRef (Ep.GetEntryPointArgCustom cp mname)+callingTAddress (TAddress addr) epRef =+  withDict (niceParameterEvi @cp) $+  case Ep.parameterEntryPointCallCustom @cp epRef of+    epc@M.EntryPointCall{} -> ContractRef addr (M.SomeEpc epc) +-- | Specification of 'callTAddress' to call the default entrypoint.+callingDefTAddress+  :: forall cp.+     (NiceParameterFull cp)+  => TAddress cp+  -> ContractRef (Ep.GetDefaultEntryPointArg cp)+callingDefTAddress taddr = callingTAddress taddr Ep.CallDefault++-- | Address associated with value of @contract arg@ type.+--+-- Places where 'ContractRef' can appear are now severely limited,+-- this type gives you type-safety of 'ContractRef' but still can be used+-- everywhere.+-- This type is not a full-featured one rather a helper; in particular, once+-- pushing it on stack, you cannot return it back to Haskell world.+--+-- Note that it refers to an entrypoint of the contract, not just the contract+-- as a whole. In this sense this type differs from 'TAddress'.+--+-- Unlike with 'ContractRef', having this type you still cannot be sure that+-- the referred contract exists and need to perform a lookup before calling it.+newtype FutureContract arg = FutureContract { unFutureContract :: ContractRef arg }++instance IsoValue (FutureContract arg) where+  type ToT (FutureContract arg) = ToT EpAddress+  toVal (FutureContract contract) = toVal $ M.contractRefToAddr contract+  fromVal = error "Fetching 'FutureContract' back from Michelson is impossible"+ -- | Convert something to 'Address' in /Haskell/ world. -- -- Use this when you want to access state of the contract and are not interested@@ -111,12 +174,26 @@ instance ToAddress EpAddress where   toAddress = eaAddress +instance ToAddress (TAddress cp) where+  toAddress = unTAddress+ instance ToAddress (FutureContract cp) where-  toAddress = toAddress . futureContractAddress+  toAddress = toAddress . unFutureContract  instance ToAddress (ContractRef cp) where   toAddress = crAddress +-- | Convert something referring to a contract (not specific entrypoint)+-- to 'TAddress' in /Haskell/ world.+class ToTAddress (cp :: Kind.Type) (a :: Kind.Type) where+  toTAddress :: a -> TAddress cp++instance ToTAddress cp Address where+  toTAddress = TAddress++instance (cp ~ cp') => ToTAddress cp (TAddress cp') where+  toTAddress = id+ -- | Convert something to 'ContractRef' in /Haskell/ world. class ToContractRef (cp :: Kind.Type) (contract :: Kind.Type) where   toContractRef :: HasCallStack => contract -> ContractRef cp@@ -125,33 +202,46 @@   toContractRef = id  instance (NiceParameter cp, cp ~ cp') => ToContractRef cp (FutureContract cp') where-  toContractRef = embodyFutureContract--instance (NiceParameter cp) => ToContractRef cp EpAddress where-  toContractRef = embodyFutureContract . FutureContract+  toContractRef = unFutureContract --- | Make contract ref calling the default entrypoint.-instance (NiceParameter cp) => ToContractRef cp Address where-  toContractRef addr = toContractRef $ EpAddress addr def+instance ( FailWhen cond msg+         , cond ~+            ( Ep.CanHaveEntryPoints cp &&+              Not (Ep.ParameterEntryPointsDerivation cp == Ep.EpdNone)+            )+         , msg ~+            ( 'Text "Cannot apply `ToContractRef` to `TAddress`" ':$$:+              'Text "Consider using call(Def)TAddress first`" ':$$:+              'Text "(or if you know your parameter type is primitive," ':$$:+              'Text " make sure typechecker also knows about that)" ':$$:+              'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"+            )+         , cp ~ arg, NiceParameter arg+           -- These constraints should naturally derive from ones above,+           -- but prooving that does not worth the effort+         , NiceParameterFull cp, Ep.GetDefaultEntryPointArg cp ~ cp+         ) =>+         ToContractRef arg (TAddress cp) where+  toContractRef = callingDefTAddress  -- | Convert something from 'ContractAddr' in /Haskell/ world. class FromContractRef (cp :: Kind.Type) (contract :: Kind.Type) where-  fromContractAddr :: ContractRef cp -> contract+  fromContractRef :: ContractRef cp -> contract  instance (cp ~ cp') => FromContractRef cp (ContractRef cp') where-  fromContractAddr = id+  fromContractRef = id  instance (cp ~ cp') => FromContractRef cp (FutureContract cp') where-  fromContractAddr = FutureContract . fromContractAddr+  fromContractRef = FutureContract . fromContractRef  instance FromContractRef cp EpAddress where-  fromContractAddr (ContractRef addr sepc) = EpAddress addr (M.sepcName sepc)+  fromContractRef = M.contractRefToAddr  instance FromContractRef cp Address where-  fromContractAddr = eaAddress . fromContractAddr+  fromContractRef = crAddress  convertContractRef   :: forall cp contract2 contract1.      (ToContractRef cp contract1, FromContractRef cp contract2)   => contract1 -> contract2-convertContractRef = fromContractAddr @cp . toContractRef+convertContractRef = fromContractRef @cp . toContractRef

@@ -35,15 +35,6 @@    on this module. -} --- | Version of '#' which performs some optimizations immediatelly.--- Need it here at least because we don't want to surround--- @fromVal (Lambda i o)@ with nops.-(##) :: (a :-> b) -> (b :-> c) -> (a :-> c)-l ## r = case (l, r) of-  (I Nop, I x) -> I x-  (I x, I Nop) -> I x-  _ -> l # r- instance ZipInstr '[] where   type ZippedStack '[] = ()   zipInstr = I UNIT

@@ -21,8 +21,11 @@      -- * Utilities   , forEachContractLayer+  , forEachContractDocItem   ) where +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)@@ -120,6 +123,12 @@   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 ---------------------------------------------------------------------------- @@ -161,13 +170,33 @@         Just ds@(_ :| _ : _) ->           let txts = ds <&> \(DDescription txt) -> txt           in assertFailure . fmt $-             nameF "Found multiple adjacent descriptions" (blockListF txts)+             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+ -- | Base properties which should comply for all documentations. testDocBasic :: [DocTest] testDocBasic =   [ testContractNameAtTop   , testDocNotEmpty   , testNoAdjacentDescriptions+  , testDescriptionsAreWellFormatted   ]

@@ -5,6 +5,8 @@   , typicalFailWithTag   , isTypicalFailWith   , modifyTypicalFailWith++  , ConstantScope'   ) where  import Data.Singletons (sing)@@ -73,9 +75,11 @@ -- | If given instruction ends with a typical 'FAILWITH' usage, modify -- the tag used there using given transformation function. It can -- return any value, not necessarily a string.-modifyTypicalFailWith ::-  (HasCallStack, ConstantScope t, Typeable t) =>-  (MText -> Value t) -> Instr inp out -> Instr inp out+modifyTypicalFailWith+  :: HasCallStack+  => (MText -> SomeConstrainedValue ConstantScope')+  -> Instr inp out+  -> Instr inp out modifyTypicalFailWith f = modifyTypicalFailWith' . linearizeLeft   where     modifyTypicalFailWith' :: HasCallStack => Instr inp out -> Instr inp out@@ -94,15 +98,19 @@               , _ :: Instr (b ': s) ('TPair a b ': s) <- i1 ->                 case sing @('TPair a b) of                   STPair {} -> case isStringValue v of-                    Just str -> PUSH (f str) `Seq` PAIR `Seq` FAILWITH-                    Nothing -> PUSH v `Seq` PAIR `Seq` FAILWITH+                    Just (f -> SomeConstrainedValue v') ->+                      PUSH v' `Seq` PAIR `Seq` FAILWITH+                    Nothing ->+                      PUSH v `Seq` PAIR `Seq` FAILWITH             Seq (Seq i0 (PUSH v)) PAIR               | _ :: Value a <- v               , _ :: Instr s0 ('TPair a b ': s) <- i1 ->                 case sing @('TPair a b) of                   STPair {} -> Seq i0 $ case isStringValue v of-                    Just str -> PUSH (f str) `Seq` PAIR `Seq` FAILWITH-                    Nothing -> PUSH v `Seq` PAIR `Seq` FAILWITH+                    Just (f -> SomeConstrainedValue v') ->+                      PUSH v' `Seq` PAIR `Seq` FAILWITH+                    Nothing ->+                      PUSH v `Seq` PAIR `Seq` FAILWITH              _ -> Seq i1 FAILWITH @@ -111,8 +119,8 @@     onPush ::       (HasCallStack, Typeable v, ConstantScope v) => Value v -> Instr inp out     onPush v = case isTypicalErrorConstant v of-      Just (FailWithString str) -> PUSH (f str) `Seq` FAILWITH-      Just (FailWithConstantPair str (SomeConstrainedValue arg)) ->-        PUSH (VPair (f str, arg)) `Seq` FAILWITH+      Just (FailWithString (f -> SomeConstrainedValue v')) -> PUSH v' `Seq` FAILWITH+      Just (FailWithConstantPair (f -> SomeConstrainedValue v') (SomeConstrainedValue arg)) ->+        PUSH (VPair (v', arg)) `Seq` FAILWITH       Just _ -> error "Unexpected TypicalFailWith"       Nothing -> PUSH v `Seq` FAILWITH

@@ -185,7 +185,7 @@       Refl <- first UnexpectedStorageType $ eqType @st @st1       Refl <- first UnexpectedParamType   $ eqType @cp @cp1       handleContractReturn $-        interpret instr def paramV initStV env+        interpret instr epcCallRootUnsafe paramV initStV env  type ContractReturn st =   (Either MichelsonFailed ([Operation], T.Value st), InterpreterState)@@ -279,6 +279,7 @@   -> EvalOp (Rec (T.Value) out) runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r runInstr i@(InstrWithNotes _ _i1) r = runInstrImpl runInstr i r+runInstr i@(InstrWithVarNotes _ _i1) r = runInstrImpl runInstr i r runInstr i@Nop r = runInstrImpl runInstr i r runInstr i@(Nested _) r = runInstrImpl runInstr i r runInstr i r = do@@ -308,6 +309,7 @@       ) runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r' runInstrImpl runner (InstrWithNotes _ i) r = runner i r+runInstrImpl runner (InstrWithVarNotes _ i) r = runner i r runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do   let (inp, end) = rsplit @_ @_ @s r   out <- runInstrImpl runner i inp@@ -507,7 +509,7 @@       :& (VC (CvAddress resEpAddr))       :& r runInstrImpl _ IMPLICIT_ACCOUNT (VC (CvKeyHash k) :& r) =-  pure $ VContract (KeyAddress k) def :& r+  pure $ VContract (KeyAddress k) sepcPrimitive :& r runInstrImpl _ NOW r = do   ContractEnv{..} <- ask   pure $ VC (CvTimestamp ceNow) :& r@@ -578,8 +580,7 @@     }  unwrapMbKeyHash :: Maybe (T.Value ('Tc 'U.CKeyHash)) -> Maybe KeyHash-unwrapMbKeyHash (Just (T.VC (CvKeyHash keyHash))) = Just keyHash-unwrapMbKeyHash Nothing = Nothing+unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(T.VC (CvKeyHash keyHash)) -> keyHash  interpretExt :: SomeItStack -> EvalOp () interpretExt (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do

@@ -6,7 +6,9 @@   , packT'   , packValue   , packValue'-+    -- * Serializers used in morley-client+  , encodeValue'+  , packNotedT'     -- * Internals   , encodeIntPayload   ) where@@ -23,7 +25,8 @@  import Michelson.Text import Michelson.Typed-import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, TypeAnn, noAnn, renderWEAnn)+import Michelson.Untyped.Annotation+  (Annotation(..), FieldAnn, TypeAnn, VarAnn, noAnn, renderWEAnn) import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core (ChainId(..), Mutez(..), timestampToSeconds) import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), signatureToBytes)@@ -40,6 +43,9 @@ packValue' :: PackedValScope t => Value t -> ByteString packValue' = LBS.toStrict . packValue +encodeValue' :: (SingI t, HasNoOp t) => Value t -> ByteString+encodeValue' = LBS.toStrict . encodeValue+ packT' :: forall (t :: T). SingI t => ByteString packT' = LBS.toStrict $ encodeT' @t @@ -49,7 +55,15 @@ surround :: LByteString -> LByteString -> ByteString -> LByteString surround prefix suffix main = prefix <> LBS.fromStrict main <> suffix -encodeValue :: forall t. PackedValScope t => Value t -> LByteString+-- | Generic serializer.+--+-- We don't require @HasNoBigMap@ constraint here since the big_map serialization+-- is only prohibited in @PACK@ instructions, however, we still want to be able to+-- serialize big_map e.g. in order to transform typed value to low-level Micheline+-- representation.+-- TODO: Serialize chain operations properly as well since they actually also have+-- byte representation.+encodeValue :: forall t. (SingI t, HasNoOp t) => Value t -> LByteString encodeValue val = case (val, sing @t) of   (VC cval, _) -> encodeCValue cval   (VKey s, _) -> encodeBytes . LBS.fromStrict $ case s of@@ -67,16 +81,17 @@   (VSet xs, _) -> encodeList encodeCValue (toList xs)   (VContract addr sepc, _) -> encodeEpAddress $ EpAddress addr (sepcName sepc)   (VPair (v1, v2), STPair l _) ->-    case (checkOpPresence l, checkBigMapPresence l) of-      (OpAbsent, BigMapAbsent) -> "\x07\x07" <> encodeValue v1 <> encodeValue v2+    case checkOpPresence l of+      OpAbsent -> "\x07\x07" <> encodeValue v1 <> encodeValue v2   (VOr (Left v), STOr l _) ->-    case (checkOpPresence l, checkBigMapPresence l) of-      (OpAbsent, BigMapAbsent) -> "\x05\x05" <> encodeValue v+    case checkOpPresence l of+      OpAbsent -> "\x05\x05" <> encodeValue v   (VOr (Right v), STOr l _) ->-    case (checkOpPresence l, checkBigMapPresence l) of-      (OpAbsent, BigMapAbsent) -> "\x05\x08" <> encodeValue v+    case checkOpPresence l of+      OpAbsent-> "\x05\x08" <> encodeValue v   (VLam lam, _) -> encodeInstrs $ rfAnyInstr lam   (VMap m, STMap _ _) -> encodeMap m+  (VBigMap m, STBigMap _ _) -> encodeMap m  encodeCValue :: CValue t -> LByteString encodeCValue = \case@@ -115,7 +130,7 @@ encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn  -- | Encode some map.-encodeMap :: (PackedValScope v) => Map (CValue k) (Value v) -> LByteString+encodeMap :: (SingI v, HasNoOp v) => Map (CValue k) (Value v) -> LByteString encodeMap m =   encodeList (\(k, v) -> "\x07\x04" <> encodeCValue k <> encodeValue v) (Map.toList m) @@ -175,7 +190,9 @@ encodeInstr :: forall inp out. Instr inp out -> LByteString encodeInstr = \case   InstrWithNotes n a ->-    encodeNotedInstr a n+    encodeNotedInstr a n []+  InstrWithVarNotes varNotes a ->+    encodeVarNotedInstr a varNotes   FrameInstr _ i ->     encodeInstr i   Seq a b ->@@ -213,9 +230,9 @@   PAIR ->     "\x03\x42"   (AnnCAR fn) ->-    encodeWithAnns [] [fn] "\x03\x16"+    encodeWithAnns [] [fn] [] "\x03\x16"   (AnnCDR fn) ->-    encodeWithAnns [] [fn] "\x03\x17"+    encodeWithAnns [] [fn] [] "\x03\x17"   LEFT | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->     "\x05\x33" <> encodeT' @r   RIGHT | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->@@ -322,10 +339,12 @@     "\x03\x28"   INT ->     "\x03\x30"-  SELF{} ->-    error "SELF should not appear in lambda"+  SELF sepc ->+    case sepcName sepc of+      DefEpName ->  "\x03\x49"+      epName -> "\x04\x49" <> encodeEpName epName   CONTRACT ns ep | _ :: Proxy ('TOption ('TContract t) ': s) <- Proxy @out ->-    encodeWithAnns [] [epNameToRefAnn ep] $ "\x05\x55" <> encodeNotedT' @t ns+    encodeWithAnns [] [epNameToRefAnn ep] [] $ "\x05\x55" <> encodeNotedT' @t ns   TRANSFER_TOKENS ->     "\x03\x4d"   SET_DELEGATE ->@@ -371,8 +390,8 @@  -- | Iff there are non-empty annotations it increments the value's tag and -- appends the encoded annotations.-encodeWithAnns :: [TypeAnn] -> [FieldAnn] -> LByteString -> LByteString-encodeWithAnns tns fns encodedInput+encodeWithAnns :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> LByteString -> LByteString+encodeWithAnns tns fns vns encodedInput   | null encodedInput = encodedInput   | null annsList = encodedInput   | otherwise = inputIncrem <> encodedAnns@@ -380,34 +399,42 @@     trimEndNoAnn a lst = if null lst && a == noAnn then [] else a : lst     tnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] tns     fnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] fns-    annsList = tnsText <> fnsText+    vnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] vns+    annsList = tnsText <> fnsText <> vnsText     encodedAnns = encodeAsList . encodeUtf8 $ unwords annsList     inputIncrem = (1 + LBS.head encodedInput) `LBS.cons` LBS.tail encodedInput +-- | Encode an instruction with variable annotations+encodeVarNotedInstr :: Instr inp out -> NonEmpty VarAnn -> LByteString+encodeVarNotedInstr i vns = case i of+  InstrWithNotes n a -> encodeNotedInstr a n (toList vns)+  _ -> encodeWithAnns [] [] (toList vns) $ encodeInstr i+ -- | Encode an instruction with Annotations-encodeNotedInstr :: forall inp out. Instr inp out -> PackedNotes out -> LByteString-encodeNotedInstr a (PackedNotes n _) = case (a, Proxy @out, n) of+encodeNotedInstr+  :: forall inp out. Instr inp out -> PackedNotes out -> [VarAnn] -> LByteString+encodeNotedInstr a (PackedNotes n _) vns = case (a, Proxy @out, n) of   (SOME, _, NTOption tn _ns) ->-    encodeWithAnns [tn] [] $ encodeInstr a+    encodeWithAnns [tn] [] vns $ encodeInstr a   (NONE, _ :: Proxy ('TOption t ': s), NTOption tn ns) ->-    encodeWithAnns [tn] [] $ "\x05\x3e" <> encodeNotedT' @t ns+    encodeWithAnns [tn] [] vns $ "\x05\x3e" <> encodeNotedT' @t ns   (UNIT, _, NTUnit tn) ->-    encodeWithAnns [tn] [] $ encodeInstr a+    encodeWithAnns [tn] [] vns $ encodeInstr a   (PAIR, _, NTPair tn fn1 fn2 _ns1 _ns2) ->-    encodeWithAnns [tn] [fn1, fn2] $ encodeInstr a+    encodeWithAnns [tn] [fn1, fn2] vns $ encodeInstr a   (LEFT, _ :: Proxy ('TOr l r ': s), NTOr tn fn1 fn2 _ns1 ns2) ->-    encodeWithAnns [tn] [fn1, fn2] $ "\x05\x33" <> encodeNotedT' @r ns2+    encodeWithAnns [tn] [fn1, fn2] vns $ "\x05\x33" <> encodeNotedT' @r ns2   (RIGHT, _ :: Proxy ('TOr l r ': s), NTOr tn fn1 fn2 ns1 _ns2) ->-    encodeWithAnns [tn] [fn1, fn2] $ "\x05\x44" <> encodeNotedT' @l ns1+    encodeWithAnns [tn] [fn1, fn2] vns $ "\x05\x44" <> encodeNotedT' @l ns1   (NIL, _ :: Proxy ('TList t ': s), NTList tn ns) ->-    encodeWithAnns [tn] [] $ "\x05\x3d" <> encodeNotedT' @t ns+    encodeWithAnns [tn] [] vns $ "\x05\x3d" <> encodeNotedT' @t ns   (EMPTY_SET, _ :: Proxy ('TSet t ': s), NTSet tn1 tn2) ->-    encodeWithAnns [tn1] [] $ "\x05\x24" <> encodeNotedT' @('Tc t) (NTc tn2)+    encodeWithAnns [tn1] [] vns $ "\x05\x24" <> encodeNotedT' @('Tc t) (NTc tn2)   (EMPTY_MAP, _ :: Proxy ('TMap k v ': s), NTMap tn1 tn2 ns) ->-    encodeWithAnns [tn1] [] $+    encodeWithAnns [tn1] [] vns $       "\x07\x23" <> encodeNotedT' @('Tc k) (NTc tn2) <> encodeNotedT' @v ns   (EMPTY_BIG_MAP, _ :: Proxy ('TBigMap k v ': s), NTBigMap tn1 tn2 ns) ->-    encodeWithAnns [tn1] [] $+    encodeWithAnns [tn1] [] vns $       "\x07\x72" <> encodeNotedT' @('Tc k) (NTc tn2) <> encodeNotedT' @v ns   (PUSH (v :: Value t), _, NTc tn) ->     "\x07\x43" <> encodeNotedT' @t (NTc tn) <> encodeValue v@@ -418,11 +445,14 @@   (CAST, _ :: Proxy (t ': s), NTc tn) ->     "\x05\x57" <> encodeNotedT' @t (NTc tn)   (UNPACK, _ :: Proxy ('TOption t ': s), NTOption tn ns) ->-    encodeWithAnns [tn] [] $ "\x05\x0d" <> encodeNotedT' @t ns+    encodeWithAnns [tn] [] vns $ "\x05\x0d" <> encodeNotedT' @t ns   -- NOTE: `CONTRACT` may be part of an `InstrWithNotes` with `NTOption`, but is   -- taken care of in `encodeInstr` anyway (because it contains the note itself)   _ -> encodeInstr a +packNotedT' :: forall (t :: T). SingI t => Notes t -> ByteString+packNotedT' = LBS.toStrict . encodeNotedT'+ encodeNotedT' :: forall (t :: T). SingI t => Notes t -> LByteString encodeNotedT' = encodeNotedST (sing @t) noAnn @@ -433,41 +463,41 @@   (STc ct, NTc tn) ->     encodeCTWithAnns (fromSingCT ct) tn fn   (STKey, NTKey tn) ->-    encodeWithAnns [tn] [fn] $ "\x03\x5c"+    encodeWithAnns [tn] [fn] [] $ "\x03\x5c"   (STUnit, NTUnit tn) ->-    encodeWithAnns [tn] [fn] $ "\x03\x6c"+    encodeWithAnns [tn] [fn] [] $ "\x03\x6c"   (STSignature, NTSignature tn) ->-    encodeWithAnns [tn] [fn] $ "\x03\x67"+    encodeWithAnns [tn] [fn] [] $ "\x03\x67"   (STChainId, NTChainId tn) ->-    encodeWithAnns [tn] [fn] $ "\x03\x74"+    encodeWithAnns [tn] [fn] [] $ "\x03\x74"   (STOption a, NTOption tn ns) ->-    encodeWithAnns [tn] [fn] $ "\x05\x63" <> encodeNotedST a noAnn ns+    encodeWithAnns [tn] [fn] [] $ "\x05\x63" <> encodeNotedST a noAnn ns   (STList a, NTList tn ns) ->-    encodeWithAnns [tn] [fn] $ "\x05\x5f" <> encodeNotedST a noAnn ns+    encodeWithAnns [tn] [fn] [] $ "\x05\x5f" <> encodeNotedST a noAnn ns   (STSet a, NTSet tn1 tn2) ->-    encodeWithAnns [tn1] [fn] $ "\x05\x66" <> encodeCTWithAnns (fromSingCT a) tn2 noAnn+    encodeWithAnns [tn1] [fn] [] $ "\x05\x66" <> encodeCTWithAnns (fromSingCT a) tn2 noAnn   (STOperation, NTOperation tn) ->-    encodeWithAnns [tn] [fn] $ "\x03\x6d"+    encodeWithAnns [tn] [fn] [] $ "\x03\x6d"   (STContract a, NTContract tn ns) ->-    encodeWithAnns [tn] [fn] $ "\x05\x5a" <> encodeNotedST a noAnn ns+    encodeWithAnns [tn] [fn] [] $ "\x05\x5a" <> encodeNotedST a noAnn ns   (STPair a b, NTPair tn fn1 fn2 ns1 ns2) ->-    encodeWithAnns [tn] [fn] $+    encodeWithAnns [tn] [fn] [] $       "\x07\x65" <> encodeNotedST a fn1 ns1 <> encodeNotedST b fn2 ns2   (STOr a b, NTOr tn fn1 fn2 ns1 ns2) ->-    encodeWithAnns [tn] [fn] $+    encodeWithAnns [tn] [fn] [] $       "\x07\x64" <> encodeNotedST a fn1 ns1 <> encodeNotedST b fn2 ns2   (STLambda a r, NTLambda tn ns1 ns2) ->-    encodeWithAnns [tn] [fn] $+    encodeWithAnns [tn] [fn] [] $       "\x07\x5e" <> encodeNotedST a noAnn ns1 <> encodeNotedST r noAnn ns2   (STMap k v, NTMap tn1 tn2 ns) ->-    encodeWithAnns [tn1] [fn] $+    encodeWithAnns [tn1] [fn] [] $       "\x07\x60" <> encodeCTWithAnns (fromSingCT k) tn2 noAnn <> encodeNotedST v noAnn ns   (STBigMap k v, NTBigMap tn1 tn2 ns) ->-    encodeWithAnns [tn1] [fn] $+    encodeWithAnns [tn1] [fn] [] $       "\x07\x61" <> encodeCTWithAnns (fromSingCT k) tn2 noAnn <> encodeNotedST v noAnn ns  encodeCTWithAnns :: CT -> TypeAnn -> FieldAnn -> LByteString-encodeCTWithAnns ct tn fn = encodeWithAnns [tn] [fn] $ encodeCT ct+encodeCTWithAnns ct tn fn = encodeWithAnns [tn] [fn] [] $ encodeCT ct  encodeT :: T -> LByteString encodeT = \case

@@ -6,15 +6,18 @@  * https://pastebin.com/8gfXaRvp -* https://gitlab.com/tezos/tezos/blob/master/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501+* https://gitlab.com/tezos/tezos/-/blob/767de2b6665ec2cc21e41e6348f8a0b369d26450/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501 -* https://github.com/tezbridge/tezbridge-crypto/blob/master/src/PsddFKi3/codec.js#L513+* https://github.com/tezbridge/tezbridge-crypto/blob/f7d93d8d04201557972e839967758cff5bbe5345/PsddFKi3/codec.js#L513  -} module Michelson.Interpret.Unpack   ( UnpackError (..)   , unpackValue   , unpackValue'+  , unpackInstr'++  , decodeContract   ) where  import Prelude hiding (EQ, Ordering(..), get)@@ -178,6 +181,12 @@     Nothing -> unknownTag what tag     Just TaggedDecoder{..} -> tdDecoder +launchGet :: Get a -> LByteString -> Either UnpackError a+launchGet decoder bs =+  case Get.runGetOrFail decoder bs of+    Left (_remainder, _offset, err) -> Left . UnpackError $ toText err+    Right (_remainder, _offset, res) -> Right res+ ---------------------------------------------------------------------------- -- Michelson serialisation ----------------------------------------------------------------------------@@ -207,10 +216,7 @@ unpackValue   :: (UnpackedValScope t)   => LByteString -> Either UnpackError (T.Value t)-unpackValue bs =-  case Get.runGetOrFail unpackDecoder bs of-    Left (_remainder, _offset, err) -> Left . UnpackError $ toText err-    Right (_remainder, _offset, res) -> Right res+unpackValue = launchGet (finalizeDecoder decodeValue)  -- | Like 'unpackValue', for strict byte array. unpackValue'@@ -218,13 +224,15 @@   => ByteString -> Either UnpackError (T.Value t) unpackValue' = unpackValue . LBS.fromStrict --- | Overall value decoder we use in @UNPACK@.-unpackDecoder-  :: (UnpackedValScope t)-  => Get (T.Value t)-unpackDecoder =-  expectTag "Packed data start" 0x05 *> decodeValue <* ensureEnd+-- | Deserialize an instruction into the given value.+unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]+unpackInstr' = launchGet (finalizeDecoder decodeOps) . LBS.fromStrict +-- | Turn composable decoder into a final decoder which will be run over data.+finalizeDecoder :: Get a -> Get a+finalizeDecoder decoder =+  expectTag "Packed data start" 0x05 *> decoder <* ensureEnd+ decodeValue   :: forall t.      (HasCallStack, UnpackedValScope t)@@ -608,6 +616,7 @@     (0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeNoAnn     (0x03, 0x47) -> SOURCE <$> decodeNoAnn     (0x03, 0x48) -> SENDER <$> decodeNoAnn+    (0x03, 0x49) -> SELF <$> decodeNoAnn <*> decodeNoAnn     (0x03, 0x54) -> ADDRESS <$> decodeNoAnn     (0x03, 0x75) -> CHAIN_ID <$> decodeNoAnn     -- Instructions with annotations from here on@@ -705,6 +714,7 @@     (0x04, 0x4A) -> STEPS_TO_QUOTA <$> decodeVAnn     (0x04, 0x47) -> SOURCE <$> decodeVAnn     (0x04, 0x48) -> SENDER <$> decodeVAnn+    (0x04, 0x49) -> decodeWithVFAnns SELF     (0x04, 0x54) -> ADDRESS <$> decodeVAnn     (0x04, 0x75) -> CHAIN_ID <$> decodeVAnn     (other1, other2) -> fail $ "Unknown instruction tag: 0x" +|

@@ -84,10 +84,11 @@   renderDoc _ _ = PP.empty  instance Buildable ParsedOp where-  build (Prim parseInstr _) = "<Prim: "+|parseInstr|+">"-  build (Mac macro _)       = "<Mac: "+|macro|+">"-  build (LMac letMacro _)   = "<LMac: "+|letMacro|+">"-  build (Seq parsedOps _)     = "<Seq: "+|parsedOps|+">"+  build = \case+    Prim parseInstr _ -> "<Prim: "+|parseInstr|+">"+    Mac macro _       -> "<Mac: "+|macro|+">"+    LMac letMacro _   -> "<LMac: "+|letMacro|+">"+    Seq parsedOps _   -> "<Seq: "+|parsedOps|+">"  ------------------------------------- -- Types produced by parser@@ -131,33 +132,34 @@   deriving stock (Eq, Show, Data, Generic)  instance Buildable Macro where-  build (TAG idx ty) = "<TAG: #"+||idx||+" from "+|toList ty|+""-  build (CASE parsedInstrs) = "<CASE: "+|toList parsedInstrs|+">"-  build (ACCESS idx size) = "<ACCESS: #"+||idx||+"/"+|size|+""-  build (SET idx size) = "<SET: #"+||idx||+"/"+|size|+""-  build (CONSTRUCT parsedInstrs) = "<CONSTRUCT: "+|toList parsedInstrs|+">"-  build (VIEW code) = "<VIEW: "+|code|+">"-  build (VOID code) = "<VOID: "+|code|+">"-  build (CMP parsedInstr carAnn) = "<CMP: "+|parsedInstr|+", "+|carAnn|+">"-  build (IFX parsedInstr parsedOps1 parsedOps2) = "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"-  build (IFCMP parsedInstr varAnn parsedOps1 parsedOps2) = "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"-  build FAIL = "FAIL"-  build (PAPAIR pairStruct typeAnn varAnn) = "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"-  build (UNPAIR pairStruct) = "<UNPAIR: "+|pairStruct|+">"-  build (CADR cadrStructs varAnn fieldAnn) = "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-  build (SET_CADR cadrStructs varAnn fieldAnn) = "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-  build (MAP_CADR cadrStructs varAnn fieldAnn parsedOps) = "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"-  build (DIIP integer parsedOps) = "<DIIP: "+|integer|+", "+|parsedOps|+">"-  build (DUUP integer varAnn) = "<DUUP: "+|integer|+", "+|varAnn|+">"-  build ASSERT = "ASSERT"-  build (ASSERTX parsedInstr) = "<ASSERTX: "+|parsedInstr|+">"-  build (ASSERT_CMP parsedInstr) = "<ASSERT_CMP: "+|parsedInstr|+">"-  build ASSERT_NONE  = "ASSERT_NONE"-  build ASSERT_SOME  = "ASSERT_SOME"-  build ASSERT_LEFT  = "ASSERT_LEFT"-  build ASSERT_RIGHT = "ASSERT_RIGHT"-  build (IF_SOME parsedOps1 parsedOps2) = "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"-  build (IF_RIGHT parsedOps1 parsedOps2) = "<IF_RIGHT: "+|parsedOps1|+", "+|parsedOps2|+">"+  build = \case+    TAG idx ty -> "<TAG: #"+||idx||+" from "+|toList ty|+""+    CASE parsedInstrs -> "<CASE: "+|toList parsedInstrs|+">"+    ACCESS idx size -> "<ACCESS: #"+||idx||+"/"+|size|+""+    SET idx size -> "<SET: #"+||idx||+"/"+|size|+""+    CONSTRUCT parsedInstrs -> "<CONSTRUCT: "+|toList parsedInstrs|+">"+    VIEW code -> "<VIEW: "+|code|+">"+    VOID code -> "<VOID: "+|code|+">"+    CMP parsedInstr carAnn -> "<CMP: "+|parsedInstr|+", "+|carAnn|+">"+    IFX parsedInstr parsedOps1 parsedOps2 -> "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"+    IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"+    FAIL -> "FAIL"+    PAPAIR pairStruct typeAnn varAnn -> "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"+    UNPAIR pairStruct -> "<UNPAIR: "+|pairStruct|+">"+    CADR cadrStructs varAnn fieldAnn -> "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+    SET_CADR cadrStructs varAnn fieldAnn -> "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+    MAP_CADR cadrStructs varAnn fieldAnn parsedOps -> "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"+    DIIP integer parsedOps -> "<DIIP: "+|integer|+", "+|parsedOps|+">"+    DUUP integer varAnn -> "<DUUP: "+|integer|+", "+|varAnn|+">"+    ASSERT -> "ASSERT"+    ASSERTX parsedInstr -> "<ASSERTX: "+|parsedInstr|+">"+    ASSERT_CMP parsedInstr -> "<ASSERT_CMP: "+|parsedInstr|+">"+    ASSERT_NONE  -> "ASSERT_NONE"+    ASSERT_SOME  -> "ASSERT_SOME"+    ASSERT_LEFT  -> "ASSERT_LEFT"+    ASSERT_RIGHT -> "ASSERT_RIGHT"+    IF_SOME parsedOps1 parsedOps2 -> "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"+    IF_RIGHT parsedOps1 parsedOps2 -> "<IF_RIGHT: "+|parsedOps1|+", "+|parsedOps2|+">"  expandList :: [ParsedOp] -> [ExpandedOp] expandList = fmap (expand [])@@ -407,16 +409,17 @@ mapLeaves fs p = evalState (leavesST p) fs  leavesST :: PairStruct -> State [(VarAnn, FieldAnn)] PairStruct-leavesST (P l r) = do-  l' <- leavesST l-  r' <- leavesST r-  return $ P l' r'-leavesST (F _) = do-  f <- state getLeaf-  return $ F f-  where-    getLeaf (a:as) = (a, as)-    getLeaf _      = ((noAnn, noAnn), [])+leavesST = \case+  (P l r) -> do+    l' <- leavesST l+    r' <- leavesST r+    return $ P l' r'+  (F _) -> do+    f <- state getLeaf+    return $ F f+    where+      getLeaf (a:as) = (a, as)+      getLeaf _      = ((noAnn, noAnn), [])  deriveJSON defaultOptions ''ParsedOp deriveJSON defaultOptions ''LetMacro

@@ -28,6 +28,9 @@    -- * Quoters   , utypeQ++  -- * Re-exports+  , errorBundlePretty   ) where  import Prelude hiding (try)

@@ -23,12 +23,14 @@   | WrongTagArgs Natural Positive   | WrongAccessArgs Natural Positive   | WrongSetArgs Natural Positive+  | ExcessFieldAnnotation   deriving stock (Eq, Data, Ord, Show)  instance ShowErrorComponent CustomParserException where   showErrorComponent UnknownTypeException = "unknown type"   showErrorComponent (StringLiteralException e) = showErrorComponent e   showErrorComponent OddNumberBytesException = "odd number bytes"+  showErrorComponent ExcessFieldAnnotation = "excess field annotation"   showErrorComponent (WrongTagArgs idx size) =     "TAG: too large index: " +| idx |+ " \            \exceedes union size " +| size |+ ""

@@ -24,14 +24,14 @@ extInstr opsParser = choice [stackOp, testAssertOp opsParser, printOp]  stackOp :: Parser ParsedUExtInstr-stackOp = symbol' "STACKTYPE" >> U.STACKTYPE <$> stackType+stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType  testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr testAssertOp opsParser =-  symbol' "TEST_ASSERT" >> U.UTEST_ASSERT <$> testAssert opsParser+  word' "TEST_ASSERT" U.UTEST_ASSERT <*> testAssert opsParser  printOp :: Parser ParsedUExtInstr-printOp = symbol' "PRINT" >> U.UPRINT <$> printComment+printOp = word' "PRINT" U.UPRINT <*> printComment  testAssert :: Parser [ParsedOp] -> Parser (U.TestAssert ParsedOp) testAssert opsParser = do@@ -57,8 +57,8 @@ stackType :: Parser U.StackTypePattern stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)   where-    emptyStk = try $ symbol "]" >> return U.StkEmpty-    stkRest = try $ symbol "..." >> symbol "]" >> return U.StkRest+    emptyStk = try $ symbol "]" $> U.StkEmpty+    stkRest = try $ symbol "..." >> symbol "]" $> U.StkRest     stkCons = try $ do       t <- tyVar       s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk

@@ -12,7 +12,7 @@ import qualified Text.Megaparsec as P import Text.Megaparsec.Char.Lexer (decimal) -import Michelson.Parser.Lexer (parens, symbol')+import Michelson.Parser.Lexer (parens, word') import Michelson.Parser.Types (Parser) import Util.Positive @@ -29,7 +29,7 @@  -- | Make a parser from a string mkParser :: (a -> Text) -> a -> Parser a-mkParser f a = (P.try $ symbol' (f a)) >> return a+mkParser f a = P.try $ word' (f a) a  -- | Apply given parser and return default value if it fails. parseDef :: Default a => Parser a -> Parser a

@@ -47,19 +47,19 @@ -- Control Structures  failWithOp :: Parser ParsedInstr-failWithOp = do symbol' "FAILWITH"; return FAILWITH+failWithOp = word' "FAILWITH" FAILWITH  loopOp :: Parser ParsedOp -> Parser ParsedInstr-loopOp opParser = do void $ symbol' "LOOP"; LOOP <$> ops' opParser+loopOp opParser = word' "LOOP" LOOP <*> ops' opParser  loopLOp :: Parser ParsedOp -> Parser ParsedInstr-loopLOp opParser = do void $ symbol' "LOOP_LEFT"; LOOP_LEFT <$> ops' opParser+loopLOp opParser = word' "LOOP_LEFT" LOOP_LEFT <*> ops' opParser  execOp :: Parser ParsedInstr-execOp = do void $ symbol' "EXEC"; EXEC <$> noteDef+execOp = word' "EXEC" EXEC <*> noteDef  applyOp :: Parser ParsedInstr-applyOp = do void $ symbol' "APPLY"; APPLY <$> noteDef+applyOp = word' "APPLY" APPLY <*> noteDef  -- Parses both `DIP` and `DIP n`. dipOp :: Parser ParsedOp -> Parser ParsedInstr@@ -78,16 +78,16 @@ dropOp = parseWithOptionalParameter "DROP" DROPN DROP  dupOp :: Parser ParsedInstr-dupOp = do void $ symbol' "DUP"; DUP <$> noteDef+dupOp = word' "DUP" DUP <*> noteDef  swapOp :: Parser ParsedInstr-swapOp = do symbol' "SWAP"; return SWAP;+swapOp = word' "SWAP" SWAP;  digOp :: Parser ParsedInstr-digOp = symbol' "DIG" *> (DIG <$> lexeme L.decimal)+digOp = word' "DIG" DIG <*> lexeme L.decimal  dugOp :: Parser ParsedInstr-dugOp = symbol' "DUG" *> (DUG <$> lexeme L.decimal)+dugOp = word' "DUG" DUG <*> lexeme L.decimal  pushOp :: Parser ParsedOp -> Parser ParsedInstr pushOp opParser = do@@ -106,8 +106,7 @@  lambdaOp :: Parser ParsedOp -> Parser ParsedInstr lambdaOp opParser =-  symbol' "LAMBDA" *>-  (LAMBDA <$> noteDef <*> type_ <*> type_ <*> ops' opParser)+  word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser  -- Generic comparison @@ -115,77 +114,77 @@ cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp  eqOp :: Parser ParsedInstr-eqOp = do void $ symbol' "EQ"; EQ <$> noteDef+eqOp = word' "EQ" EQ <*> noteDef  neqOp :: Parser ParsedInstr-neqOp = do void $ symbol' "NEQ"; NEQ <$> noteDef+neqOp = word' "NEQ" NEQ <*> noteDef  ltOp :: Parser ParsedInstr-ltOp = do void $ symbol' "LT"; LT <$> noteDef+ltOp = word' "LT" LT <*> noteDef  gtOp :: Parser ParsedInstr-gtOp = do void $ symbol' "GT"; GT <$> noteDef+gtOp = word' "GT" GT <*> noteDef  leOp :: Parser ParsedInstr-leOp = do void $ symbol' "LE"; LE <$> noteDef+leOp = word' "LE" LE <*> noteDef  geOp :: Parser ParsedInstr-geOp = do void $ symbol' "GE"; GE <$> noteDef+geOp = word' "GE" GE <*> noteDef  -- ad-hoc comparison  compareOp :: Parser ParsedInstr-compareOp = do void $ symbol' "COMPARE"; COMPARE <$> noteDef+compareOp = word' "COMPARE" COMPARE <*> noteDef  -- Operations on booleans  orOp :: Parser ParsedInstr-orOp = do void $ symbol' "OR";  OR <$> noteDef+orOp = word' "OR"  OR <*> noteDef  andOp :: Parser ParsedInstr-andOp = do void $ symbol' "AND"; AND <$> noteDef+andOp = word' "AND" AND <*> noteDef  xorOp :: Parser ParsedInstr-xorOp = do void $ symbol' "XOR"; XOR <$> noteDef+xorOp = word' "XOR" XOR <*> noteDef  notOp :: Parser ParsedInstr-notOp = do void $ symbol' "NOT"; NOT <$> noteDef+notOp = word' "NOT" NOT <*> noteDef  -- Operations on integers and natural numbers  addOp :: Parser ParsedInstr-addOp = do void $ symbol' "ADD"; ADD <$> noteDef+addOp = word' "ADD" ADD <*> noteDef  subOp :: Parser ParsedInstr-subOp = do void $ symbol' "SUB"; SUB <$> noteDef+subOp = word' "SUB" SUB <*> noteDef  mulOp :: Parser ParsedInstr-mulOp = do void $ symbol' "MUL"; MUL <$> noteDef+mulOp = word' "MUL" MUL <*> noteDef  edivOp :: Parser ParsedInstr-edivOp = do void $ symbol' "EDIV";EDIV <$> noteDef+edivOp = word' "EDIV"EDIV <*> noteDef  absOp :: Parser ParsedInstr-absOp = do void $ symbol' "ABS"; ABS <$> noteDef+absOp = word' "ABS" ABS <*> noteDef  negOp :: Parser ParsedInstr-negOp = do void $ symbol' "NEG"; NEG <$> noteDef+negOp = word' "NEG" NEG <*> noteDef  -- Bitwise logical operators  lslOp :: Parser ParsedInstr-lslOp = do void $ symbol' "LSL"; LSL <$> noteDef+lslOp = word' "LSL" LSL <*> noteDef  lsrOp :: Parser ParsedInstr-lsrOp = do void $ symbol' "LSR"; LSR <$> noteDef+lsrOp = word' "LSR" LSR <*> noteDef  -- Operations on string's  concatOp :: Parser ParsedInstr-concatOp = do void $ symbol' "CONCAT"; CONCAT <$> noteDef+concatOp = word' "CONCAT" CONCAT <*> noteDef  sliceOp :: Parser ParsedInstr-sliceOp = do void $ symbol' "SLICE"; SLICE <$> noteDef+sliceOp = word' "SLICE" SLICE <*> noteDef  -- Operations on pairs pairOp :: Parser ParsedInstr@@ -212,22 +211,22 @@                    EMPTY_BIG_MAP t v a <$> type_  memOp :: Parser ParsedInstr-memOp = do void $ symbol' "MEM"; MEM <$> noteDef+memOp = word' "MEM" MEM <*> noteDef  updateOp :: Parser ParsedInstr-updateOp = do void $ symbol' "UPDATE"; UPDATE <$> noteDef+updateOp = word' "UPDATE" UPDATE <*> noteDef  iterOp :: Parser ParsedOp -> Parser ParsedInstr-iterOp opParser = do void $ symbol' "ITER"; ITER <$> ops' opParser+iterOp opParser = word' "ITER" ITER <*> ops' opParser  sizeOp :: Parser ParsedInstr-sizeOp = do void $ symbol' "SIZE"; SIZE <$> noteDef+sizeOp = word' "SIZE" SIZE <*> noteDef  mapOp :: Parser ParsedOp -> Parser ParsedInstr-mapOp opParser = do symbol' "MAP"; v <- noteDef; MAP v <$> ops' opParser+mapOp opParser = word' "MAP" MAP <*>  noteDef <*> ops' opParser  getOp :: Parser ParsedInstr-getOp = do void $ symbol' "GET"; GET <$> noteDef+getOp = word' "GET" GET <*> noteDef  nilOp :: Parser ParsedInstr nilOp = do symbol' "NIL"; (t, v) <- notesTV; NIL t v <$> type_@@ -240,9 +239,7 @@   CONS <$> noteDef  ifConsOp :: Parser ParsedOp -> Parser ParsedInstr-ifConsOp opParser =-  symbol' "IF_CONS" *>-  (IF_CONS <$> ops' opParser <*> ops' opParser)+ifConsOp opParser = word' "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser  -- Operations on options @@ -253,9 +250,7 @@ noneOp = do symbol' "NONE"; (t, v) <- notesTV; NONE t v <$> type_  ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr-ifNoneOp opParser =-  symbol' "IF_NONE" *>-  (IF_NONE <$> ops' opParser <*> ops' opParser)+ifNoneOp opParser = word' "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser  -- Operations on unions @@ -268,63 +263,60 @@                RIGHT t v f f' <$> type_  ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr-ifLeftOp opParser = do-  symbol' "IF_LEFT"-  a <- ops' opParser-  IF_LEFT a <$> ops' opParser+ifLeftOp opParser = word' "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser  -- Operations on contracts  createContractOp :: Parser (Contract' ParsedOp) -> Parser ParsedInstr createContractOp contractParser =-  symbol' "CREATE_CONTRACT" *>-  (CREATE_CONTRACT <$> noteDef <*> noteDef <*> braces contractParser)+  word' "CREATE_CONTRACT" CREATE_CONTRACT+    <*> noteDef <*> noteDef <*> braces contractParser  transferTokensOp :: Parser ParsedInstr-transferTokensOp = do void $ symbol' "TRANSFER_TOKENS"; TRANSFER_TOKENS <$> noteDef+transferTokensOp = word' "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef  setDelegateOp :: Parser ParsedInstr-setDelegateOp = do void $ symbol' "SET_DELEGATE"; SET_DELEGATE <$> noteDef+setDelegateOp = word' "SET_DELEGATE" SET_DELEGATE <*> noteDef  balanceOp :: Parser ParsedInstr-balanceOp = do void $ symbol' "BALANCE"; BALANCE <$> noteDef+balanceOp = word' "BALANCE" BALANCE <*> noteDef  contractOp :: Parser ParsedInstr-contractOp = do void $ symbol' "CONTRACT"; CONTRACT <$> noteDef <*> noteDef <*> type_+contractOp = word' "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_  sourceOp :: Parser ParsedInstr-sourceOp = do void $ symbol' "SOURCE"; SOURCE <$> noteDef+sourceOp = word' "SOURCE" SOURCE <*> noteDef  senderOp :: Parser ParsedInstr-senderOp = do void $ symbol' "SENDER"; SENDER <$> noteDef+senderOp = word' "SENDER" SENDER <*> noteDef  amountOp :: Parser ParsedInstr-amountOp = do void $ symbol' "AMOUNT"; AMOUNT <$> noteDef+amountOp = word' "AMOUNT" AMOUNT <*> noteDef  implicitAccountOp :: Parser ParsedInstr-implicitAccountOp = do void $ symbol' "IMPLICIT_ACCOUNT"; IMPLICIT_ACCOUNT <$> noteDef+implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef  selfOp :: Parser ParsedInstr-selfOp = do void $ symbol' "SELF"; SELF <$> noteDef <*> noteDef+selfOp = word' "SELF" SELF <*> noteDef <*> noteDef  addressOp :: Parser ParsedInstr-addressOp = do void $ symbol' "ADDRESS"; ADDRESS <$> noteDef+addressOp = word' "ADDRESS" ADDRESS <*> noteDef  -- Special Operations  nowOp :: Parser ParsedInstr-nowOp = do void $ symbol' "NOW"; NOW <$> noteDef+nowOp = word' "NOW" NOW <*> noteDef  stepsToQuotaOp :: Parser ParsedInstr-stepsToQuotaOp = do void $ symbol' "STEPS_TO_QUOTA"; STEPS_TO_QUOTA <$> noteDef+stepsToQuotaOp = word' "STEPS_TO_QUOTA" STEPS_TO_QUOTA <*> noteDef  chainIdOp :: Parser ParsedInstr-chainIdOp = do void $ symbol' "CHAIN_ID"; CHAIN_ID <$> noteDef+chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef  -- Operations on bytes  packOp :: Parser ParsedInstr-packOp = do void $ symbol' "PACK"; PACK <$> noteDef+packOp = word' "PACK" PACK <*> noteDef  unpackOp :: Parser ParsedInstr unpackOp = do symbol' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_@@ -332,30 +324,30 @@ -- Cryptographic Primitives  checkSigOp :: Parser ParsedInstr-checkSigOp = do void $ symbol' "CHECK_SIGNATURE"; CHECK_SIGNATURE <$> noteDef+checkSigOp = word' "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef  blake2BOp :: Parser ParsedInstr-blake2BOp = do void $ symbol' "BLAKE2B"; BLAKE2B <$> noteDef+blake2BOp = word' "BLAKE2B" BLAKE2B <*> noteDef  sha256Op :: Parser ParsedInstr-sha256Op = do void $ symbol' "SHA256"; SHA256 <$> noteDef+sha256Op = word' "SHA256" SHA256 <*> noteDef  sha512Op :: Parser ParsedInstr-sha512Op = do void $ symbol' "SHA512"; SHA512 <$> noteDef+sha512Op = word' "SHA512" SHA512 <*> noteDef  hashKeyOp :: Parser ParsedInstr-hashKeyOp = do void $ symbol' "HASH_KEY"; HASH_KEY <$> noteDef+hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef  -- Type operations  castOp :: Parser ParsedInstr-castOp = do void $ symbol' "CAST"; CAST <$> noteDef <*> type_;+castOp = word' "CAST" CAST <*> noteDef <*> type_  renameOp :: Parser ParsedInstr-renameOp = do void $ symbol' "RENAME"; RENAME <$> noteDef+renameOp = word' "RENAME" RENAME <*> noteDef  isNatOp :: Parser ParsedInstr-isNatOp = do void $ symbol' "ISNAT"; ISNAT <$> noteDef+isNatOp = word' "ISNAT" ISNAT <*> noteDef  intOp :: Parser ParsedInstr-intOp = do void $ symbol' "INT"; INT <$> noteDef+intOp = word' "INT" INT <*> noteDef

@@ -3,6 +3,8 @@   , mSpace   , symbol   , symbol'+  , word+  , word'   , string'   , parens   , braces@@ -33,7 +35,13 @@ symbol = void . L.symbol mSpace  symbol' :: Text -> Parser ()-symbol' str = void $ symbol str <|> symbol (T.map toLower str)+symbol' str = symbol str <|> symbol (T.map toLower str)++word :: Tokens Text -> a -> Parser a+word str val = symbol str $> val++word' :: Tokens Text -> a -> Parser a+word' str val = symbol' str $> val  string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text string' str = string str <|> string (T.map toLower str)

@@ -28,24 +28,24 @@  macro :: Parser ParsedOp -> Parser Macro macro opParser =-      do symbol' "CASE"; is <- someNE ops; return $ CASE is-  <|> do symbol' "TAG"; tagMac-  <|> do symbol' "ACCESS"; accessMac-  <|> do symbol' "SET "; setMac-  <|> do symbol' "CONSTRUCT"; is <- someNE ops; return $ CONSTRUCT is-  <|> do symbol' "VIEW"; a <- ops; return $ VIEW a-  <|> do symbol' "VOID"; a <- ops; return $ VOID a-  <|> do symbol' "CMP"; a <- cmpOp; CMP a <$> noteDef-  <|> do void $ symbol' "IF_SOME"; IF_SOME <$> ops <*> ops-  <|> do void $ symbol' "IF_RIGHT"; IF_RIGHT <$> ops <*> ops-  <|> do symbol' "FAIL"; return FAIL-  <|> do void $ symbol' "ASSERT_CMP"; ASSERT_CMP <$> cmpOp-  <|> do symbol' "ASSERT_NONE"; return ASSERT_NONE-  <|> do symbol' "ASSERT_SOME"; return ASSERT_SOME-  <|> do symbol' "ASSERT_LEFT"; return ASSERT_LEFT-  <|> do symbol' "ASSERT_RIGHT"; return ASSERT_RIGHT-  <|> do void $ symbol' "ASSERT_"; ASSERTX <$> cmpOp-  <|> do symbol' "ASSERT"; return ASSERT+      word' "CASE" CASE <*> someNE ops+  <|> symbol' "TAG" *> tagMac+  <|> symbol' "ACCESS" *> accessMac+  <|> symbol' "SET " *> setMac+  <|> word' "CONSTRUCT" CONSTRUCT <*> someNE ops+  <|> word' "VIEW" VIEW <*> ops+  <|> word' "VOID" VOID <*> ops+  <|> word' "CMP" CMP <*> cmpOp <*> noteDef+  <|> word' "IF_SOME" IF_SOME <*> ops <*> ops+  <|> word' "IF_RIGHT" IF_RIGHT <*> ops <*> ops+  <|> word' "FAIL" FAIL+  <|> word' "ASSERT_CMP" ASSERT_CMP <*> cmpOp+  <|> word' "ASSERT_NONE" ASSERT_NONE+  <|> word' "ASSERT_SOME" ASSERT_SOME+  <|> word' "ASSERT_LEFT" ASSERT_LEFT+  <|> word' "ASSERT_RIGHT" ASSERT_RIGHT+  <|> word' "ASSERT_" ASSERTX <*> cmpOp+  <|> word' "ASSERT" ASSERT   <|> do string' "DI"; n <- num "I"; symbol' "P"; DIIP (n + 1) <$> ops   <|> do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef   <|> unpairMac@@ -66,8 +66,8 @@ pairMacInner :: Parser PairStruct pairMacInner = do   string' "P"-  l <- (string' "A" >> return (F (noAnn, noAnn))) <|> pairMacInner-  r <- (string' "I" >> return (F (noAnn, noAnn))) <|> pairMacInner+  l <- (string' "A" $> F (noAnn, noAnn)) <|> pairMacInner+  r <- (string' "I" $> F (noAnn, noAnn)) <|> pairMacInner   return $ P l r  unpairMac :: Parser Macro@@ -88,7 +88,7 @@   return $ CADR (a ++ pure b) vn fn  cadrInner :: Parser CadrStruct-cadrInner = (string' "A" >> return A) <|> (string' "D" >> return D)+cadrInner = (string' "A" $> A) <|> (string' "D" $> D)  {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} setCadrMac :: Parser Macro@@ -109,8 +109,7 @@  ifCmpMac :: Parser ParsedOp -> Parser Macro ifCmpMac opParser =-  symbol' "IFCMP" *>-  (IFCMP <$> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser)+  word' "IFCMP" IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser  tagMac :: Parser Macro tagMac = do

@@ -7,9 +7,9 @@  import Prelude hiding (many, note, some, try) -import Data.Default (Default)+import Data.Default (Default, def) import qualified Data.Map as Map-import Text.Megaparsec (choice, customFailure, try)+import Text.Megaparsec (choice, customFailure, sepBy)  import Michelson.Let (LetType(..)) import Michelson.Parser.Annotations@@ -20,20 +20,53 @@ import Michelson.Untyped import Util.Generic --- | Parse untyped Michelson 'Type` (i. e. one with annotations). type_ :: Parser Type-type_ = mparens ti <|> customFailure UnknownTypeException+type_ = snd <$> typeInner (pure noAnn)++field :: Parser (FieldAnn, Type)+field = typeInner note++t_operator :: Parser FieldAnn -> Parser (FieldAnn, Type)+t_operator fp = do+  whole <- parens do+    optional do+      ty   <- field+      rest <- optional do+        isOr <- (symbol' "|" >> return True)+            <|> (symbol' "," >> return False)+        others <- field `sepBy` symbol' if isOr then "|" else ","+        return (isOr, others)+      return (ty, rest)++  (f, t) <- fieldType fp+  case whole of+    Just (ty, Just (isOr, tys)) -> do+      let (f', Type ty' _) = mkGenericTree (mergeTwo isOr) (ty :| tys)+      f'' <- mergeAnnots f f'+      return (f'', Type ty' t)+    Just (res, _) -> do+      return res+    Nothing -> do+      return (f, Type TUnit t)   where-    ti = snd <$> (lexeme $ typeInner (pure noAnn))+    mergeTwo isOr _ (l, a) (r, b) =+      (noAnn, Type ((if isOr then TOr else TPair) l r a b) noAnn) +    mergeAnnots l r+      | l == def  = return r+      | r == def  = return l+      | otherwise = customFailure ExcessFieldAnnotation+ typeInner   :: Parser FieldAnn -> Parser (FieldAnn, Type)-typeInner fp = choice $ (\x -> x fp) <$>+typeInner fp = lexeme $ choice $ (\x -> x fp) <$>   [ t_ct, t_key, t_unit, t_signature, t_chain_id   , t_option, t_list, t_set   , t_operation, t_contract, t_pair, t_or   , t_lambda, t_map, t_big_map, t_view   , t_void, t_letType+  , t_operator+  , const (customFailure UnknownTypeException)   ]  ----------------------------------------------------------------------------@@ -41,45 +74,42 @@ ----------------------------------------------------------------------------  comparable :: Parser Comparable-comparable = let c = do ct' <- ct; Comparable ct' <$> noteDef in mparens c+comparable = mparens $ Comparable <$> ct <*> noteDef  t_ct :: (Default a) => Parser a -> Parser (a, Type) t_ct fp = do ct' <- ct; (f,t) <- fieldType fp; return (f, Type (Tc ct') t)  ct :: Parser CT-ct =  (symbol' "Int" >> return CInt)-  <|> (symbol' "Nat" >> return CNat)-  <|> (symbol' "String" >> return CString)-  <|> (symbol' "Bytes" >> return CBytes)-  <|> (symbol' "Mutez" >> return CMutez)-  <|> (symbol' "Bool" >> return CBool)-  <|> ((symbol' "KeyHash" <|> symbol "key_hash") >> return CKeyHash)-  <|> (symbol' "Timestamp" >> return CTimestamp)-  <|> (symbol' "Address" >> return CAddress)+ct =  word' "Int" CInt+  <|> word' "Nat" CNat+  <|> word' "String" CString+  <|> word' "Bytes" CBytes+  <|> word' "Mutez" CMutez+  <|> word' "Bool" CBool+  <|> word' "KeyHash" CKeyHash <|> word "key_hash" CKeyHash+  <|> word' "Timestamp" CTimestamp+  <|> word' "Address" CAddress  ---------------------------------------------------------------------------- -- Non-comparable types ---------------------------------------------------------------------------- -field :: Parser (FieldAnn, Type)-field = lexeme (mparens fi)-  where-    fi = typeInner note+mkType :: T -> (a, TypeAnn) -> (a, Type)+mkType t (a, ta) = (a, Type t ta)  t_key :: (Default a) => Parser a -> Parser (a, Type)-t_key fp = do symbol' "Key"; (f,t) <- fieldType fp; return (f, Type TKey t)+t_key fp = word' "Key" (mkType TKey) <*> fieldType fp  t_signature :: (Default a) => Parser a -> Parser (a, Type)-t_signature fp = do symbol' "Signature"; (f, t) <- fieldType fp; return (f, Type TSignature t)+t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp  t_chain_id :: (Default a) => Parser a -> Parser (a, Type) t_chain_id fp = do   symbol' "ChainId" <|> symbol' "chain_id"-  (f, t) <- fieldType fp-  return (f, Type TChainId t)+  mkType TChainId <$> fieldType fp  t_operation :: (Default a) => Parser a -> Parser (a, Type)-t_operation fp = do symbol' "Operation"; (f, t) <- fieldType fp; return (f, Type TOperation t)+t_operation fp = word' "Operation" (mkType TOperation) <*> fieldType fp  t_contract :: (Default a) => Parser a -> Parser (a, Type) t_contract fp = do@@ -90,7 +120,7 @@  t_unit :: (Default a) => Parser a -> Parser (a, Type) t_unit fp = do-  symbol' "Unit" <|> symbol "()"+  symbol' "Unit" <|> symbol' "()"   (f,t) <- fieldType fp   return (f, Type TUnit t) @@ -106,34 +136,14 @@   return (f, Type (mkPair l r a b) t)  t_pair :: (Default a) => Parser a -> Parser (a, Type)-t_pair fp = core <|> tuple-  where-    core = do-      symbol' "Pair"-      t_pair_like TPair fp-    tuple = try $ do-      (_, Type ty _) <- parens tupleInner-      (f, t) <- fieldType fp-      return (f, Type ty t)-    tupleInner = do-      fs <- sepBy2 field comma-      let mergeTwo _ (l, a) (r, b) = (noAnn, Type (TPair l r a b) noAnn)-      return $ mkGenericTree mergeTwo fs+t_pair fp = do+  symbol' "Pair"+  t_pair_like TPair fp  t_or :: (Default a) => Parser a -> Parser (a, Type)-t_or fp = core <|> bar-  where-    core = do-      symbol' "Or"-      t_pair_like TOr fp-    bar = try $ do-      (_, Type ty _) <- parens barInner-      (f, t) <- fieldType fp-      return (f, Type ty t)-    barInner = do-      fs <- sepBy2 field (symbol "|")-      let mergeTwo _ (l, a) (r, b) = (noAnn, Type (TOr l r a b) noAnn)-      return $ mkGenericTree mergeTwo fs+t_or fp = do+  symbol' "Or"+  t_pair_like TOr fp  t_option :: (Default a) => Parser a -> Parser (a, Type) t_option fp = do

@@ -74,7 +74,7 @@ -- thing that starts from 0x (at least for now) bytesLiteral :: Parser (U.Value' op) bytesLiteral = do-  symbol "0x"+  string "0x"   hexdigits <- takeWhileP Nothing Char.isHexDigit   let (bytes, remain) = B16.decode $ encodeUtf8 hexdigits   if remain == ""@@ -85,26 +85,19 @@ intLiteral = try $ U.ValueInt <$> L.signed pass L.decimal  unitValue :: Parser ParsedValue-unitValue = do symbol "Unit"; return U.ValueUnit+unitValue = word "Unit" U.ValueUnit  trueValue :: Parser ParsedValue-trueValue = do symbol "True"; return U.ValueTrue+trueValue = word "True" U.ValueTrue  falseValue :: Parser ParsedValue-falseValue = do symbol "False"; return U.ValueFalse+falseValue = word "False" U.ValueFalse  pairValue :: Parser ParsedOp -> Parser ParsedValue pairValue opParser = core <|> tuple   where-    core = do-      void $ symbol "Pair"-      a <- value' opParser-      U.ValuePair a <$> value' opParser-    tuple = try $ do-      symbol "("-      ty <- tupleInner-      symbol ")"-      return ty+    core = word "Pair" U.ValuePair <*> value' opParser <*> value' opParser+    tuple = try $ parens tupleInner     tupleInner = try $ do       a <- value' opParser       comma@@ -112,16 +105,16 @@       return $ U.ValuePair a b  leftValue :: Parser ParsedOp -> Parser ParsedValue-leftValue opParser = do void $ symbol "Left"; U.ValueLeft <$> value' opParser+leftValue opParser = word "Left" U.ValueLeft <*> value' opParser  rightValue :: Parser ParsedOp -> Parser ParsedValue-rightValue opParser = do void $ symbol "Right"; U.ValueRight <$> value' opParser+rightValue opParser = word "Right" U.ValueRight <*> value' opParser  someValue :: Parser ParsedOp -> Parser ParsedValue-someValue opParser = do void $ symbol "Some"; U.ValueSome <$> value' opParser+someValue opParser = word "Some" U.ValueSome <*> value' opParser  noneValue :: Parser ParsedValue-noneValue = U.ValueNone <$ symbol "None"+noneValue = word "None" U.ValueNone  nilValue :: Parser ParsedValue nilValue = U.ValueNil <$ (try $ braces pass)@@ -137,12 +130,11 @@   U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon)  eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)-eltValue opParser = do-  void $ symbol "Elt"-  U.Elt <$> value' opParser <*> value' opParser+eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser  mapValue :: Parser ParsedOp -> Parser ParsedValue-mapValue opParser = U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)+mapValue opParser =+  U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)  dataLetValue :: Parser ParsedValue dataLetValue = do

@@ -2,6 +2,7 @@   ( RenderDoc(..)   , Prettier(..)   , printDoc+  , printDocB   , renderOps   , renderOpsList   , spaces@@ -57,6 +58,10 @@ printDoc :: Bool -> Doc -> LT.Text printDoc oneLine = displayT . doRender oneLine +-- | Convert 'Doc' to 'Builder' in the same maner as 'printDoc'.+printDocB :: Bool -> Doc -> Builder+printDocB oneLine = displayB . doRender oneLine+ -- | Generic way to render the different op types that get passed -- to a contract. renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc@@ -88,7 +93,7 @@ -- | Turn something that is instance of `RenderDoc` into a `Builder`. -- It's formatted the same way as `printDoc` formats docs. buildRenderDoc :: RenderDoc a => a -> Builder-buildRenderDoc = displayB . doRender True . renderDoc doesntNeedParens+buildRenderDoc = printDocB True . renderDoc doesntNeedParens  -- | Here using a page width of 80 and a ribbon width of 1.0 -- https://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html

@@ -47,6 +47,7 @@   , expectStorageUpdate   , expectStorageUpdateConst   , expectBalance+  , expectStorage   , expectStorageConst   , expectGasExhaustion   , expectMichelsonFailed

@@ -27,8 +27,9 @@ 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 (assertFailure, testCase)+import Test.Tasty.HUnit (testCase)  import qualified Lorentz as L import Michelson.Parser.Error (ParserException(..))

@@ -45,6 +45,7 @@   , expectStorageUpdate   , expectStorageUpdateConst   , expectBalance+  , expectStorage   , expectStorageConst   , expectGasExhaustion   , expectMichelsonFailed@@ -145,6 +146,7 @@   | IncorrectUpdates ValidationError [GStateUpdate]   | IncorrectStorageUpdate AddressName Text   | InvalidStorage AddressName ExpectedStorage Text+  | StoragePredicateMismatch AddressName Text   | InvalidBalance AddressName ExpectedBalance Text   | UnexpectedUpdates (NonEmpty GStateUpdate)   | CustomValidationError Text@@ -164,6 +166,8 @@     "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) =@@ -373,13 +377,28 @@       GSSetStorageValue {} -> True       _ -> False +-- | Check that storage value satisfies the given predicate.+expectStorage+  :: Address+  -> (Value -> Either ValidationError ())+  -> SuccessValidator+expectStorage addr predicate is gs _ =+  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"+  where+    intro = StoragePredicateMismatch (addrToAddrName addr is)+ -- | 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+expectStorageUpdate+  :: Address   -> (Value -> Either ValidationError ())   -> SuccessValidator expectStorageUpdate addr predicate is _ updates =@@ -396,8 +415,8 @@     checkAddr _ = False  -- | Like 'expectStorageUpdate', but expects a constant.-expectStorageUpdateConst ::-     Address+expectStorageUpdateConst+  :: Address   -> Value   -> SuccessValidator expectStorageUpdateConst addr expected is =@@ -406,21 +425,16 @@     predicate val       | val == expected = pass       | otherwise = Left $-        IncorrectStorageUpdate (addrToAddrName addr is) $ pretty expected+        IncorrectStorageUpdate (addrToAddrName addr is) (pretty expected)  -- | Check that eventually address has some particular storage value. expectStorageConst :: Address -> Value -> SuccessValidator-expectStorageConst addr expected is gs _ =-  case gsAddresses gs ^. at addr of-    Just (ASContract cs)-      | csStorage cs == expected -> pass-      | otherwise ->-        Left $ intro $ "its actual storage is: " <> (pretty $ csStorage cs)-    Just (ASSimple {}) ->-      Left $ intro $ "it's a simple address"-    Nothing -> Left $ intro $ "it's unknown"+expectStorageConst addr expected is = expectStorage addr predicate is   where-    intro = InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected)+    predicate val+      | val == expected = pass+      | otherwise = Left $+        InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected) (pretty val)  -- | Check that eventually address has some particular balance. expectBalance :: Address -> Mutez -> SuccessValidator

@@ -10,7 +10,6 @@   , hasEp   ) where -import Data.Default (def) import Data.List.NonEmpty (fromList) import qualified Data.Map as Map @@ -52,6 +51,11 @@  -- | 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@@ -61,7 +65,7 @@   -> T.Value st   -> prop contractPropVal instr check env param initSt =-  check $ interpret instr def param initSt env+  check $ interpret instr T.epcCallRootUnsafe param initSt env  -- | Check if entrypoint is present in `T`. hasEp :: T -> (EpName, U.Type) -> Bool

@@ -33,10 +33,12 @@  -- | The 'Property' holds on `Left a`. qcIsLeft :: Show b => Either a b -> Property-qcIsLeft (Left _)  = property True-qcIsLeft (Right x) = failedProp $ "expected Left, got Right (" <> show x <> ")"+qcIsLeft = \case+  Left _ -> property True+  Right x -> failedProp $ "expected Left, got Right (" <> show x <> ")"  -- | The 'Property' holds on `Right b`. qcIsRight :: Show a => Either a b -> Property-qcIsRight (Right _) = property True-qcIsRight (Left x)  = failedProp $ "expected Right, got Left (" <> show x <> ")"+qcIsRight = \case+  Right _ -> property True+  Left x -> failedProp $ "expected Right, got Left (" <> show x <> ")"

@@ -47,7 +47,7 @@ -- | Michelson string value. -- -- This is basically a mere text with limits imposed by the language:--- <http://tezos.gitlab.io/zeronet/whitedoc/michelson.html#constants>+-- <https://tezos.gitlab.io/whitedoc/michelson.html#constants> -- Although, this document seems to be not fully correct, and thus we applied -- constraints deduced empirically. --

@@ -79,28 +79,29 @@   deriving stock (Show, Eq)  instance Buildable TCTypeError where-  build (AnnError e) = build e-  build (TypeEqError type1 type2) =-    "Types not equal: " +| type1 |+ " /= " +| type2 |+ ""-  build (StackEqError st1 st2) =-    "Stacks not equal: " +| buildStack st1 |+ " /= " +| buildStack st2 |+ ""-  build (UnsupportedTypes types) =-    "Unsupported types: " +| listF types |+ ""-  build (InvalidValueType t) =-    "Value type is never a valid `" +| t |+ "`"-  build (NotEnoughItemsOnStack n instr) =-    "Not enough items on stack to " +| instr |+ " " +| n |+ ""-  build (UnknownContract addr) =-    "Contract is not registered: " +| addr |+ ""-  build (IllegalEntryPoint err) = build err-  build (EntryPointNotFound ep) =-    "No such entrypoint '" +| ep |+ "'"-  build (IllegalParamDecl err) = build err-  build NegativeNat = "Natural number cannot be negative"-  build MutezOverflow = "Exceeds maximal value for mutez"-  build (InvalidAddress e) = build e-  build (InvalidKeyHash e) = build e-  build (InvalidTimestamp) = "Is not a valid RFC3339 timestamp"+  build = \case+    AnnError e -> build e+    TypeEqError type1 type2 ->+      "Types not equal: " +| type1 |+ " /= " +| type2 |+ ""+    StackEqError st1 st2 ->+      "Stacks not equal: " +| buildStack st1 |+ " /= " +| buildStack st2 |+ ""+    UnsupportedTypes types ->+      "Unsupported types: " +| listF types |+ ""+    InvalidValueType t ->+      "Value type is never a valid `" +| t |+ "`"+    NotEnoughItemsOnStack n instr ->+      "Not enough items on stack to " +| instr |+ " " +| n |+ ""+    UnknownContract addr ->+      "Contract is not registered: " +| addr |+ ""+    IllegalEntryPoint err -> build err+    EntryPointNotFound ep ->+      "No such entrypoint '" +| ep |+ "'"+    IllegalParamDecl err -> build err+    NegativeNat -> "Natural number cannot be negative"+    MutezOverflow -> "Exceeds maximal value for mutez"+    InvalidAddress e -> build e+    InvalidKeyHash e -> build e+    InvalidTimestamp -> "Is not a valid RFC3339 timestamp"  -- | Type check error data TCError

@@ -54,7 +54,7 @@ import Michelson.Typed   (CT(..), Instr(..), Notes(..), PackedNotes(..), Sing(..), T(..), converge, fromSingT, orAnn,   starNotes)-import Michelson.Typed.Annotation (AnnConvergeError)+import Michelson.Typed.Annotation (AnnConvergeError, isStar) import Michelson.Typed.Arith (Add, ArithOp(..), Mul, Sub, UnaryArithOp(..)) import Michelson.Typed.Polymorphic   (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..))@@ -303,6 +303,8 @@      wrapWithNotes :: HST d -> Instr c d -> Instr c d     wrapWithNotes h ins = case h of+      -- do not wrap in notes if the notes are "star"+      ((_, n, _) ::& _) | isStar n -> ins       ((s, n, _) ::& _) -> InstrWithNotes (PackedNotes n s) ins       SNil -> ins @@ -454,16 +456,17 @@   -> HST inp   -> VarAnn   -> m (SomeInstr inp)-addImpl SCInt SCInt = arithImpl @Add ADD-addImpl SCInt SCNat = arithImpl @Add ADD-addImpl SCNat SCInt = arithImpl @Add ADD-addImpl SCNat SCNat = arithImpl @Add ADD-addImpl SCInt SCTimestamp = arithImpl @Add ADD-addImpl SCTimestamp SCInt = arithImpl @Add ADD-addImpl SCMutez SCMutez = arithImpl @Add ADD-addImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.ADD vn) (SomeHST i)-  "wrong operand types for add operation"-  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+addImpl t1 t2 = case (t1, t2) of+  (SCInt, SCInt) -> arithImpl @Add ADD+  (SCInt, SCNat) -> arithImpl @Add ADD+  (SCNat, SCInt) -> arithImpl @Add ADD+  (SCNat, SCNat) -> arithImpl @Add ADD+  (SCInt, SCTimestamp) -> arithImpl @Add ADD+  (SCTimestamp, SCInt) -> arithImpl @Add ADD+  (SCMutez, SCMutez) -> arithImpl @Add ADD+  _ -> \i vn -> onTypeCheckInstrErr (Un.ADD vn) (SomeHST i)+    "wrong operand types for add operation"+    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  edivImpl   :: forall a b inp rs m.@@ -477,15 +480,16 @@   -> HST inp   -> VarAnn   -> m (SomeInstr inp)-edivImpl SCInt SCInt = edivImplDo-edivImpl SCInt SCNat = edivImplDo-edivImpl SCNat SCInt = edivImplDo-edivImpl SCNat SCNat = edivImplDo-edivImpl SCMutez SCMutez = edivImplDo-edivImpl SCMutez SCNat = edivImplDo-edivImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.EDIV vn) (SomeHST i)-  "wrong operand types for ediv operation"-  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+edivImpl t1 t2 = case (t1, t2) of+  (SCInt, SCInt) -> edivImplDo+  (SCInt, SCNat) -> edivImplDo+  (SCNat, SCInt) -> edivImplDo+  (SCNat, SCNat) -> edivImplDo+  (SCMutez, SCMutez) -> edivImplDo+  (SCMutez, SCNat) -> edivImplDo+  _ -> \i vn -> onTypeCheckInstrErr (Un.EDIV vn) (SomeHST i)+    "wrong operand types for ediv operation"+    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  edivImplDo   :: ( EDivOp n m@@ -514,16 +518,17 @@   -> HST inp   -> VarAnn   -> m (SomeInstr inp)-subImpl SCInt SCInt = arithImpl @Sub SUB-subImpl SCInt SCNat = arithImpl @Sub SUB-subImpl SCNat SCInt = arithImpl @Sub SUB-subImpl SCNat SCNat = arithImpl @Sub SUB-subImpl SCTimestamp SCTimestamp = arithImpl @Sub SUB-subImpl SCTimestamp SCInt = arithImpl @Sub SUB-subImpl SCMutez SCMutez = arithImpl @Sub SUB-subImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.SUB vn) (SomeHST i)-  "wrong operand types for sub operation"-  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+subImpl t1 t2 = case (t1, t2) of+  (SCInt, SCInt) -> arithImpl @Sub SUB+  (SCInt, SCNat) -> arithImpl @Sub SUB+  (SCNat, SCInt) -> arithImpl @Sub SUB+  (SCNat, SCNat) -> arithImpl @Sub SUB+  (SCTimestamp, SCTimestamp) -> arithImpl @Sub SUB+  (SCTimestamp, SCInt) -> arithImpl @Sub SUB+  (SCMutez, SCMutez) -> arithImpl @Sub SUB+  _ -> \i vn -> onTypeCheckInstrErr (Un.SUB vn) (SomeHST i)+    "wrong operand types for sub operation"+    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  mulImpl   :: forall a b inp rs m.@@ -537,15 +542,16 @@   -> HST inp   -> VarAnn   -> m (SomeInstr inp)-mulImpl SCInt SCInt = arithImpl @Mul MUL-mulImpl SCInt SCNat = arithImpl @Mul MUL-mulImpl SCNat SCInt = arithImpl @Mul MUL-mulImpl SCNat SCNat = arithImpl @Mul MUL-mulImpl SCNat SCMutez = arithImpl @Mul MUL-mulImpl SCMutez SCNat = arithImpl @Mul MUL-mulImpl _ _ = \i vn -> onTypeCheckInstrErr (Un.MUL vn) (SomeHST i)-  "wrong operand types for mul operation"-  (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+mulImpl t1 t2 = case (t1, t2) of+  (SCInt, SCInt) -> arithImpl @Mul MUL+  (SCInt, SCNat) -> arithImpl @Mul MUL+  (SCNat, SCInt) -> arithImpl @Mul MUL+  (SCNat, SCNat) -> arithImpl @Mul MUL+  (SCNat, SCMutez) -> arithImpl @Mul MUL+  (SCMutez, SCNat) -> arithImpl @Mul MUL+  _ -> \i vn -> onTypeCheckInstrErr (Un.MUL vn) (SomeHST i)+    "wrong operand types for mul operation"+    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])  -- | Helper function to construct instructions for binary arithmetic -- operations.

@@ -212,632 +212,606 @@ -- that is interpreted as input of wrong type and type check finishes with -- error. typeCheckInstr :: TcInstrHandler-typeCheckInstr (U.EXT ext) si =-  typeCheckExt typeCheckList ext si--typeCheckInstr U.DROP i@(_ ::& rs) = pure (i :/ DROP ::: rs)--typeCheckInstr uInstr@(U.DROPN nTotal) inputHST =-  go nTotal inputHST <&> \case-    TCDropHelper s out -> inputHST :/ DROPN s ::: out-  where-    go :: forall inp. Typeable inp-      => Word-      -> HST inp-      -> TypeCheckInstr (TCDropHelper inp)-    go n i = case (n, i) of-      (0, _) -> pure (TCDropHelper SZ i)--      (_, SNil) -> onTypeCheckInstrErr uInstr-        (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDrop))--      (_, (_ ::& iTail)) -> do-        go (n - 1) iTail <&> \case TCDropHelper s out -> TCDropHelper (SS s) out--typeCheckInstr (U.DUP _vn) i@(a ::& rs) =-  pure (i :/ DUP ::: (a ::& a::& rs))--typeCheckInstr U.SWAP (i@(a ::& b ::& rs)) =-  pure (i :/ SWAP ::: (b ::& a ::& rs))--typeCheckInstr uInstr@(U.DIG nTotal) inputHST =-  go nTotal inputHST <&> \case-    TCDigHelper s out -> inputHST :/ DIG s ::: out-  where-    go :: forall inp. Typeable inp-      => Word-      -> HST inp-      -> TypeCheckInstr (TCDigHelper inp)-    go n i = case (n, i) of-      -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).-      (_, SNil) -> onTypeCheckInstrErr uInstr-        (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDig))--      (0, (_ ::& _)) -> pure (TCDigHelper SZ i)--      (_, (b ::& iTail)) ->-        go (n - 1) iTail <&> \case-        TCDigHelper s (a ::& resTail) -> TCDigHelper (SS s) (a ::& b ::& resTail)--typeCheckInstr uInstr@(U.DUG nTotal) inputHST =-  go nTotal inputHST <&> \case-    TCDugHelper s out -> inputHST :/ DUG s ::: out-  where-    go :: forall inp. Typeable inp-      => Word-      -> HST inp-      -> TypeCheckInstr (TCDugHelper inp)-    go n i = case (n, i) of-      (0, (_ ::& _)) -> pure (TCDugHelper SZ i)--      (_, (a ::& b ::& iTail)) ->-        go (n - 1) (a ::& iTail) <&> \case-        TCDugHelper s resTail -> TCDugHelper (SS s) (b ::& resTail)--      -- Two cases:-      -- 1. Input stack is empty.-      -- 2. n > 0 and input stack has exactly 1 item.-      _ -> onTypeCheckInstrErr uInstr-        (SomeHST i) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDug))--typeCheckInstr instr@(U.PUSH vn mt mval) i =-  withUType mt $ \(t' :: Sing t', nt' :: Notes t') -> do-    val :::: (t :: Sing t, nt) <- typeCheckValue mval (t', nt')-    proofOp <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-             "Operations in constant are not allowed"-             $ Left $ UnsupportedTypes [demote @t])-      pure (opAbsense t)-    proofBigMap <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-             "BigMaps in constant are not allowed"-             $ Left $ UnsupportedTypes [demote @t])-      pure (bigMapAbsense t)-    proofContract <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-             "Contract type in constant is not allowed"-             $ Left $ UnsupportedTypes [demote @t])-      pure (contractTypeAbsense t)-    case (proofOp, proofBigMap, proofContract) of-      (Dict, Dict, Dict) -> pure $ i :/ PUSH val ::: ((t, nt, vn) ::& i)--typeCheckInstr (U.SOME tn vn) i@((at, an, _) ::& rs) = do-  pure (i :/ SOME ::: ((STOption at, NTOption tn an, vn) ::& rs))--typeCheckInstr (U.NONE tn vn elMt) i =-  withUType elMt $ \(elSing :: Sing t, elNotes :: Notes t) ->-    pure $ i :/ NONE ::: ((STOption elSing, NTOption tn elNotes, vn) ::& i)--typeCheckInstr (U.UNIT tn vn) i = do-  pure $ i :/ UNIT ::: ((STUnit, NTUnit tn, vn) ::& i)--typeCheckInstr (U.IF_NONE mp mq) i@((STOption a, ons, ovn) ::& rs) = do-  let (an, avn) = deriveNsOption ons ovn-  genericIf IF_NONE U.IF_NONE mp mq rs ((a, an, avn) ::& rs) i--typeCheckInstr (U.PAIR tn vn pfn qfn) i@((a, an, avn) ::&-                                             (b, bn, bvn) ::& rs) = do-  let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn-      ns = NTPair tn pfn' qfn' an bn-  pure (i :/ PAIR ::: ((STPair a b, ns, vn `orAnn` vn') ::& rs))--typeCheckInstr instr@(U.CAR vn fn)-            (i@(( STPair a b-                       , NTPair pairTN pfn qfn pns qns-                       , pairVN ) ::& rs)) = do-  pfn' <- onTypeCheckInstrAnnErr instr i "wrong car type:" (convergeAnns fn pfn)-  let vn' = deriveSpecialVN vn pfn' pairVN-      i' = ( STPair a b-           , NTPair pairTN pfn' qfn pns qns-           , pairVN ) ::& rs-  pure $ i' :/ AnnCAR fn ::: ((a, pns, vn') ::& rs)--typeCheckInstr instr@(U.CDR vn fn)-          (i@(( STPair a b-                      , NTPair pairTN pfn qfn pns qns-                      , pairVN ) ::& rs)) = do-  qfn' <- onTypeCheckInstrAnnErr instr i "wrong cdr type:" (convergeAnns fn qfn)--  let vn' = deriveSpecialVN vn qfn' pairVN-      i' = ( STPair a b-           , NTPair pairTN pfn qfn' pns qns-           , pairVN ) ::& rs-  pure $ i' :/ AnnCDR fn ::: ((b, qns, vn') ::& rs)--typeCheckInstr (U.LEFT tn vn pfn qfn bMt) i@((a, an, _) ::& rs) =-  withUType bMt $ \(b :: Sing b, bn :: Notes b) -> do-    let ns = NTOr tn pfn qfn an bn-    pure (i :/ LEFT ::: ((STOr a b, ns, vn) ::& rs))--typeCheckInstr (U.RIGHT tn vn pfn qfn aMt) i@((b, bn, _) ::& rs) =-  withUType aMt $ \(a :: Sing a, an :: Notes a) -> do-    let ns = NTOr tn pfn qfn an bn-    pure (i :/ RIGHT ::: ((STOr a b, ns, vn) ::& rs))--typeCheckInstr (U.IF_LEFT mp mq) i@((STOr a b, ons, ovn) ::& rs) = do-  let (an, bn, avn, bvn) = deriveNsOr ons ovn-      ait = (a, an, avn) ::& rs-      bit = (b, bn, bvn) ::& rs-  genericIf IF_LEFT U.IF_LEFT mp mq ait bit i--typeCheckInstr (U.NIL tn vn elMt) i =-  withUType elMt $ \(elT :: Sing elT, elNotes :: Notes elT) ->-    pure $ i :/ NIL ::: ((STList elT, NTList tn elNotes, vn) ::& i)--typeCheckInstr instr@(U.CONS vn) i@((((at :: Sing a), an, _)-                              ::& (STList (_ :: Sing a'), ln, _) ::& rs)) =-  case eqType @a @a' of-    Right Refl -> do-      n <- onTypeCheckInstrAnnErr instr i "wrong cons type:" (converge ln (NTList def an))-      pure $ i :/ CONS ::: ((STList at, n, vn) ::& rs)-    Left m -> onTypeCheckInstrErr instr (SomeHST i)-                ("list element type is different from one "-                <> "that is being CONSed:") (Left m)--typeCheckInstr (U.IF_CONS mp mq) i@((STList a, ns, vn) ::& rs)  = do-  let NTList _ an = ns-      ait =-        (a, an, vn <> "hd") ::& (STList a, ns, vn <> "tl") ::& rs-  genericIf IF_CONS U.IF_CONS mp mq ait rs i--typeCheckInstr (U.SIZE vn) i@((STList _, _, _) ::& _)  = sizeImpl i vn-typeCheckInstr (U.SIZE vn) i@((STSet _, _, _) ::& _)  = sizeImpl i vn-typeCheckInstr (U.SIZE vn) i@((STMap _ _, _, _) ::& _)  = sizeImpl i vn-typeCheckInstr (U.SIZE vn) i@((STc SCString, _, _) ::& _)  = sizeImpl i vn-typeCheckInstr (U.SIZE vn) i@((STc SCBytes, _, _) ::& _)  = sizeImpl i vn--typeCheckInstr (U.EMPTY_SET tn vn (U.Comparable mk ktn)) i =-  withSomeSingCT mk $ \k ->-    pure $ i :/ EMPTY_SET ::: ((STSet k, NTSet tn ktn, vn) ::& i)--typeCheckInstr (U.EMPTY_MAP tn vn (U.Comparable mk ktn) mv) i =-  withUType mv $ \(v :: Sing v, vns :: Notes v) ->-  withSomeSingCT mk $ \k -> do-    let ns = NTMap tn ktn vns-    pure $ i :/ EMPTY_MAP ::: ((STMap k v, ns, vn) ::& i)--typeCheckInstr (U.EMPTY_BIG_MAP tn vn (U.Comparable mk ktn) mv) i =-  withUType mv $ \(v :: Sing v, vns :: Notes v) ->-  withSomeSingCT mk $ \k -> do-    let ns = NTBigMap tn ktn vns-    pure $ i :/ EMPTY_BIG_MAP ::: ((STBigMap k v, ns, vn) ::& i)--typeCheckInstr instr@(U.MAP vn mp) i@((STList _, NTList _ vns, _vn) ::& _) = do-  mapImpl vns instr mp i-    (\rt rn -> (::&) (STList rt, NTList def rn, vn))--typeCheckInstr-  instr@(U.MAP vn mp)-  i@((STMap k _, NTMap _ kns vns, _vn) ::& _)-    = do-  let pns = NTPair def def def (NTc kns) vns-  mapImpl pns instr mp i-    (\rt rn -> (::&) (STMap k rt, NTMap def kns rn, vn))---- case `U.HSTER []` is wrongly typed by definition--- (as it is required to at least drop an element), so we don't consider it--typeCheckInstr instr@(U.ITER (i1 : ir)) i@((STSet _, NTSet _ en, _) ::& _) = do-  iterImpl (NTc en) instr (i1 :| ir) i-typeCheckInstr-  instr@(U.ITER (i1 : ir))-  i@((STList _, NTList _ en, _) ::& _)-    = do-  iterImpl en instr (i1 :| ir) i-typeCheckInstr-  instr@(U.ITER (i1 : ir))-  i@((STMap _ _, NTMap _ kns vns, _) ::& _)-    = do-  let en = NTPair def def def (NTc kns) vns-  iterImpl en instr (i1 :| ir) i--typeCheckInstr instr@(U.MEM vn)-           i@((STc _, _, _) ::& (STSet _, _, _) ::& _) = memImpl instr i vn-typeCheckInstr instr@(U.MEM vn)-           i@((STc _, _, _) ::& (STMap _ _, _, _) ::& _) = memImpl instr i vn-typeCheckInstr instr@(U.MEM vn)-           i@((STc _, _, _) ::& (STBigMap _ _, _, _) ::& _) = memImpl instr i vn--typeCheckInstr instr@(U.GET vn) i@(_ ::& (STMap _ vt, NTMap _ _ v, _) ::& _) =-  getImpl instr i vt v vn-typeCheckInstr-  instr@(U.GET vn)-  i@(_ ::& (STBigMap _ vt, NTBigMap _ _ v, _) ::& _)-    =-  getImpl instr i vt v vn--typeCheckInstr instr@(U.UPDATE vn) i@(_ ::& _ ::& (STMap _ _, _, _) ::& _) =-  updImpl instr i vn-typeCheckInstr instr@(U.UPDATE vn) i@(_ ::& _ ::& (STBigMap _ _, _, _) ::& _) =-  updImpl instr i vn-typeCheckInstr instr@(U.UPDATE vn) i@(_ ::& _ ::& (STSet _, _, _) ::& _) =-  updImpl instr i vn--typeCheckInstr (U.IF mp mq) i@((STc SCBool, _, _) ::& rs)  =-  genericIf IF U.IF mp mq rs rs i--typeCheckInstr instr@(U.LOOP is)-           i@((STc SCBool, _, _) ::& (rs :: HST rs)) = do-  _ :/ tp <- lift $ typeCheckList is rs-  case tp of-    subI ::: (o :: HST o) -> do-      case eqHST o (sing @('Tc 'CBool) -:& rs) of-        Right Refl -> do-          let _ ::& rs' = o-          pure $ i :/ LOOP subI ::: rs'-        Left m -> onTypeCheckInstrErr instr (SomeHST i)-                    "iteration expression has wrong output stack type:" (Left m)-    AnyOutInstr subI ->-      pure $ i :/ LOOP subI ::: rs--typeCheckInstr instr@(U.LOOP_LEFT is)-           i@((STOr (at :: Sing a) (bt :: Sing b), ons, ovn)-                      ::& (rs :: HST rs)) = do-  let (an, bn, avn, bvn) = deriveNsOr ons ovn-      ait = (at, an, avn) ::& rs-  _ :/ tp <- lift $ typeCheckList is ait-  case tp of-    subI ::: o -> do-      case (eqHST o (sing @('TOr a b) -:& rs), o) of-        (Right Refl, ((STOr _ bt', ons', ovn') ::& rs')) -> do-            let (_, bn', _, bvn') = deriveNsOr ons' ovn'-            br <- onTypeCheckInstrAnnErr instr i "wrong LOOP_LEFT input type:" $-                    convergeHSTEl (bt, bn, bvn) (bt', bn', bvn')-            pure $ i :/ LOOP_LEFT subI ::: (br ::& rs')-        (Left m, _) -> onTypeCheckInstrErr instr (SomeHST i)-                         "iteration expression has wrong output stack type:" (Left m)-    AnyOutInstr subI -> do-      let br = (bt, bn, bvn)-      pure $ i :/ LOOP_LEFT subI ::: (br ::& rs)--typeCheckInstr instr@(U.LAMBDA vn imt omt is) i = do-  withUType imt $ \(it :: Sing it, ins :: Notes ins) ->-    withUType omt $ \(ot :: Sing ot, ons :: Notes ons) ->-      -- further processing is extracted into another function because-      -- otherwise I encountered some weird GHC error with that code-      -- located right here-      lamImpl instr is vn it ins ot ons i--typeCheckInstr instr@(U.EXEC vn) i@(((_ :: Sing t1), _, _)-                              ::& ( STLambda (_ :: Sing t1') t2-                                  , NTLambda _ _ t2n-                                  , _-                                  )-                              ::& rs) = do-  Refl <- onTypeCheckInstrErr instr (SomeHST i)-                "lambda is given argument with wrong type:" (eqType @t1 @t1')-  pure $ i :/ EXEC ::: ((t2, t2n, vn) ::& rs)--typeCheckInstr instr@(U.APPLY vn)-               i@(((_ :: Sing a'), _, _)-                  ::& (STLambda (STPair (sa :: Sing a) (sb :: Sing b)) sc, ln, _)-                  ::& rs) = do-  let-    l2n = case ln of-      NTLambda vann (NTPair _ _ _ _ bn) cn ->-        NTLambda vann bn cn--  proofArgEq <- onTypeCheckInstrErr instr (SomeHST i)-                "lambda is given argument with wrong type:" (eqType @a' @a)-  proofOp <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-            "Operations in argument of partially applied lambda are not allowed"-            $ Left $ UnsupportedTypes [demote @a])-    pure (opAbsense sa)-  proofBigMap <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-            "BigMaps in argument of partially applied lambda are not allowed"-            $ Left $ UnsupportedTypes [demote @a])-    pure (bigMapAbsense sa)-  proofContract <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-            "Contract type in constant is not allowed"-            $ Left $ UnsupportedTypes [demote @a])-    pure (contractTypeAbsense sa)-  case (proofArgEq, proofOp, proofBigMap, proofContract) of-    (Refl, Dict, Dict, Dict) ->-      pure $ i :/ (APPLY @a) ::: ((STLambda sb sc, l2n, vn) ::& rs)--typeCheckInstr instr@(U.DIP is) i@(a ::& (s :: HST s)) = do-  typeCheckDipBody instr is s $ \subI t -> pure $ i :/ DIP subI ::: (a ::& t)--typeCheckInstr uInstr@(U.DIPN nTotal instructions) inputHST =-  go nTotal inputHST <&> \case-  TCDipHelper s subI out -> inputHST :/ DIPN s subI ::: out-  where-    go :: forall inp. Typeable inp-      => Word-      -> HST inp-      -> TypeCheckInstr (TCDipHelper inp)-    go n curHST = case (n, curHST) of-      (0, _) -> typeCheckDipBody uInstr instructions curHST $ \subI t ->-        pure (TCDipHelper SZ subI t)-      (_, SNil) -> onTypeCheckInstrErr uInstr-        (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDip))-      (_, hstHead ::& hstTail) ->-        go (n - 1) hstTail <&> \case-        TCDipHelper s subI out -> TCDipHelper (SS s) subI (hstHead ::& out)--typeCheckInstr U.FAILWITH i@(_ ::& _) =-  pure $ i :/ AnyOutInstr FAILWITH--typeCheckInstr instr@(U.CAST vn (AsUType _ castToNotes))-           i@(((e :: Sing e), (en :: Notes e), evn) ::& rs) = do-  (Refl, _) <- errM $ matchTypes en castToNotes-  pure $ i :/ CAST ::: ((e, castToNotes, vn `orAnn` evn) ::& rs)-  where-    errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a-    errM = onTypeCheckInstrErr instr (SomeHST i) "cast to incompatible type:"--typeCheckInstr (U.RENAME vn) i@((at, an, _) ::& rs) =-  pure $ i :/ RENAME ::: ((at, an, vn) ::& rs)--typeCheckInstr instr@(U.UNPACK tn vn mt) i@((STc SCBytes, _, _) ::& rs) =-  withUType mt $ \(t :: Sing t, tns :: Notes t) -> do-    let ns = NTOption tn tns-    proofOp <--      maybe (typeCheckInstrErr instr (SomeHST i)-             "Operation cannot appear in serialized data")-      pure (opAbsense t)-    proofBigMap <--      maybe (typeCheckInstrErr instr (SomeHST i)-             "BigMap cannot appear in serialized data")-      pure (bigMapAbsense t)-    proofContract <--      maybe (typeCheckInstrErr instr (SomeHST i)-             "UNPACK should not contain 'contract' type")-      pure (contractTypeAbsense t)-    case (proofOp, proofBigMap, proofContract) of-      (Dict, Dict, Dict) -> pure $ i :/ UNPACK ::: ((STOption t, ns, vn) ::& rs)--typeCheckInstr instr@(U.PACK vn) i@(((a :: Sing a), _, _) ::& rs) = do-  proofOp <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-           "Operations cannot appear in serialized data"-           $ Left $ UnsupportedTypes [demote @a])-    pure (opAbsense a)-  proofBigMap <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-           "BigMap cannot appear in serialized data"-           $ Left $ UnsupportedTypes [demote @a])-    pure (bigMapAbsense a)-  case (proofOp, proofBigMap) of-    (Dict, Dict) -> pure $ i :/ PACK ::: ((STc SCBytes, starNotes, vn) ::& rs)--typeCheckInstr (U.CONCAT vn) i@((STc SCBytes, _, _) ::&-                                    (STc SCBytes, _, _) ::& _) = concatImpl i vn-typeCheckInstr (U.CONCAT vn) i@((STc SCString, _, _) ::&-                                    (STc SCString, _, _) ::& _) = concatImpl i vn-typeCheckInstr (U.CONCAT vn) i@((STList (STc SCBytes), _, _) ::& _) = concatImpl' i vn-typeCheckInstr (U.CONCAT vn) i@((STList (STc SCString), _, _) ::& _) = concatImpl' i vn-typeCheckInstr (U.SLICE vn) i@((STc SCNat, _, _) ::&-                                   (STc SCNat, _, _) ::&-                                   (STc SCString, _, _) ::& _) = sliceImpl i vn-typeCheckInstr (U.SLICE vn) i@((STc SCNat, _, _) ::&-                                   (STc SCNat, _, _) ::&-                                   (STc SCBytes, _, _) ::& _) = sliceImpl i vn--typeCheckInstr (U.ISNAT vn') i@((STc SCInt, _, oldVn) ::& rs) = do-  let vn = vn' `orAnn` oldVn-  pure $ i :/ ISNAT ::: ((STOption (STc SCNat), starNotes, vn) ::& rs)--typeCheckInstr (U.ADD vn) i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _) = addImpl a b i vn--typeCheckInstr (U.SUB vn) i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _) = subImpl a b i vn--typeCheckInstr (U.MUL vn) i@((STc a, _, _) ::&-                                 (STc b, _, _) ::& _) = mulImpl a b i vn--typeCheckInstr (U.EDIV vn) i@((STc a, _, _) ::&-                                  (STc b, _, _) ::& _) = edivImpl a b i vn--typeCheckInstr (U.ABS vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Abs ABS i vn--typeCheckInstr (U.NEG vn) (i@((STc SCInt, _, _) ::& _)) = unaryArithImpl @Neg NEG i vn--typeCheckInstr (U.NEG vn) (i@((STc SCNat, _, _) ::& _)) = unaryArithImpl @Neg NEG i vn--typeCheckInstr (U.LSL vn) i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _) = arithImpl @Lsl LSL i vn--typeCheckInstr (U.LSR vn) i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _) = arithImpl @Lsr LSR i vn--typeCheckInstr (U.OR vn) i@((STc SCBool, _, _) ::&-                         (STc SCBool, _, _) ::& _) = arithImpl @Or OR i vn-typeCheckInstr (U.OR vn) i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _) = arithImpl @Or OR i vn--typeCheckInstr (U.AND vn) i@((STc SCInt, _, _) ::&-                         (STc SCNat, _, _) ::& _) = arithImpl @And AND i vn-typeCheckInstr (U.AND vn) i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _) = arithImpl @And AND i vn-typeCheckInstr (U.AND vn) i@((STc SCBool, _, _) ::&-                         (STc SCBool, _, _) ::& _) = arithImpl @And AND i vn--typeCheckInstr (U.XOR vn) i@((STc SCBool, _, _) ::&-                         (STc SCBool, _, _) ::& _) = arithImpl @Xor XOR i vn-typeCheckInstr (U.XOR vn) i@((STc SCNat, _, _) ::&-                         (STc SCNat, _, _) ::& _) = arithImpl @Xor XOR i vn--typeCheckInstr (U.NOT vn) i@((STc SCNat, _, _) ::& _) = unaryArithImpl @Not NOT i vn-typeCheckInstr (U.NOT vn) i@((STc SCBool, _, _) ::& _) = unaryArithImpl @Not NOT i vn-typeCheckInstr (U.NOT vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Not NOT i vn--typeCheckInstr instr@(U.COMPARE vn)-  i@(   (a :: Sing aT, an :: Notes aT, _)-    ::& (_ :: Sing bT, bn :: Notes bT, _)-    ::& rs-    )-    = do-  case eqType @aT @bT of-    Right Refl -> do-      void . errConv $ converge an bn-      proof <--        maybe (onTypeCheckInstrErr (U.COMPARE vn) (SomeHST i)-                "comparison is given incomparable arguments"-                $ Left $ UnsupportedTypes [demote @aT, demote @bT])-          pure (comparabilityPresence a)--      case proof of-        Dict -> do-          pure $ i :/ COMPARE ::: ((sing, starNotes, vn) ::& rs)--    Left err -> do-      typeCheckInstrErr' instr (SomeHST i) "comparing different types:" err-  where-    errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a-    errConv = onTypeCheckInstrAnnErr instr i "comparing types with different annotations:"--typeCheckInstr (U.EQ vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Eq' EQ i vn--typeCheckInstr (U.NEQ vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Neq NEQ i vn--typeCheckInstr (U.LT vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Lt LT i vn--typeCheckInstr (U.GT vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Gt GT i vn--typeCheckInstr (U.LE vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Le LE i vn--typeCheckInstr (U.GE vn) i@((STc SCInt, _, _) ::& _) = unaryArithImpl @Ge GE i vn--typeCheckInstr (U.INT vn) i@((STc SCNat, _, _) ::& rs) =-  pure $ i :/ INT ::: ((STc SCInt, starNotes, vn) ::& rs)--typeCheckInstr instr@(U.SELF vn fn) i = do-  cpType <- gets tcContractParam-  let t = fromUType cpType-  -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-  -- valid parameter type-  withUType cpType $ \(singcp :: Sing cp, (ParamNotesUnsafe -> notescp)) -> do-    proofOp <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-              "contract param type cannot contain operation"-              $ Left $ UnsupportedTypes [t])-      pure (opAbsense singcp)-    proofBigMap <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-              "contract param type cannot contain nested big_map"-              $ Left $ UnsupportedTypes [t])-      pure (nestedBigMapsAbsense singcp)-    case (proofOp, proofBigMap) of-      (Dict, Dict) -> do-        epName <- onTypeCheckInstrErr instr (SomeHST i) "Bad annotation:" $-                    epNameFromRefAnn fn `onLeft` IllegalEntryPoint-        MkEntryPointCallRes (argNotes :: Notes arg) epc <--          mkEntryPointCall epName (singcp, notescp)-            & maybeToRight (EntryPointNotFound epName)-            & onTypeCheckInstrErr instr (SomeHST i) "entrypoint not found"-        let ntRes = NTContract U.noAnn argNotes-        pure $ i :/ SELF @arg (SomeEpc epc)-                ::: ((sing @('TContract arg), ntRes, vn) ::& i)--typeCheckInstr instr@(U.CONTRACT vn fn mt)-           i@((STc SCAddress, _, _) ::& rs) =-  withUType mt $ \(t :: Sing t, tns :: Notes t) -> do-    proofOp <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-              "contract param type cannot contain operation"-              $ Left $ UnsupportedTypes [fromUType mt])-      pure (opAbsense t)-    proofBigMap <--      maybe (onTypeCheckInstrErr instr (SomeHST i)-              "contract param type cannot contain nested big_map"-              $ Left $ UnsupportedTypes [fromUType mt])-      pure (nestedBigMapsAbsense t)-    let ns = NTOption def $ NTContract def tns-    epName <- onTypeCheckInstrErr instr (SomeHST i) "Bad annotation:" $-                epNameFromRefAnn fn `onLeft` IllegalEntryPoint-    case (proofOp, proofBigMap) of-      (Dict, Dict) ->-        pure $ i :/ CONTRACT tns epName ::: ((STOption $ STContract t, ns, vn) ::& rs)--typeCheckInstr instr@(U.TRANSFER_TOKENS vn) i@(((_ :: Sing p'), _, _)-  ::& (STc SCMutez, _, _) ::& (STContract (p :: Sing p), _, _) ::& rs) = do-  proofOp <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-            "contract param type cannot contain operation"-            $ Left $ UnsupportedTypes [demote @p])-    pure (opAbsense p)-  proofBigMap <--    maybe (onTypeCheckInstrErr instr (SomeHST i)-            "contract param type cannot contain big_map"-            $ Left $ UnsupportedTypes [demote @p])-    pure (nestedBigMapsAbsense p)-  case (eqType @p @p', proofOp, proofBigMap) of-    (Right Refl, Dict, Dict) ->-      pure $ i :/ TRANSFER_TOKENS ::: ((STOperation, starNotes, vn) ::& rs)-    (Left m, _, _) ->-      onTypeCheckInstrErr instr (SomeHST i)-        "mismatch of contract param type:" (Left m)--typeCheckInstr (U.SET_DELEGATE vn)-           i@((STOption (STc SCKeyHash), _, _) ::& rs) = do-  pure $ i :/ SET_DELEGATE ::: ((STOperation, starNotes, vn) ::& rs)--typeCheckInstr instr@(U.CREATE_CONTRACT ovn avn contract)-           i@((STOption (STc SCKeyHash), _, _)-             ::& (STc SCMutez, _, _)-             ::& ((_ :: Sing g), gn, _) ::& rs) = do-  (SomeContract (FullContract (contr :: Contract p' g') paramNotes storeNotes))-    <- lift $ typeCheckContractImpl contract-  Refl <- checkEqT @g @g' instr i "contract storage type mismatch"-  void $ onTypeCheckInstrAnnErr instr i "contract storage type mismatch" (converge gn storeNotes)-  pure $ i :/ CREATE_CONTRACT (FullContract contr paramNotes storeNotes) :::-         ((STOperation, starNotes, ovn) ::& (STc SCAddress, starNotes, avn) ::& rs)--typeCheckInstr (U.IMPLICIT_ACCOUNT vn)-           i@((STc SCKeyHash, _, _) ::& rs) =-  pure $ i :/ IMPLICIT_ACCOUNT ::: ((STContract STUnit, starNotes, vn) ::& rs)--typeCheckInstr (U.NOW vn) i =-  pure $ i :/ NOW ::: ((STc SCTimestamp, starNotes, vn) ::& i)--typeCheckInstr (U.AMOUNT vn) i =-  pure $ i :/ AMOUNT ::: ((STc SCMutez, starNotes, vn) ::& i)--typeCheckInstr (U.BALANCE vn) i =-  pure $ i :/ BALANCE ::: ((STc SCMutez, starNotes, vn) ::& i)--typeCheckInstr (U.CHECK_SIGNATURE vn)-           i@((STKey, _, _)-             ::& (STSignature, _, _) ::& (STc SCBytes, _, _) ::& rs) =-  pure $ i :/ CHECK_SIGNATURE ::: ((STc SCBool, starNotes, vn) ::& rs)--typeCheckInstr (U.SHA256 vn)-           i@((STc SCBytes, _, _) ::& rs) =-  pure $ i :/ SHA256 ::: ((STc SCBytes, starNotes, vn) ::& rs)--typeCheckInstr (U.SHA512 vn)-           i@((STc SCBytes, _, _) ::& rs) =-  pure $ i :/ SHA512 ::: ((STc SCBytes, starNotes, vn) ::& rs)--typeCheckInstr (U.BLAKE2B vn)-           i@((STc SCBytes, _, _) ::& rs) =-  pure $ i :/ BLAKE2B ::: ((STc SCBytes, starNotes, vn) ::& rs)--typeCheckInstr (U.HASH_KEY vn)-           i@((STKey, _, _) ::& rs) =-  pure $ i :/ HASH_KEY ::: ((STc SCKeyHash, starNotes, vn) ::& rs)--typeCheckInstr (U.STEPS_TO_QUOTA vn) i =-  pure $ i :/ STEPS_TO_QUOTA ::: ((STc SCNat, starNotes, vn) ::& i)--typeCheckInstr (U.SOURCE vn) i =-  pure $ i :/ SOURCE ::: ((STc SCAddress, starNotes, vn) ::& i)--typeCheckInstr (U.SENDER vn) i =-  pure $ i :/ SENDER ::: ((STc SCAddress, starNotes, vn) ::& i)--typeCheckInstr (U.ADDRESS vn) i@((STContract _, _, _) ::& rs) =-  pure $ i :/ ADDRESS ::: ((STc SCAddress, starNotes, vn) ::& rs)--typeCheckInstr (U.CHAIN_ID vn) i =-  pure $ i :/ CHAIN_ID ::: ((STChainId, starNotes, vn) ::& i)--typeCheckInstr instr sit = typeCheckInstrErr instr (SomeHST sit) "unknown expression"+typeCheckInstr uInstr inp = case (uInstr, inp) of+  (U.EXT ext, si) ->+    typeCheckExt typeCheckList ext si++  (U.DROP, _ ::& rs) -> pure (inp :/ DROP ::: rs)++  (U.DROPN nTotal, inputHST) ->+    go nTotal inputHST <&> \case+      TCDropHelper s out -> inputHST :/ DROPN s ::: out+    where+      go :: forall inp. Typeable inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDropHelper inp)+      go n i = case (n, i) of+        (0, _) -> pure (TCDropHelper SZ i)++        (_, SNil) -> onTypeCheckInstrErr uInstr+          (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDrop))++        (_, (_ ::& iTail)) -> do+          go (n - 1) iTail <&> \case TCDropHelper s out -> TCDropHelper (SS s) out++  (U.DUP _vn, a ::& rs) ->+    pure (inp :/ DUP ::: (a ::& a::& rs))++  (U.SWAP, a ::& b ::& rs) ->+    pure (inp :/ SWAP ::: (b ::& a ::& rs))++  (U.DIG nTotal, inputHST) ->+    go nTotal inputHST <&> \case+      TCDigHelper s out -> inputHST :/ DIG s ::: out+    where+      go :: forall inp. Typeable inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDigHelper inp)+      go n i = case (n, i) of+        -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).+        (_, SNil) -> onTypeCheckInstrErr uInstr+          (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDig))++        (0, (_ ::& _)) -> pure (TCDigHelper SZ i)++        (_, (b ::& iTail)) ->+          go (n - 1) iTail <&> \case+          TCDigHelper s (a ::& resTail) -> TCDigHelper (SS s) (a ::& b ::& resTail)++  (U.DUG nTotal, inputHST) ->+    go nTotal inputHST <&> \case+      TCDugHelper s out -> inputHST :/ DUG s ::: out+    where+      go :: forall inp. Typeable inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDugHelper inp)+      go n i = case (n, i) of+        (0, (_ ::& _)) -> pure (TCDugHelper SZ i)++        (_, (a ::& b ::& iTail)) ->+          go (n - 1) (a ::& iTail) <&> \case+          TCDugHelper s resTail -> TCDugHelper (SS s) (b ::& resTail)++        -- Two cases:+        -- 1. Input stack is empty.+        -- 2. n > 0 and input stack has exactly 1 item.+        _ -> onTypeCheckInstrErr uInstr+          (SomeHST i) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDug))++  (U.PUSH vn mt mval, i) ->+    withUType mt $ \(t' :: Sing t', nt' :: Notes t') -> do+      val :::: (t :: Sing t, nt) <- typeCheckValue mval (t', nt')+      proofOp <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST i)+              "Operations in constant are not allowed"+              $ Left $ UnsupportedTypes [demote @t])+        pure (opAbsense t)+      proofBigMap <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST i)+              "BigMaps in constant are not allowed"+              $ Left $ UnsupportedTypes [demote @t])+        pure (bigMapAbsense t)+      proofContract <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST i)+              "Contract type in constant is not allowed"+              $ Left $ UnsupportedTypes [demote @t])+        pure (contractTypeAbsense t)+      case (proofOp, proofBigMap, proofContract) of+        (Dict, Dict, Dict) -> pure $ i :/ PUSH val ::: ((t, nt, vn) ::& i)++  (U.SOME tn vn, (at, an, _) ::& rs) -> do+    pure (inp :/ SOME ::: ((STOption at, NTOption tn an, vn) ::& rs))++  (U.NONE tn vn elMt, _) ->+    withUType elMt $ \(elSing :: Sing t, elNotes :: Notes t) ->+      pure $ inp :/ NONE ::: ((STOption elSing, NTOption tn elNotes, vn) ::& inp)++  (U.UNIT tn vn, _) ->+    pure $ inp :/ UNIT ::: ((STUnit, NTUnit tn, vn) ::& inp)++  (U.IF_NONE mp mq, (STOption a, ons, ovn) ::& rs) -> do+    let (an, avn) = deriveNsOption ons ovn+    genericIf IF_NONE U.IF_NONE mp mq rs ((a, an, avn) ::& rs) inp++  (U.PAIR tn vn pfn qfn, (a, an, avn) ::& (b, bn, bvn) ::& rs) -> do+    let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn+        ns = NTPair tn pfn' qfn' an bn+    pure (inp :/ PAIR ::: ((STPair a b, ns, vn `orAnn` vn') ::& rs))++  (U.CAR vn fn, ( STPair a b+                , NTPair pairTN pfn qfn pns qns+                , pairVN ) ::& rs) -> do+    pfn' <- onTypeCheckInstrAnnErr uInstr inp "wrong car type:" (convergeAnns fn pfn)+    let vn' = deriveSpecialVN vn pfn' pairVN+        i' = ( STPair a b+            , NTPair pairTN pfn' qfn pns qns+            , pairVN ) ::& rs+    pure $ i' :/ AnnCAR fn ::: ((a, pns, vn') ::& rs)++  (U.CDR vn fn, ( STPair a b+                , NTPair pairTN pfn qfn pns qns+                , pairVN ) ::& rs) -> do+    qfn' <- onTypeCheckInstrAnnErr uInstr inp "wrong cdr type:" (convergeAnns fn qfn)++    let vn' = deriveSpecialVN vn qfn' pairVN+        i' = ( STPair a b+            , NTPair pairTN pfn qfn' pns qns+            , pairVN ) ::& rs+    pure $ i' :/ AnnCDR fn ::: ((b, qns, vn') ::& rs)++  (U.LEFT tn vn pfn qfn bMt, (a, an, _) ::& rs) ->+    withUType bMt $ \(b :: Sing b, bn :: Notes b) -> do+      let ns = NTOr tn pfn qfn an bn+      pure (inp :/ LEFT ::: ((STOr a b, ns, vn) ::& rs))++  (U.RIGHT tn vn pfn qfn aMt, (b, bn, _) ::& rs) ->+    withUType aMt $ \(a :: Sing a, an :: Notes a) -> do+      let ns = NTOr tn pfn qfn an bn+      pure (inp :/ RIGHT ::: ((STOr a b, ns, vn) ::& rs))++  (U.IF_LEFT mp mq, (STOr a b, ons, ovn) ::& rs) -> do+    let (an, bn, avn, bvn) = deriveNsOr ons ovn+        ait = (a, an, avn) ::& rs+        bit = (b, bn, bvn) ::& rs+    genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp++  (U.NIL tn vn elMt, i) ->+    withUType elMt $ \(elT :: Sing elT, elNotes :: Notes elT) ->+      pure $ i :/ NIL ::: ((STList elT, NTList tn elNotes, vn) ::& i)++  (U.CONS vn, ((at :: Sing a), an, _)+                ::& (STList (_ :: Sing a'), ln, _) ::& rs) ->+    case eqType @a @a' of+      Right Refl -> do+        n <- onTypeCheckInstrAnnErr uInstr inp "wrong cons type:" (converge ln (NTList def an))+        pure $ inp :/ CONS ::: ((STList at, n, vn) ::& rs)+      Left m -> onTypeCheckInstrErr uInstr (SomeHST inp)+                  ("list element type is different from one "+                  <> "that is being CONSed:") (Left m)++  (U.IF_CONS mp mq, (STList a, ns, vn) ::& rs) -> do+    let NTList _ an = ns+        ait = (a, an, vn <> "hd") ::& (STList a, ns, vn <> "tl") ::& rs+    genericIf IF_CONS U.IF_CONS mp mq ait rs inp++  (U.SIZE vn, (STList _, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (STSet _, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (STMap _ _, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (STc SCString, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (STc SCBytes, _, _) ::& _) -> sizeImpl inp vn++  (U.EMPTY_SET tn vn (U.Comparable mk ktn), i) ->+    withSomeSingCT mk $ \k ->+      pure $ i :/ EMPTY_SET ::: ((STSet k, NTSet tn ktn, vn) ::& inp)++  (U.EMPTY_MAP tn vn (U.Comparable mk ktn) mv, i) ->+    withUType mv $ \(v :: Sing v, vns :: Notes v) ->+    withSomeSingCT mk $ \k -> do+      let ns = NTMap tn ktn vns+      pure $ i :/ EMPTY_MAP ::: ((STMap k v, ns, vn) ::& i)++  (U.EMPTY_BIG_MAP tn vn (U.Comparable mk ktn) mv, i) ->+    withUType mv $ \(v :: Sing v, vns :: Notes v) ->+    withSomeSingCT mk $ \k -> do+      let ns = NTBigMap tn ktn vns+      pure $ i :/ EMPTY_BIG_MAP ::: ((STBigMap k v, ns, vn) ::& i)++  (U.MAP vn mp, (STList _, NTList _ vns, _vn) ::& _) -> do+    mapImpl vns uInstr mp inp+      (\rt rn -> (::&) (STList rt, NTList def rn, vn))+++  (U.MAP vn mp, (STMap k _, NTMap _ kns vns, _vn) ::& _) -> do+    let pns = NTPair def def def (NTc kns) vns+    mapImpl pns uInstr mp inp+      (\rt rn -> (::&) (STMap k rt, NTMap def kns rn, vn))++-- case `U.HSTER []` is wrongly typed by definition+-- (as it is required to at least drop an element), so we don't consider it++  (U.ITER (i1 : ir), (STSet _, NTSet _ en, _) ::& _) -> do+    iterImpl (NTc en) uInstr (i1 :| ir) inp++  (U.ITER (i1 : ir), (STList _, NTList _ en, _) ::& _) -> do+    iterImpl en uInstr (i1 :| ir) inp++  (U.ITER (i1 : ir), (STMap _ _, NTMap _ kns vns, _) ::& _) -> do+    let en = NTPair def def def (NTc kns) vns+    iterImpl en uInstr (i1 :| ir) inp++  (U.MEM vn, (STc _, _, _) ::& (STSet _, _, _) ::& _) ->+    memImpl uInstr inp vn+  (U.MEM vn, (STc _, _, _) ::& (STMap _ _, _, _) ::& _) ->+    memImpl uInstr inp vn+  (U.MEM vn, (STc _, _, _) ::& (STBigMap _ _, _, _) ::& _) ->+    memImpl uInstr inp vn++  (U.GET vn, _ ::& (STMap _ vt, NTMap _ _ v, _) ::& _) ->+    getImpl uInstr inp vt v vn+  (U.GET vn, _ ::& (STBigMap _ vt, NTBigMap _ _ v, _) ::& _) ->+    getImpl uInstr inp vt v vn++  (U.UPDATE vn, _ ::& _ ::& (STMap _ _, _, _) ::& _) ->+    updImpl uInstr inp vn+  (U.UPDATE vn, _ ::& _ ::& (STBigMap _ _, _, _) ::& _) ->+    updImpl uInstr inp vn+  (U.UPDATE vn, _ ::& _ ::& (STSet _, _, _) ::& _) ->+    updImpl uInstr inp vn++  (U.IF mp mq, (STc SCBool, _, _) ::& rs) ->+    genericIf IF U.IF mp mq rs rs inp++  (U.LOOP is, (STc SCBool, _, _) ::& (rs :: HST rs)) -> do+    _ :/ tp <- lift $ typeCheckList is rs+    case tp of+      subI ::: (o :: HST o) -> do+        case eqHST o (sing @('Tc 'CBool) -:& rs) of+          Right Refl -> do+            let _ ::& rs' = o+            pure $ inp :/ LOOP subI ::: rs'+          Left m -> onTypeCheckInstrErr uInstr (SomeHST inp)+                      "iteration expression has wrong output stack type:" (Left m)+      AnyOutInstr subI ->+        pure $ inp :/ LOOP subI ::: rs++  (U.LOOP_LEFT is, (STOr (at :: Sing a) (bt :: Sing b), ons, ovn) ::& rs) -> do+    let (an, bn, avn, bvn) = deriveNsOr ons ovn+        ait = (at, an, avn) ::& rs+    _ :/ tp <- lift $ typeCheckList is ait+    case tp of+      subI ::: o -> do+        case (eqHST o (sing @('TOr a b) -:& rs), o) of+          (Right Refl, ((STOr _ bt', ons', ovn') ::& rs')) -> do+              let (_, bn', _, bvn') = deriveNsOr ons' ovn'+              br <- onTypeCheckInstrAnnErr uInstr inp "wrong LOOP_LEFT input type:" $+                      convergeHSTEl (bt, bn, bvn) (bt', bn', bvn')+              pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs')+          (Left m, _) -> onTypeCheckInstrErr uInstr (SomeHST inp)+                          "iteration expression has wrong output stack type:" (Left m)+      AnyOutInstr subI -> do+        let br = (bt, bn, bvn)+        pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs)++  (U.LAMBDA vn imt omt is, i) -> do+    withUType imt $ \(it :: Sing it, ins :: Notes ins) ->+      withUType omt $ \(ot :: Sing ot, ons :: Notes ons) ->+        -- further processing is extracted into another function because+        -- otherwise I encountered some weird GHC error with that code+        -- located right here+        lamImpl uInstr is vn it ins ot ons i++  (U.EXEC vn, ((_ :: Sing t1), _, _)+                              ::& ( STLambda (_ :: Sing t1') t2+                                  , NTLambda _ _ t2n+                                  , _+                                  )+                              ::& rs) -> do+    Refl <- onTypeCheckInstrErr uInstr (SomeHST inp)+                  "lambda is given argument with wrong type:" (eqType @t1 @t1')+    pure $ inp :/ EXEC ::: ((t2, t2n, vn) ::& rs)++  (U.APPLY vn, ((_ :: Sing a'), _, _)+                  ::& (STLambda (STPair (sa :: Sing a) (sb :: Sing b)) sc, ln, _)+                  ::& rs) -> do+    let+      l2n = case ln of+        NTLambda vann (NTPair _ _ _ _ bn) cn ->+          NTLambda vann bn cn++    proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp)+                  "lambda is given argument with wrong type:" (eqType @a' @a)+    proofOp <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+              "Operations in argument of partially applied lambda are not allowed"+              $ Left $ UnsupportedTypes [demote @a])+      pure (opAbsense sa)+    proofBigMap <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+              "BigMaps in argument of partially applied lambda are not allowed"+              $ Left $ UnsupportedTypes [demote @a])+      pure (bigMapAbsense sa)+    proofContract <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+              "Contract type in constant is not allowed"+              $ Left $ UnsupportedTypes [demote @a])+      pure (contractTypeAbsense sa)+    case (proofArgEq, proofOp, proofBigMap, proofContract) of+      (Refl, Dict, Dict, Dict) ->+        pure $ inp :/ (APPLY @a) ::: ((STLambda sb sc, l2n, vn) ::& rs)++  (U.DIP is, a ::& s) -> do+    typeCheckDipBody uInstr is s $+      \subI t -> pure $ inp :/ DIP subI ::: (a ::& t)++  (U.DIPN nTotal instructions, inputHST) ->+    go nTotal inputHST <&> \case+    TCDipHelper s subI out -> inputHST :/ DIPN s subI ::: out+    where+      go :: forall inp. Typeable inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDipHelper inp)+      go n curHST = case (n, curHST) of+        (0, _) -> typeCheckDipBody uInstr instructions curHST $ \subI t ->+          pure (TCDipHelper SZ subI t)+        (_, SNil) -> onTypeCheckInstrErr uInstr+          (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDip))+        (_, hstHead ::& hstTail) ->+          go (n - 1) hstTail <&> \case+          TCDipHelper s subI out -> TCDipHelper (SS s) subI (hstHead ::& out)++  (U.FAILWITH, (_ ::& _)) ->+    pure $ inp :/ AnyOutInstr FAILWITH++  (U.CAST vn (AsUType _ castToNotes), (e, en, evn) ::& rs) -> do+    (Refl, _) <- errM $ matchTypes en castToNotes+    pure $ inp :/ CAST ::: ((e, castToNotes, vn `orAnn` evn) ::& rs)+    where+      errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a+      errM = onTypeCheckInstrErr uInstr (SomeHST inp) "cast to incompatible type:"++  (U.RENAME vn, (at, an, _) ::& rs) ->+    pure $ inp :/ RENAME ::: ((at, an, vn) ::& rs)++  (U.UNPACK tn vn mt, (STc SCBytes, _, _) ::& rs) ->+    withUType mt $ \(t, tns) -> do+      let ns = NTOption tn tns+      proofOp <-+        maybe (typeCheckInstrErr uInstr (SomeHST inp)+              "Operation cannot appear in serialized data")+        pure (opAbsense t)+      proofBigMap <-+        maybe (typeCheckInstrErr uInstr (SomeHST inp)+              "BigMap cannot appear in serialized data")+        pure (bigMapAbsense t)+      proofContract <-+        maybe (typeCheckInstrErr uInstr (SomeHST inp)+              "UNPACK should not contain 'contract' type")+        pure (contractTypeAbsense t)+      case (proofOp, proofBigMap, proofContract) of+        (Dict, Dict, Dict) ->+          pure $ inp :/ UNPACK ::: ((STOption t, ns, vn) ::& rs)++  (U.PACK vn, (a, _, _) ::& rs) -> do+    proofOp <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+            "Operations cannot appear in serialized data"+            $ Left $ UnsupportedTypes [fromSingT a])+      pure (opAbsense a)+    proofBigMap <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+            "BigMap cannot appear in serialized data"+            $ Left $ UnsupportedTypes [fromSingT a])+      pure (bigMapAbsense a)+    case (proofOp, proofBigMap) of+      (Dict, Dict) ->+        pure $ inp :/ PACK ::: ((STc SCBytes, starNotes, vn) ::& rs)++  (U.CONCAT vn, (STc SCBytes, _, _) ::& (STc SCBytes, _, _) ::& _) ->+    concatImpl inp vn+  (U.CONCAT vn, (STc SCString, _, _) ::& (STc SCString, _, _) ::& _) ->+    concatImpl inp vn+  (U.CONCAT vn, (STList (STc SCBytes), _, _) ::& _) ->+    concatImpl' inp vn+  (U.CONCAT vn, (STList (STc SCString), _, _) ::& _) ->+    concatImpl' inp vn+  (U.SLICE vn, (STc SCNat, _, _) ::&+               (STc SCNat, _, _) ::&+               (STc SCString, _, _) ::& _) -> sliceImpl inp vn+  (U.SLICE vn, (STc SCNat, _, _) ::&+               (STc SCNat, _, _) ::&+               (STc SCBytes, _, _) ::& _) -> sliceImpl inp vn++  (U.ISNAT vn', (STc SCInt, _, oldVn) ::& rs) -> do+    let vn = vn' `orAnn` oldVn+    pure $ inp :/ ISNAT ::: ((STOption (STc SCNat), starNotes, vn) ::& rs)++  (U.ADD vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> addImpl a b inp vn+  (U.SUB vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> subImpl a b inp vn+  (U.MUL vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> mulImpl a b inp vn+  (U.EDIV vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> edivImpl a b inp vn++  (U.ABS vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Abs ABS inp vn++  (U.NEG vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Neg NEG inp vn+  (U.NEG vn, (STc SCNat, _, _) ::& _) -> unaryArithImpl @Neg NEG inp vn++  (U.LSL vn, (STc SCNat, _, _) ::&+             (STc SCNat, _, _) ::& _) -> arithImpl @Lsl LSL inp vn++  (U.LSR vn, (STc SCNat, _, _) ::&+             (STc SCNat, _, _) ::& _) -> arithImpl @Lsr LSR inp vn++  (U.OR vn, (STc SCBool, _, _) ::&+            (STc SCBool, _, _) ::& _) -> arithImpl @Or OR inp vn+  (U.OR vn, (STc SCNat, _, _) ::&+            (STc SCNat, _, _) ::& _) -> arithImpl @Or OR inp vn++  (U.AND vn, (STc SCInt, _, _) ::&+             (STc SCNat, _, _) ::& _) -> arithImpl @And AND inp vn+  (U.AND vn, (STc SCNat, _, _) ::&+             (STc SCNat, _, _) ::& _) -> arithImpl @And AND inp vn+  (U.AND vn, (STc SCBool, _, _) ::&+             (STc SCBool, _, _) ::& _) -> arithImpl @And AND inp vn++  (U.XOR vn, (STc SCBool, _, _) ::&+             (STc SCBool, _, _) ::& _) -> arithImpl @Xor XOR inp vn+  (U.XOR vn, (STc SCNat, _, _) ::&+             (STc SCNat, _, _) ::& _) -> arithImpl @Xor XOR inp vn++  (U.NOT vn, (STc SCNat, _, _) ::& _) -> unaryArithImpl @Not NOT inp vn+  (U.NOT vn, (STc SCBool, _, _) ::& _) -> unaryArithImpl @Not NOT inp vn+  (U.NOT vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Not NOT inp vn++  (U.COMPARE vn,+        (a :: Sing aT, an :: Notes aT, _)+    ::& (_ :: Sing bT, bn :: Notes bT, _)+    ::& rs+    )+    -> do+    case eqType @aT @bT of+      Right Refl -> do+        void . errConv $ converge an bn+        proof <-+          maybe (onTypeCheckInstrErr (U.COMPARE vn) (SomeHST inp)+                  "comparison is given incomparable arguments"+                  $ Left $ UnsupportedTypes [demote @aT, demote @bT])+            pure (comparabilityPresence a)++        case proof of+          Dict -> do+            pure $ inp :/ COMPARE ::: ((sing, starNotes, vn) ::& rs)++      Left err -> do+        typeCheckInstrErr' uInstr (SomeHST inp) "comparing different types:" err+    where+      errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a+      errConv = onTypeCheckInstrAnnErr uInstr inp "comparing types with different annotations:"++  (U.EQ vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Eq' EQ inp vn++  (U.NEQ vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Neq NEQ inp vn++  (U.LT vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Lt LT inp vn++  (U.GT vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Gt GT inp vn++  (U.LE vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Le LE inp vn++  (U.GE vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Ge GE inp vn++  (U.INT vn, (STc SCNat, _, _) ::& rs) ->+    pure $ inp :/ INT ::: ((STc SCInt, starNotes, vn) ::& rs)++  (U.SELF vn fn, _) -> do+    cpType <- gets tcContractParam+    let t = fromUType cpType+    -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has+    -- valid parameter type+    withUType cpType $ \(singcp :: Sing cp, (ParamNotesUnsafe -> notescp)) -> do+      proofOp <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+                "contract param type cannot contain operation"+                $ Left $ UnsupportedTypes [t])+        pure (opAbsense singcp)+      proofBigMap <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+                "contract param type cannot contain nested big_map"+                $ Left $ UnsupportedTypes [t])+        pure (nestedBigMapsAbsense singcp)+      case (proofOp, proofBigMap) of+        (Dict, Dict) -> do+          epName <- onTypeCheckInstrErr uInstr (SomeHST inp) "Bad annotation:" $+                      epNameFromRefAnn fn `onLeft` IllegalEntryPoint+          MkEntryPointCallRes (argNotes :: Notes arg) epc <-+            mkEntryPointCall epName (singcp, notescp)+              & maybeToRight (EntryPointNotFound epName)+              & onTypeCheckInstrErr uInstr (SomeHST inp) "entrypoint not found"+          let ntRes = NTContract U.noAnn argNotes+          pure $ inp :/ SELF @arg (SomeEpc epc)+                  ::: ((sing @('TContract arg), ntRes, vn) ::& inp)++  (U.CONTRACT vn fn mt, (STc SCAddress, _, _) ::& rs) ->+    withUType mt $ \(t :: Sing t, tns :: Notes t) -> do+      proofOp <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+                "contract param type cannot contain operation"+                $ Left $ UnsupportedTypes [fromUType mt])+        pure (opAbsense t)+      proofBigMap <-+        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+                "contract param type cannot contain nested big_map"+                $ Left $ UnsupportedTypes [fromUType mt])+        pure (nestedBigMapsAbsense t)+      let ns = NTOption def $ NTContract def tns+      epName <- onTypeCheckInstrErr uInstr (SomeHST inp) "Bad annotation:" $+                  epNameFromRefAnn fn `onLeft` IllegalEntryPoint+      case (proofOp, proofBigMap) of+        (Dict, Dict) ->+          pure $ inp :/ CONTRACT tns epName ::: ((STOption $ STContract t, ns, vn) ::& rs)++  (U.TRANSFER_TOKENS vn, ((_ :: Sing p'), _, _)+    ::& (STc SCMutez, _, _) ::& (STContract (p :: Sing p), _, _) ::& rs) -> do+    proofOp <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+              "contract param type cannot contain operation"+              $ Left $ UnsupportedTypes [demote @p])+      pure (opAbsense p)+    proofBigMap <-+      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)+              "contract param type cannot contain big_map"+              $ Left $ UnsupportedTypes [demote @p])+      pure (nestedBigMapsAbsense p)+    case (eqType @p @p', proofOp, proofBigMap) of+      (Right Refl, Dict, Dict) ->+        pure $ inp :/ TRANSFER_TOKENS ::: ((STOperation, starNotes, vn) ::& rs)+      (Left m, _, _) ->+        onTypeCheckInstrErr uInstr (SomeHST inp)+          "mismatch of contract param type:" (Left m)++  (U.SET_DELEGATE vn, (STOption (STc SCKeyHash), _, _) ::& rs) -> do+    pure $ inp :/ SET_DELEGATE ::: ((STOperation, starNotes, vn) ::& rs)++  (U.CREATE_CONTRACT ovn avn contract,+                 (STOption (STc SCKeyHash), _, _)+             ::& (STc SCMutez, _, _)+             ::& ((_ :: Sing g), gn, _) ::& rs) -> do+    (SomeContract (FullContract (contr :: Contract p' g') paramNotes storeNotes))+      <- lift $ typeCheckContractImpl contract+    Refl <- checkEqT @g @g' uInstr inp "contract storage type mismatch"+    void $ onTypeCheckInstrAnnErr uInstr inp "contract storage type mismatch" (converge gn storeNotes)+    pure $ inp :/ CREATE_CONTRACT (FullContract contr paramNotes storeNotes) :::+          ((STOperation, starNotes, ovn) ::& (STc SCAddress, starNotes, avn) ::& rs)++  (U.IMPLICIT_ACCOUNT vn, (STc SCKeyHash, _, _) ::& rs) ->+    pure $ inp :/ IMPLICIT_ACCOUNT ::: ((STContract STUnit, starNotes, vn) ::& rs)++  (U.NOW vn, _) ->+    pure $ inp :/ NOW ::: ((STc SCTimestamp, starNotes, vn) ::& inp)++  (U.AMOUNT vn, _) ->+    pure $ inp :/ AMOUNT ::: ((STc SCMutez, starNotes, vn) ::& inp)++  (U.BALANCE vn, _) ->+    pure $ inp :/ BALANCE ::: ((STc SCMutez, starNotes, vn) ::& inp)++  (U.CHECK_SIGNATURE vn,+             (STKey, _, _)+             ::& (STSignature, _, _) ::& (STc SCBytes, _, _) ::& rs) ->+    pure $ inp :/ CHECK_SIGNATURE ::: ((STc SCBool, starNotes, vn) ::& rs)++  (U.SHA256 vn, (STc SCBytes, _, _) ::& rs) ->+    pure $ inp :/ SHA256 ::: ((STc SCBytes, starNotes, vn) ::& rs)++  (U.SHA512 vn, (STc SCBytes, _, _) ::& rs) ->+    pure $ inp :/ SHA512 ::: ((STc SCBytes, starNotes, vn) ::& rs)++  (U.BLAKE2B vn, (STc SCBytes, _, _) ::& rs) ->+    pure $ inp :/ BLAKE2B ::: ((STc SCBytes, starNotes, vn) ::& rs)++  (U.HASH_KEY vn, (STKey, _, _) ::& rs) ->+    pure $ inp :/ HASH_KEY ::: ((STc SCKeyHash, starNotes, vn) ::& rs)++  (U.STEPS_TO_QUOTA vn, _) ->+    pure $ inp :/ STEPS_TO_QUOTA ::: ((STc SCNat, starNotes, vn) ::& inp)++  (U.SOURCE vn, _) ->+    pure $ inp :/ SOURCE ::: ((STc SCAddress, starNotes, vn) ::& inp)++  (U.SENDER vn, _) ->+    pure $ inp :/ SENDER ::: ((STc SCAddress, starNotes, vn) ::& inp)++  (U.ADDRESS vn, (STContract _, _, _) ::& rs) ->+    pure $ inp :/ ADDRESS ::: ((STc SCAddress, starNotes, vn) ::& rs)++  (U.CHAIN_ID vn, _) ->+    pure $ inp :/ CHAIN_ID ::: ((STChainId, starNotes, vn) ::& inp)++  _ ->+    typeCheckInstrErr uInstr (SomeHST inp) "unknown expression"  -- | Helper function for two-branch if where each branch is given a single -- value.

@@ -7,6 +7,7 @@   , runTypeCheck   , TypeCheckInstr   , runTypeCheckIsolated+  , runTypeCheckInstrIsolated   , mapTCError    , tcContractParamL@@ -17,6 +18,7 @@ import Control.Lens (makeLensesWith) import Control.Monad.Except (withExceptT) import Control.Monad.Reader (mapReaderT)+import Data.Default (def)  import Michelson.ErrorPos (InstrCallStack) import Michelson.TypeCheck.Error (TCError)@@ -25,9 +27,9 @@ import Tezos.Address (ContractHash) import Util.Lens -type TypeCheck a =+type TypeCheck =   ExceptT TCError-    (State TypeCheckEnv) a+    (State TypeCheckEnv)  type TcOriginatedContracts = Map ContractHash U.Type @@ -65,7 +67,12 @@ type TcResult inp = Either TCError (SomeInstr inp)  type TypeCheckInstr =-       ReaderT InstrCallStack (ExceptT TCError (State TypeCheckEnv))+       ReaderT InstrCallStack TypeCheck++-- | Similar to 'runTypeCheckIsolated', but for 'TypeCheckInstr.'+runTypeCheckInstrIsolated :: TypeCheckInstr a -> Either TCError a+runTypeCheckInstrIsolated =+  runTypeCheckIsolated . flip runReaderT def  -- | Run 'TypeCheckInstr' and modify thrown errors using given functions. mapTCError :: (TCError -> TCError) -> TypeCheckInstr a -> TypeCheckInstr a

@@ -28,32 +28,33 @@  typeCheckCValue   :: U.Value' op -> CT -> Either (U.Value' op, TCTypeError) SomeCValue-typeCheckCValue (U.ValueInt i) CInt = pure $ CvInt i :--: SCInt-typeCheckCValue (U.ValueInt i) CNat-  | i >= 0 = pure $ CvNat (fromInteger i) :--: SCNat-  | otherwise = Left (U.ValueInt i, NegativeNat)-typeCheckCValue v@(U.ValueInt i) CMutez = do-  mtz <- maybeToRight (v, InvalidTimestamp) . mkMutez $ fromInteger i-  pure $ CvMutez mtz :--: SCMutez-typeCheckCValue (U.ValueString s) CString =-  pure $ CvString s :--: SCString-typeCheckCValue v@(U.ValueString s) CAddress = do-  addr <- T.parseEpAddress (unMText s) `onLeft` ((v, ) . InvalidAddress)-  pure $ CvAddress addr :--: SCAddress-typeCheckCValue v@(U.ValueString s) CKeyHash = do-  kHash <- parseKeyHash (unMText s) `onLeft` ((v, ) . InvalidKeyHash)-  pure $ CvKeyHash kHash :--: SCKeyHash-typeCheckCValue v@(U.ValueString s) CTimestamp = do-  tstamp <- maybeToRight (v, InvalidTimestamp) . parseTimestamp $ unMText s-  pure $ CvTimestamp tstamp :--: SCTimestamp-typeCheckCValue (U.ValueInt i) CTimestamp =-  pure $ CvTimestamp (timestampFromSeconds i) :--: SCTimestamp-typeCheckCValue (U.ValueBytes (U.InternalByteString s)) CBytes =-  pure $ CvBytes s :--: SCBytes-typeCheckCValue U.ValueTrue CBool = pure $ CvBool True :--: SCBool-typeCheckCValue U.ValueFalse CBool = pure $ CvBool False :--: SCBool-typeCheckCValue v t =-  Left $ (v, InvalidValueType (T.Tc t))+typeCheckCValue val ct = case (val, ct) of+  (U.ValueInt i, CInt) -> pure $ CvInt i :--: SCInt+  (U.ValueInt i, CNat)+    | i >= 0 -> pure $ CvNat (fromInteger i) :--: SCNat+    | otherwise -> Left (U.ValueInt i, NegativeNat)+  (v@(U.ValueInt i), CMutez) -> do+    mtz <- maybeToRight (v, InvalidTimestamp) . mkMutez $ fromInteger i+    pure $ CvMutez mtz :--: SCMutez+  (U.ValueString s, CString) ->+    pure $ CvString s :--: SCString+  (v@(U.ValueString s), CAddress) -> do+    addr <- T.parseEpAddress (unMText s) `onLeft` ((v, ) . InvalidAddress)+    pure $ CvAddress addr :--: SCAddress+  (v@(U.ValueString s), CKeyHash) -> do+    kHash <- parseKeyHash (unMText s) `onLeft` ((v, ) . InvalidKeyHash)+    pure $ CvKeyHash kHash :--: SCKeyHash+  (v@(U.ValueString s), CTimestamp) -> do+    tstamp <- maybeToRight (v, InvalidTimestamp) . parseTimestamp $ unMText s+    pure $ CvTimestamp tstamp :--: SCTimestamp+  (U.ValueInt i, CTimestamp) ->+    pure $ CvTimestamp (timestampFromSeconds i) :--: SCTimestamp+  (U.ValueBytes (U.InternalByteString s), CBytes) ->+    pure $ CvBytes s :--: SCBytes+  (U.ValueTrue, CBool) -> pure $ CvBool True :--: SCBool+  (U.ValueFalse, CBool) -> pure $ CvBool False :--: SCBool+  (v, t) ->+    Left $ (v, InvalidValueType (T.Tc t))  typeCheckCVals   :: forall t op . (Typeable t, SingI t)@@ -89,149 +90,130 @@   -> U.Value   -> (Sing t, Notes t)   -> TypeCheckInstr SomeNotedValue-typeCheckValImpl _ mv (t@(STc ct), NTc nt) = do-  case typeCheckCValue mv (fromSingCT ct) of-    Left (uval, err) -> tcFailedOnValue uval (fromSingT $ t) "" (Just err)-    Right (v :--: cst) -> pure $ VC v :::: (STc cst, NTc nt)-typeCheckValImpl _ (U.ValueString (parsePublicKey . unMText -> Right s)) t@(STKey, _) =-  pure $ T.VKey s :::: t+typeCheckValImpl tcDo uvalue ty@(tySing, tyNotes) = case (uvalue, tySing, tyNotes) of+  (mv, t@(STc ct), NTc nt) -> do+    case typeCheckCValue mv (fromSingCT ct) of+      Left (uval, err) -> tcFailedOnValue uval (fromSingT $ t) "" (Just err)+      Right (v :--: cst) -> pure $ VC v :::: (STc cst, NTc nt)+  (U.ValueString (parsePublicKey . unMText -> Right s), STKey, _) ->+    pure $ T.VKey s :::: ty -typeCheckValImpl _ (U.ValueString (parseSignature . unMText -> Right s)) t@(STSignature, _) =-  pure $ VSignature s :::: t+  (U.ValueString (parseSignature . unMText -> Right s), STSignature, _) ->+    pure $ VSignature s :::: ty -typeCheckValImpl _ (U.ValueString (parseChainId . unMText -> Right ci)) t@(STChainId, _) =-  pure $ VChainId ci :::: t-typeCheckValImpl _ (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci)) t@(STChainId, _) =-  pure $ VChainId ci :::: t+  (U.ValueString (parseChainId . unMText -> Right ci), STChainId, _) ->+    pure $ VChainId ci :::: ty+  (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId, _) ->+    pure $ VChainId ci :::: ty -typeCheckValImpl _ cv@(U.ValueString (T.parseEpAddress . unMText -> Right epAddr))-                   t@(STContract (pc :: Sing cp), NTContract _ pn) = do-  instrPos <- ask-  contracts <- gets tcContracts-  let ensureTypeMatches :: (Typeable t, SingI t) => (Sing t, Notes t) -> TypeCheckInstr (cp :~: t)-      ensureTypeMatches (_, pn') =-        liftEither @_ @TypeCheckInstr $-        first (TCFailedOnValue cv (fromSingT $ fst t) "wrong contract parameter" instrPos . Just) $-          fmap fst $ matchTypes pn pn'-  let unsupportedType :: Text -> Either TCError a-      unsupportedType desc =-        Left $-        TCFailedOnValue cv (fromSingT pc) (desc <> " in type argument of 'contract' type") instrPos $-        Just (UnsupportedTypes [fromSingT pc])-  let EpAddress addr epName = epAddr-  case addr of-    KeyAddress _ -> do-      Refl <- ensureTypeMatches (second unParamNotes T.tyImplicitAccountParam)-      pure $ VContract addr def :::: t-    ContractAddress ca ->-      case M.lookup ca contracts of-        -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-        -- valid parameter type-        Just (AsUType cpSing (T.ParamNotesUnsafe -> cpNotes)) -> do-          Dict <- liftEither $ maybe (unsupportedType "Operation") pure (T.opAbsense cpSing)-          Dict <- liftEither $ maybe (unsupportedType "Nested BigMaps") pure (T.nestedBigMapsAbsense cpSing)-          case T.mkEntryPointCall epName (cpSing, cpNotes) of-            Nothing ->-              throwError $-              TCFailedOnValue cv (fromSingT $ fst t) "unknown entrypoint" instrPos . Just $-              EntryPointNotFound epName-            Just (T.MkEntryPointCallRes argNotes epc) -> do-              ensureTypeMatches (sing, argNotes)-              pure $ VContract addr (T.SomeEpc epc) :::: (sing, NTContract U.noAnn argNotes)-        Nothing ->-          throwError $ TCFailedOnValue cv (fromSingT $ fst t) "Contract literal unknown"-            instrPos (Just $ UnknownContract addr)+  ( cv@(U.ValueString (T.parseEpAddress . unMText -> Right epAddr)),+                      STContract (pc :: Sing cp), NTContract _ pn ) -> do+    instrPos <- ask+    contracts <- gets tcContracts+    let ensureTypeMatches :: (Typeable t, SingI t) => (Sing t, Notes t) -> TypeCheckInstr (cp :~: t)+        ensureTypeMatches (_, pn') =+          liftEither @_ @TypeCheckInstr $+          first (TCFailedOnValue cv (fromSingT tySing) "wrong contract parameter" instrPos . Just) $+            fmap fst $ matchTypes pn pn'+    let unsupportedType :: Text -> Either TCError a+        unsupportedType desc =+          Left $+          TCFailedOnValue cv (fromSingT pc) (desc <> " in type argument of 'contract' type") instrPos $+          Just (UnsupportedTypes [fromSingT pc])+    let EpAddress addr epName = epAddr+    case addr of+      KeyAddress _ -> do+        Refl <- ensureTypeMatches (second unParamNotes T.tyImplicitAccountParam)+        pure $ VContract addr T.sepcPrimitive :::: ty+      ContractAddress ca ->+        case M.lookup ca contracts of+          -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has+          -- valid parameter type+          Just (AsUType cpSing (T.ParamNotesUnsafe -> cpNotes)) -> do+            Dict <- liftEither $ maybe (unsupportedType "Operation") pure (T.opAbsense cpSing)+            Dict <- liftEither $ maybe (unsupportedType "Nested BigMaps") pure (T.nestedBigMapsAbsense cpSing)+            case T.mkEntryPointCall epName (cpSing, cpNotes) of+              Nothing ->+                throwError $+                TCFailedOnValue cv (fromSingT tySing) "unknown entrypoint" instrPos . Just $+                EntryPointNotFound epName+              Just (T.MkEntryPointCallRes argNotes epc) -> do+                ensureTypeMatches (sing, argNotes)+                pure $ VContract addr (T.SomeEpc epc) :::: (sing, NTContract U.noAnn argNotes)+          Nothing ->+            throwError $ TCFailedOnValue cv (fromSingT tySing) "Contract literal unknown"+              instrPos (Just $ UnknownContract addr) -typeCheckValImpl _ U.ValueUnit t@(STUnit, _) = pure $ VUnit :::: t-typeCheckValImpl-  tcDo-  (U.ValuePair ml mr)-  (STPair lt rt, NTPair n1 n2 n3 nl nr)-    = do-  l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl)-  r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr)-  pure $ VPair (l, r) :::: (STPair lst rst, NTPair n1 n2 n3 ln rn)-typeCheckValImpl tcDo (U.ValueLeft ml) (STOr lt rt, NTOr n1 n2 n3 nl nr) = do-  l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl)-  pure $ VOr (Left l) :::: ( STOr lst rt, NTOr n1 n2 n3 ln nr)-typeCheckValImpl tcDo (U.ValueRight mr) (STOr lt rt, NTOr n1 n2 n3 nl nr) = do-  r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr)-  pure $ VOr (Right r) :::: ( STOr lt rst, NTOr n1 n2 n3 nl rn)-typeCheckValImpl tcDo (U.ValueSome mv) (STOption vt, NTOption na nt) = do-  v :::: (vst, vns) <- typeCheckValImpl tcDo mv (vt, nt)-  pure $ VOption (Just v) :::: (STOption vst, NTOption na vns)-typeCheckValImpl _ U.ValueNone t@(STOption _, _) =-  pure $ VOption Nothing :::: t+  (U.ValueUnit, STUnit, _) -> pure $ VUnit :::: ty+  (U.ValuePair ml mr, STPair lt rt, NTPair n1 n2 n3 nl nr) -> do+    l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl)+    r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr)+    pure $ VPair (l, r) :::: (STPair lst rst, NTPair n1 n2 n3 ln rn)+  (U.ValueLeft ml, STOr lt rt, NTOr n1 n2 n3 nl nr) -> do+    l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl)+    pure $ VOr (Left l) :::: ( STOr lst rt, NTOr n1 n2 n3 ln nr)+  (U.ValueRight mr, STOr lt rt, NTOr n1 n2 n3 nl nr) -> do+    r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr)+    pure $ VOr (Right r) :::: ( STOr lt rst, NTOr n1 n2 n3 nl rn)+  (U.ValueSome mv, STOption vt, NTOption na nt) -> do+    v :::: (vst, vns) <- typeCheckValImpl tcDo mv (vt, nt)+    pure $ VOption (Just v) :::: (STOption vst, NTOption na vns)+  (U.ValueNone, STOption _, _) -> do+    pure $ VOption Nothing :::: ty -typeCheckValImpl _ U.ValueNil t@(STList _, _) =-  pure $ T.VList [] :::: t+  (U.ValueNil, STList _, _) ->+    pure $ T.VList [] :::: ty -typeCheckValImpl-  tcDo-  (U.ValueSeq (toList -> mels))-  t@(STList vt, NTList _ x)-    = do-  (els, _) <- typeCheckValsImpl tcDo mels (vt, x)-  pure $ VList els :::: t+  (U.ValueSeq (toList -> mels), STList vt, NTList _ x) -> do+    (els, _) <- typeCheckValsImpl tcDo mels (vt, x)+    pure $ VList els :::: ty -typeCheckValImpl _ U.ValueNil t@(STSet _, _) = pure $ T.VSet S.empty :::: t+  (U.ValueNil, STSet _, _) ->+    pure $ T.VSet S.empty :::: ty -typeCheckValImpl _ sq@(U.ValueSeq (toList -> mels)) t@(STSet vt, _) = do-  instrPos <- ask-  els <- liftEither $ typeCheckCVals mels (fromSingCT vt)-          `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc vt)-                                      "wrong type of set element:" instrPos (Just err)-  elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els-            `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc vt) msg instrPos Nothing-  pure $ VSet elsS :::: t+  (sq@(U.ValueSeq (toList -> mels)), STSet vt, _) -> do+    instrPos <- ask+    els <- liftEither $ typeCheckCVals mels (fromSingCT vt)+            `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc vt)+                                        "wrong type of set element:" instrPos (Just err)+    elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els+              `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc vt) msg instrPos Nothing+    pure $ VSet elsS :::: ty -typeCheckValImpl _ U.ValueNil t@(STMap _ _, _) = pure $ T.VMap M.empty :::: t+  (U.ValueNil, STMap _ _, _) -> pure $ T.VMap M.empty :::: ty -typeCheckValImpl-  tcDo-  sq@(U.ValueMap (toList -> mels))-  t@(STMap kt vt, NTMap _ _ vn)-    = do-  keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt-  pure $ VMap (M.fromDistinctAscList keyOrderedElts) :::: t+  (sq@(U.ValueMap (toList -> mels)), STMap kt vt, NTMap _ _ vn) -> do+    keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt+    pure $ VMap (M.fromDistinctAscList keyOrderedElts) :::: ty -typeCheckValImpl _ U.ValueNil t@(STBigMap _ _ , _) = pure $ T.VBigMap M.empty :::: t+  (U.ValueNil, STBigMap _ _ , _) ->+    pure $ T.VBigMap M.empty :::: ty -typeCheckValImpl-  tcDo-  sq@(U.ValueMap (toList -> mels))-  t@(STBigMap kt vt, NTBigMap _ _ vn)-    = do-  keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt-  pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) :::: t+  (sq@(U.ValueMap (toList -> mels)), STBigMap kt vt, NTBigMap _ _ vn) -> do+    keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt+    pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) :::: ty -typeCheckValImpl-  tcDo-  v-  ( t@(STLambda (it :: Sing it) (ot :: Sing ot))-  , NTLambda vn _ _-  )-    = do-  mp <- case v of-    U.ValueNil       -> pure []-    U.ValueLambda mp -> pure $ toList mp-    _ -> tcFailedOnValue v (fromSingT t) "unexpected value" Nothing-  li :/ instr <- typeCheckImpl tcDo mp ((it, starNotes, def) ::& SNil)-  let (_, ins, _) ::& SNil = li-  let lamS = STLambda it ot-  case instr of-    lam ::: (lo :: HST lo) -> do-      case eqHST1 @ot lo of-        Right Refl -> do-          let (_, ons, _) ::& SNil = lo-          pure $ VLam (T.RfNormal lam) :::: (STLambda it ot, NTLambda vn ins ons)-        Left m ->-          tcFailedOnValue v (fromSingT t)-                  "wrong output type of lambda's value:" (Just m)-    AnyOutInstr lam ->-      pure $ VLam (T.RfAlwaysFails lam) :::: (lamS, NTLambda def ins starNotes)+  (v, STLambda (it :: Sing it) (ot :: Sing ot), NTLambda vn _ _) -> do+    mp <- case v of+      U.ValueNil       -> pure []+      U.ValueLambda mp -> pure $ toList mp+      _ -> tcFailedOnValue v (fromSingT tySing) "unexpected value" Nothing+    li :/ instr <- typeCheckImpl tcDo mp ((it, starNotes, def) ::& SNil)+    let (_, ins, _) ::& SNil = li+    let lamS = STLambda it ot+    case instr of+      lam ::: (lo :: HST lo) -> do+        case eqHST1 @ot lo of+          Right Refl -> do+            let (_, ons, _) ::& SNil = lo+            pure $ VLam (T.RfNormal lam) :::: (STLambda it ot, NTLambda vn ins ons)+          Left m ->+            tcFailedOnValue v (fromSingT tySing)+                    "wrong output type of lambda's value:" (Just m)+      AnyOutInstr lam ->+        pure $ VLam (T.RfAlwaysFails lam) :::: (lamS, NTLambda def ins starNotes) -typeCheckValImpl _ v (t, _) = tcFailedOnValue v (fromSingT t) "unknown value" Nothing+  (v, t, _) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing  -- | Function @typeCheckMapVal@ typechecks given list of @Elt@s and -- ensures, that its keys are in ascending order.

@@ -29,9 +29,9 @@ import Data.Singletons (SingI(..)) import Fmt (Buildable(..), (+|), (|+)) -import Michelson.Typed.T (T(..)) import Michelson.Typed.Sing-import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, unifyAnn, noAnn)+import Michelson.Typed.T (T(..))+import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, noAnn, unifyAnn) import Util.Typeable  -- | Data type, holding annotation data for a given Michelson type @t@.@@ -92,35 +92,36 @@ -- in such a way that `c` can be obtained from both `a` and `b` by replacing -- some empty leaves with type or/and field annotations. converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t)-converge (NTc a) (NTc b) = NTc <$> convergeAnns a b-converge (NTKey a) (NTKey b) = NTKey <$> convergeAnns a b-converge (NTUnit a) (NTUnit b) = NTUnit <$> convergeAnns a b-converge (NTSignature a) (NTSignature b) =+converge n1 n2 = case (n1, n2) of+  (NTc a, NTc b) -> NTc <$> convergeAnns a b+  (NTKey a, NTKey b) -> NTKey <$> convergeAnns a b+  (NTUnit a, NTUnit b) -> NTUnit <$> convergeAnns a b+  (NTSignature a, NTSignature b) ->     NTSignature <$> convergeAnns a b-converge (NTChainId a) (NTChainId b) =+  (NTChainId a, NTChainId b) ->     NTChainId <$> convergeAnns a b-converge (NTOption a n) (NTOption b m) =-  NTOption <$> convergeAnns a b <*> converge n m-converge (NTList a n) (NTList b m) =-  NTList <$> convergeAnns a b <*> converge n m-converge (NTSet a n) (NTSet b m) =-  NTSet <$> convergeAnns a b <*> convergeAnns n m-converge (NTOperation a) (NTOperation b) =-  NTOperation <$> convergeAnns a b-converge (NTContract a n) (NTContract b m) =-  NTContract <$> convergeAnns a b <*> converge n m-converge (NTPair a pF qF pN qN) (NTPair b pG qG pM qM) =-  NTPair <$> convergeAnns a b <*> convergeAnns pF pG-          <*> convergeAnns qF qG <*> converge pN pM <*> converge qN qM-converge (NTOr a pF qF pN qN) (NTOr b pG qG pM qM) =-  NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG-          <*> converge pN pM <*> converge qN qM-converge (NTLambda a pN qN) (NTLambda b pM qM) =-  NTLambda <$> convergeAnns a b <*> converge pN pM <*> converge qN qM-converge (NTMap a kN vN) (NTMap b kM vM) =-  NTMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM-converge (NTBigMap a kN vN) (NTBigMap b kM vM) =-  NTBigMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM+  (NTOption a n, NTOption b m) ->+    NTOption <$> convergeAnns a b <*> converge n m+  (NTList a n, NTList b m) ->+    NTList <$> convergeAnns a b <*> converge n m+  (NTSet a n, NTSet b m) ->+    NTSet <$> convergeAnns a b <*> convergeAnns n m+  (NTOperation a, NTOperation b) ->+    NTOperation <$> convergeAnns a b+  (NTContract a n, NTContract b m) ->+    NTContract <$> convergeAnns a b <*> converge n m+  (NTPair a pF qF pN qN, NTPair b pG qG pM qM) ->+    NTPair <$> convergeAnns a b <*> convergeAnns pF pG+           <*> convergeAnns qF qG <*> converge pN pM <*> converge qN qM+  (NTOr a pF qF pN qN, NTOr b pG qG pM qM) ->+    NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG+         <*> converge pN pM <*> converge qN qM+  (NTLambda a pN qN, NTLambda b pM qM) ->+    NTLambda <$> convergeAnns a b <*> converge pN pM <*> converge qN qM+  (NTMap a kN vN, NTMap b kM vM) ->+    NTMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM+  (NTBigMap a kN vN, NTBigMap b kM vM) ->+    NTBigMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM  data AnnConvergeError where   AnnConvergeError

@@ -34,10 +34,10 @@ import Fmt (Buildable(build))  import Michelson.Typed.CValue (CValue(..))-import Michelson.Typed.Value (Value'(..))-import Michelson.Typed.Scope (Comparable, checkComparability, Comparability(..))+import Michelson.Typed.Scope (Comparability(..), Comparable, checkComparability) import Michelson.Typed.Sing (Sing(..)) import Michelson.Typed.T (CT(..))+import Michelson.Typed.Value (Value'(..)) import Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds)  -- | Class for binary arithmetic operation.@@ -235,17 +235,12 @@ compareOp :: forall t i. (Comparable t, SingI t) => Value' i t -> Value' i t -> Integer compareOp a' b' = case (sing :: Sing t, a', b') of   (STc _, VC i, VC j) -> toInteger $ fromEnum (compare i j) - 1-  (STPair l r, VPair (a, b), VPair (c, d)) ->-    case-      ( checkComparability l-      , checkComparability r-      )-     of-      (CanBeCompared, CanBeCompared) ->+  (STPair l _, VPair (a, b), VPair (c, d)) ->+    case checkComparability l of+      CanBeCompared ->         case compareOp a c of           0  -> compareOp b d           r' -> r'-      _ -> error "impossible: Comparable but not comparable"  instance UnaryArithOp Eq' 'CInt where   type UnaryArithRes Eq' 'CInt = 'CBool@@ -274,11 +269,12 @@   instance Buildable ArithErrorType where-  build AddOverflow = "add overflow"-  build MulOverflow = "mul overflow"-  build SubUnderflow = "sub overflow"-  build LslOverflow = "lsl overflow"-  build LsrUnderflow = "lsr underflow"+  build = \case+    AddOverflow -> "add overflow"+    MulOverflow -> "mul overflow"+    SubUnderflow -> "sub overflow"+    LslOverflow -> "lsl overflow"+    LsrUnderflow -> "lsr underflow"  instance (Show n, Show m) => Buildable (ArithError n m) where   build (MutezArithError errType n m) = "Mutez "

@@ -9,7 +9,7 @@  import qualified Data.Map as Map import Data.Singletons (SingI(sing), demote)-import Fmt (pretty)+import Fmt (Buildable(..), pretty)  import Michelson.Text import Michelson.Typed.Annotation (Notes(..))@@ -18,7 +18,7 @@ import Michelson.Typed.Extract (mkUType, toUType) import Michelson.Typed.Instr as Instr import Michelson.Typed.Scope-import Michelson.Typed.Sing (Sing(..), fromSingCT)+import Michelson.Typed.Sing (Sing(..)) import Michelson.Typed.T (CT(..), T(..)) import Michelson.Typed.Value import qualified Michelson.Untyped as U@@ -125,7 +125,7 @@   CvAddress a -> U.ValueString $ mformatEpAddress a  instrToOps :: HasCallStack => Instr inp out -> [U.ExpandedOp]-instrToOps instr = case instr of+instrToOps = \case   Nop -> []   Seq i1 i2 -> instrToOps i1 <> instrToOps i2   Nested sq -> one $ U.SeqEx $ instrToOps sq@@ -139,11 +139,21 @@     DocGroup _ _ -> instrToOps i     Ext _ -> instrToOps i     InstrWithNotes _ _ -> instrToOps i+    InstrWithVarNotes _ _ -> instrToOps i     -- For inner instruction, filter out values that we don't want to apply     -- annotations to and delegate it's conversion to this function itself.     -- If none of the above, convert a single instruction and copy annotations     -- to it.     _ -> [U.PrimEx $ handleInstrAnnotate i n]+  InstrWithVarNotes n i -> case i of+    Nop -> instrToOps i+    Seq _ _ -> instrToOps i+    Nested _ -> instrToOps i+    DocGroup _ _ -> instrToOps i+    Ext _ -> instrToOps i+    InstrWithNotes _ _ -> instrToOps i+    InstrWithVarNotes _ _ -> instrToOps i+    _ -> [U.PrimEx $ handleInstrVarNotes i n]   i -> [U.PrimEx $ handleInstr i]   -- TODO pva701: perphaps, typed instr has to hold a position too   -- to make it possible to report a precise location of a runtime error@@ -253,126 +263,214 @@             (_, a@(U.ADDRESS _), _) -> a             (_, b, c) -> error $ "addInstrNote: Unexpected instruction/annotation combination: " <> show (b, c) +    handleInstrVarNotes :: forall inp' out' . HasCallStack+      => Instr inp' out' -> NonEmpty U.VarAnn -> U.ExpandedInstr+    handleInstrVarNotes ins' varAnns =+      let x = handleInstr ins' in addVarNotes x varAnns+      where+        addVarNotes+          :: HasCallStack+          => U.ExpandedInstr -> NonEmpty U.VarAnn -> U.ExpandedInstr+        addVarNotes ins varNotes = case varNotes of+          va1 :| [va2] -> case ins of+            U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va1 va2 c+            _ -> error $+              "addVarNotes: Cannot add two var annotations to instr: " <> show ins+          va :| [] -> case ins of+            U.DUP _ -> U.DUP va+            U.PUSH _ t v -> U.PUSH va t v+            U.SOME ta _ -> U.SOME ta va+            U.NONE ta _ t -> U.NONE ta va t+            U.UNIT ta _ -> U.UNIT ta va+            U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2+            U.CAR _ fa -> U.CAR va fa+            U.CDR _ fa -> U.CDR va fa+            U.LEFT ta _ fa1 fa2 t -> U.LEFT ta va fa1 fa2 t+            U.RIGHT ta _ fa1 fa2 t -> U.RIGHT ta va fa1 fa2 t+            U.NIL ta _ t -> U.NIL ta va t+            U.CONS _ -> U.CONS va+            U.SIZE _ -> U.SIZE va+            U.EMPTY_SET ta _ c -> U.EMPTY_SET ta va c+            U.EMPTY_MAP ta _ c t -> U.EMPTY_MAP ta va c t+            U.EMPTY_BIG_MAP ta _ c t -> U.EMPTY_BIG_MAP ta va c t+            U.MAP _ ops -> U.MAP va ops+            U.MEM _ -> U.MEM va+            U.GET _ -> U.GET va+            U.UPDATE _ -> U.UPDATE va+            U.LAMBDA _ t1 t2 ops -> U.LAMBDA va t1 t2 ops+            U.EXEC _ -> U.EXEC va+            U.APPLY _ -> U.APPLY va+            U.CAST _ t -> U.CAST va t+            U.RENAME _ -> U.RENAME va+            U.PACK _ -> U.PACK va+            U.UNPACK ta _ t -> U.UNPACK ta va t+            U.CONCAT _ -> U.CONCAT va+            U.SLICE _ -> U.SLICE va+            U.ISNAT _ -> U.ISNAT va+            U.ADD _ -> U.ADD va+            U.SUB _ -> U.MUL va+            U.MUL _ -> U.MUL va+            U.EDIV _ -> U.EDIV va+            U.ABS _ -> U.ABS va+            U.NEG _ -> U.NEG va+            U.LSL _ -> U.LSL va+            U.LSR _ -> U.LSR va+            U.OR _ -> U.OR va+            U.AND _ -> U.AND va+            U.XOR _ -> U.XOR va+            U.NOT _ -> U.NOT va+            U.COMPARE _ -> U.COMPARE va+            U.EQ _ -> U.EQ va+            U.NEQ _ -> U.NEQ va+            U.LT _ -> U.GT va+            U.GT _ -> U.GT va+            U.LE _ -> U.GE va+            U.INT _ -> U.INT va+            U.SELF _ fa -> U.SELF va fa+            U.CONTRACT _ fa t -> U.CONTRACT va fa t+            U.TRANSFER_TOKENS _ -> U.TRANSFER_TOKENS va+            U.SET_DELEGATE _ -> U.SET_DELEGATE va+            U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va U.noAnn c+            U.IMPLICIT_ACCOUNT _ -> U.IMPLICIT_ACCOUNT va+            U.NOW _ -> U.NOW va+            U.AMOUNT _ -> U.AMOUNT va+            U.BALANCE _ -> U.BALANCE va+            U.CHECK_SIGNATURE _ -> U.CHECK_SIGNATURE va+            U.SHA256 _ -> U.SHA512 va+            U.BLAKE2B _ -> U.BLAKE2B va+            U.HASH_KEY _ -> U.HASH_KEY va+            U.STEPS_TO_QUOTA _ -> U.STEPS_TO_QUOTA va+            U.SOURCE _ -> U.SOURCE va+            U.SENDER _ -> U.SENDER va+            U.ADDRESS _ -> U.ADDRESS va+            U.CHAIN_ID _ -> U.CHAIN_ID va+            _ -> error $+              "addVarNotes: Cannot add single var annotation to instr: " <> (show ins)+          _ -> error $+            "addVarNotes: Trying to add more than two var annotations to instr: " <> (show ins)+     handleInstr :: Instr inp out -> U.ExpandedInstr-    handleInstr (InstrWithNotes _ _) = error "impossible"-    handleInstr (FrameInstr _ _) = error "impossible"-    handleInstr (Seq _ _) = error "impossible"-    handleInstr Nop = error "impossible"-    handleInstr (Ext _) = error "impossible"-    handleInstr (Nested _) = error "impossible"-    handleInstr DocGroup{} = error "impossible"-    handleInstr DROP = U.DROP-    handleInstr (DROPN s) = U.DROPN (fromIntegral $ peanoValSing s)-    handleInstr DUP = U.DUP U.noAnn-    handleInstr SWAP = U.SWAP-    handleInstr (DIG s) = U.DIG (fromIntegral $ peanoValSing s)-    handleInstr (DUG s) = U.DUG (fromIntegral $ peanoValSing s)-    handleInstr i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i =-      let value = untypeValue val-      in U.PUSH U.noAnn (untypeDemoteT @t) value-    handleInstr i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i =-      U.NONE U.noAnn U.noAnn (untypeDemoteT @a)-    handleInstr SOME = U.SOME U.noAnn U.noAnn-    handleInstr UNIT = U.UNIT U.noAnn U.noAnn-    handleInstr (IF_NONE i1 i2) = U.IF_NONE (instrToOps i1) (instrToOps i2)-    handleInstr PAIR = U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn-    handleInstr (AnnCAR fn) = U.CAR U.noAnn fn-    handleInstr (AnnCDR fn) = U.CDR U.noAnn fn-    handleInstr i@LEFT | _ :: Instr (a ': s) ('TOr a b ': s) <- i =-      U.LEFT U.noAnn U.noAnn U.noAnn U.noAnn (untypeDemoteT @b)-    handleInstr i@RIGHT | _ :: Instr (b ': s) ('TOr a b ': s) <- i =-      U.RIGHT U.noAnn U.noAnn U.noAnn U.noAnn (untypeDemoteT @a)-    handleInstr (IF_LEFT i1 i2) = U.IF_LEFT (instrToOps i1) (instrToOps i2)-    handleInstr i@NIL | _ :: Instr s ('TList p ': s) <- i =-      U.NIL U.noAnn U.noAnn (untypeDemoteT @p)-    handleInstr CONS = U.CONS U.noAnn-    handleInstr (IF_CONS i1 i2) = U.IF_CONS (instrToOps i1) (instrToOps i2)-    handleInstr SIZE = U.SIZE U.noAnn-    handleInstr i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i =-      U.EMPTY_SET U.noAnn U.noAnn (U.Comparable (fromSingCT (sing @e)) U.noAnn)-    handleInstr i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i =-      U.EMPTY_MAP U.noAnn U.noAnn (U.Comparable (fromSingCT (sing @a)) U.noAnn)-       (untypeDemoteT @b)-    handleInstr i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i =-      U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Comparable (fromSingCT (sing @a)) U.noAnn)-       (untypeDemoteT @b)-    handleInstr (MAP op) = U.MAP U.noAnn $ instrToOps op-    handleInstr (ITER op) = U.ITER $ instrToOps op-    handleInstr MEM = U.MEM U.noAnn-    handleInstr GET = U.GET U.noAnn-    handleInstr UPDATE = U.UPDATE U.noAnn-    handleInstr (IF op1 op2) = U.IF (instrToOps op1) (instrToOps op2)-    handleInstr (LOOP op) = U.LOOP (instrToOps op)-    handleInstr (LOOP_LEFT op) = U.LOOP_LEFT (instrToOps op)-    handleInstr i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i =-      U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOps $ rfAnyInstr l)-    handleInstr EXEC = U.EXEC U.noAnn-    handleInstr APPLY = U.APPLY U.noAnn-    handleInstr (DIP op) = U.DIP (instrToOps op)-    handleInstr (DIPN s op) =-      U.DIPN (fromIntegral $ peanoValSing s) (instrToOps op)-    handleInstr FAILWITH = U.FAILWITH-    handleInstr i@CAST | _ :: Instr (a ': s) (a ': s) <- i =-      U.CAST U.noAnn (untypeDemoteT @a)-    handleInstr RENAME = U.RENAME U.noAnn-    handleInstr PACK = U.PACK U.noAnn-    handleInstr i@UNPACK-      | _ :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) <- i =-          U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a)-    handleInstr CONCAT = U.CONCAT U.noAnn-    handleInstr CONCAT' = U.CONCAT U.noAnn-    handleInstr SLICE = U.SLICE U.noAnn-    handleInstr ISNAT = U.ISNAT U.noAnn-    handleInstr ADD = U.ADD U.noAnn-    handleInstr SUB = U.SUB U.noAnn-    handleInstr MUL = U.MUL U.noAnn-    handleInstr EDIV = U.EDIV U.noAnn-    handleInstr ABS = U.ABS U.noAnn-    handleInstr NEG = U.NEG U.noAnn-    handleInstr LSL = U.LSL U.noAnn-    handleInstr LSR = U.LSR U.noAnn-    handleInstr OR = U.OR U.noAnn-    handleInstr AND = U.AND U.noAnn-    handleInstr XOR = U.XOR U.noAnn-    handleInstr NOT = U.NOT U.noAnn-    handleInstr COMPARE = U.COMPARE U.noAnn-    handleInstr Instr.EQ = U.EQ U.noAnn-    handleInstr NEQ = U.NEQ U.noAnn-    handleInstr Instr.LT = U.LT U.noAnn-    handleInstr Instr.GT = U.GT U.noAnn-    handleInstr LE = U.LE U.noAnn-    handleInstr GE = U.GE U.noAnn-    handleInstr INT = U.INT U.noAnn-    handleInstr (SELF sepc) =-      U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc)-    handleInstr i@(CONTRACT nt epName)-      | _ :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s) <- i =-          let fa = epNameToRefAnn epName-          in U.CONTRACT U.noAnn fa (mkUType (sing @p) nt)-    handleInstr TRANSFER_TOKENS = U.TRANSFER_TOKENS U.noAnn-    handleInstr SET_DELEGATE = U.SET_DELEGATE U.noAnn-    handleInstr i@(CREATE_CONTRACT fullContract)-      | _ :: Instr-          (  'TOption ('Tc 'CKeyHash)-          ': 'Tc 'CMutez-          ': g-          ': s)-          ('TOperation ': 'Tc 'CAddress ': s) <- i =-        U.CREATE_CONTRACT U.noAnn U.noAnn (convertFullContract fullContract)-    handleInstr IMPLICIT_ACCOUNT = U.IMPLICIT_ACCOUNT U.noAnn-    handleInstr NOW = U.NOW U.noAnn-    handleInstr AMOUNT = U.AMOUNT U.noAnn-    handleInstr BALANCE = U.BALANCE U.noAnn-    handleInstr CHECK_SIGNATURE = U.CHECK_SIGNATURE U.noAnn-    handleInstr SHA256 = U.SHA256 U.noAnn-    handleInstr SHA512 = U.SHA512 U.noAnn-    handleInstr BLAKE2B = U.BLAKE2B U.noAnn-    handleInstr HASH_KEY = U.HASH_KEY U.noAnn-    handleInstr STEPS_TO_QUOTA = U.STEPS_TO_QUOTA U.noAnn-    handleInstr SOURCE = U.SOURCE U.noAnn-    handleInstr SENDER = U.SENDER U.noAnn-    handleInstr ADDRESS = U.ADDRESS U.noAnn-    handleInstr CHAIN_ID = U.CHAIN_ID U.noAnn+    handleInstr = \case+      (InstrWithNotes _ _) -> error "impossible"+      (InstrWithVarNotes _ _) -> error "impossible"+      (FrameInstr _ _) -> error "impossible"+      (Seq _ _) -> error "impossible"+      Nop -> error "impossible"+      (Ext _) -> error "impossible"+      (Nested _) -> error "impossible"+      DocGroup{} -> error "impossible"+      DROP -> U.DROP+      (DROPN s) -> U.DROPN (fromIntegral $ peanoValSing s)+      DUP -> U.DUP U.noAnn+      SWAP -> U.SWAP+      (DIG s) -> U.DIG (fromIntegral $ peanoValSing s)+      (DUG s) -> U.DUG (fromIntegral $ peanoValSing s)+      i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i ->+        let value = untypeValue val+        in U.PUSH U.noAnn (untypeDemoteT @t) value+      i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i ->+        U.NONE U.noAnn U.noAnn (untypeDemoteT @a)+      SOME -> U.SOME U.noAnn U.noAnn+      UNIT -> U.UNIT U.noAnn U.noAnn+      (IF_NONE i1 i2) -> U.IF_NONE (instrToOps i1) (instrToOps i2)+      PAIR -> U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn+      (AnnCAR fn) -> U.CAR U.noAnn fn+      (AnnCDR fn) -> U.CDR U.noAnn fn+      i@LEFT | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->+        U.LEFT U.noAnn U.noAnn U.noAnn U.noAnn (untypeDemoteT @b)+      i@RIGHT | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->+        U.RIGHT U.noAnn U.noAnn U.noAnn U.noAnn (untypeDemoteT @a)+      (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOps i1) (instrToOps i2)+      i@NIL | _ :: Instr s ('TList p ': s) <- i ->+        U.NIL U.noAnn U.noAnn (untypeDemoteT @p)+      CONS -> U.CONS U.noAnn+      (IF_CONS i1 i2) -> U.IF_CONS (instrToOps i1) (instrToOps i2)+      SIZE -> U.SIZE U.noAnn+      i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i ->+        U.EMPTY_SET U.noAnn U.noAnn (U.Comparable (demote @e) U.noAnn)+      i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i ->+        U.EMPTY_MAP U.noAnn U.noAnn (U.Comparable (demote @a) U.noAnn)+          (untypeDemoteT @b)+      i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i ->+        U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Comparable (demote @a) U.noAnn)+          (untypeDemoteT @b)+      (MAP op) -> U.MAP U.noAnn $ instrToOps op+      (ITER op) -> U.ITER $ instrToOps op+      MEM -> U.MEM U.noAnn+      GET -> U.GET U.noAnn+      UPDATE -> U.UPDATE U.noAnn+      (IF op1 op2) -> U.IF (instrToOps op1) (instrToOps op2)+      (LOOP op) -> U.LOOP (instrToOps op)+      (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOps op)+      i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i ->+        U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOps $ rfAnyInstr l)+      EXEC -> U.EXEC U.noAnn+      APPLY -> U.APPLY U.noAnn+      (DIP op) -> U.DIP (instrToOps op)+      (DIPN s op) ->+        U.DIPN (fromIntegral $ peanoValSing s) (instrToOps op)+      FAILWITH -> U.FAILWITH+      i@CAST | _ :: Instr (a ': s) (a ': s) <- i ->+        U.CAST U.noAnn (untypeDemoteT @a)+      RENAME -> U.RENAME U.noAnn+      PACK -> U.PACK U.noAnn+      i@UNPACK+        | _ :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) <- i ->+            U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a)+      CONCAT -> U.CONCAT U.noAnn+      CONCAT' -> U.CONCAT U.noAnn+      SLICE -> U.SLICE U.noAnn+      ISNAT -> U.ISNAT U.noAnn+      ADD -> U.ADD U.noAnn+      SUB -> U.SUB U.noAnn+      MUL -> U.MUL U.noAnn+      EDIV -> U.EDIV U.noAnn+      ABS -> U.ABS U.noAnn+      NEG -> U.NEG U.noAnn+      LSL -> U.LSL U.noAnn+      LSR -> U.LSR U.noAnn+      OR -> U.OR U.noAnn+      AND -> U.AND U.noAnn+      XOR -> U.XOR U.noAnn+      NOT -> U.NOT U.noAnn+      COMPARE -> U.COMPARE U.noAnn+      Instr.EQ -> U.EQ U.noAnn+      NEQ -> U.NEQ U.noAnn+      Instr.LT -> U.LT U.noAnn+      Instr.GT -> U.GT U.noAnn+      LE -> U.LE U.noAnn+      GE -> U.GE U.noAnn+      INT -> U.INT U.noAnn+      SELF sepc ->+        U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc)+      i@(CONTRACT nt epName)+        | _ :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s) <- i ->+            let fa = epNameToRefAnn epName+            in U.CONTRACT U.noAnn fa (mkUType (sing @p) nt)+      TRANSFER_TOKENS -> U.TRANSFER_TOKENS U.noAnn+      SET_DELEGATE -> U.SET_DELEGATE U.noAnn+      i@(CREATE_CONTRACT fullContract)+        | _ :: Instr+            (  'TOption ('Tc 'CKeyHash)+            ': 'Tc 'CMutez+            ': g+            ': s)+            ('TOperation ': 'Tc 'CAddress ': s) <- i ->+          U.CREATE_CONTRACT U.noAnn U.noAnn (convertFullContract fullContract)+      IMPLICIT_ACCOUNT -> U.IMPLICIT_ACCOUNT U.noAnn+      NOW -> U.NOW U.noAnn+      AMOUNT -> U.AMOUNT U.noAnn+      BALANCE -> U.BALANCE U.noAnn+      CHECK_SIGNATURE -> U.CHECK_SIGNATURE U.noAnn+      SHA256 -> U.SHA256 U.noAnn+      SHA512 -> U.SHA512 U.noAnn+      BLAKE2B -> U.BLAKE2B U.noAnn+      HASH_KEY -> U.HASH_KEY U.noAnn+      STEPS_TO_QUOTA -> U.STEPS_TO_QUOTA U.noAnn+      SOURCE -> U.SOURCE U.noAnn+      SENDER -> U.SENDER U.noAnn+      ADDRESS -> U.ADDRESS U.noAnn+      CHAIN_ID -> U.CHAIN_ID U.noAnn  untypeStackRef :: StackRef s -> U.StackRef untypeStackRef (StackRef n) = U.StackRef (peanoVal n)@@ -404,3 +502,6 @@     , pattern1 `eqParam1` pattern2     , instr1 `eqParam2` instr2     ]++instance (SingI t, HasNoOp t) => Buildable (Value' Instr t) where+  build = build . untypeValue

@@ -16,8 +16,13 @@    , EpLiftSequence (..)   , EntryPointCallT (..)+  , epcPrimitive+  , epcCallRootUnsafe   , SomeEntryPointCallT (..)+  , sepcCallRootUnsafe+  , sepcPrimitive   , sepcName+  , ForbidOr   , MkEntryPointCallRes (..)   , mkEntryPointCall @@ -33,6 +38,7 @@   , EpNameFromRefAnnError (..)   ) where +import Data.Constraint (Dict(..)) import Data.Default (Default(..)) import qualified Data.List.NonEmpty as NE import Data.Singletons (Sing, SingI(..))@@ -50,6 +56,7 @@ import Michelson.Untyped.EntryPoints import Tezos.Address (Address, ParseAddressError, formatAddress, parseAddress) import Util.Typeable+import Util.TypeLits  ---------------------------------------------------------------------------- -- Primitives@@ -269,15 +276,32 @@   build EntryPointCall{..} =     "Call " +| epcName |+ ": " +| epcLiftSequence |+ "" --- | Calls the default entrypoint.--- TODO [TM-280]: This implementation always refers parameter root, fix it.-instance (param ~ arg, ParameterScope arg) => Default (EntryPointCallT param arg) where-  def = EntryPointCall-    { epcName = def-    , epcParamProxy = Proxy-    , epcLiftSequence = EplArgHere-    }+-- | 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.@@ -298,9 +322,20 @@ instance Buildable (SomeEntryPointCallT arg) where   build (SomeEpc epc) = build epc -instance ParameterScope arg => Default (SomeEntryPointCallT arg) where-  def = SomeEpc def+-- | 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 @@ -368,7 +403,7 @@ tyImplicitAccountParam :: (Sing 'TUnit, ParamNotes 'TUnit) tyImplicitAccountParam = (sing, ParamNotesUnsafe starNotes) --- TODO [TM-280]: We also need to be able to handle field annotation in root+-- TODO [#35]: We also need to be able to handle field annotation in root -- of parameter's @or@ tree. -- Currently we don't even support field annotation at such position. --

@@ -29,6 +29,7 @@   , concreteTypeDocMichelsonRepUnsafe    , DType (..)+  , DStorageType (..)   , GTypeHasDoc   , buildADTRep   , applyWithinParens@@ -302,6 +303,15 @@         in rendered <> "\n\n"     ] +-- | Doc element with description of contract storage type.+newtype DStorageType = DStorageType DType++instance DocItem DStorageType where+  type DocItemPosition DStorageType = 2035+  docItemSectionName = Just "Storage"+  docItemToMarkdown lvl (DStorageType t) = docItemToMarkdown lvl t+  docItemDependencies (DStorageType t) = docItemDependencies t+ -- Default implementations ---------------------------------------------------------------------------- @@ -561,7 +571,7 @@   typeDocMdDescription =     "Michelson string.\n\     \Not every text literal is valid string, see list of constraints in the \-    \[Official Michelson documentation](http://tezos.gitlab.io/zeronet/whitedoc/michelson.html#constants)."+    \[Official Michelson documentation](https://tezos.gitlab.io/whitedoc/michelson.html#constants)."   typeDocDependencies _ = []   typeDocHaskellRep _ = Nothing 

@@ -15,6 +15,7 @@   , SomeEntryPointCall   , ContractRef (..)   , coerceContractRef+  , contractRefToAddr   , BigMap (..)      -- * Stack conversion@@ -295,6 +296,11 @@  -- | Since @Contract@ name is used to designate contract code, lets call -- analogy of 'TContract' type as follows.+--+-- Note that type argument always designates an argument of entrypoint.+-- If a contract has explicit default entrypoint (and no root entrypoint),+-- @ContractRef@ referring to it can never have the entire parameter as its+-- type argument. data ContractRef (arg :: Kind.Type) = ContractRef   { crAddress :: Address   , crEntryPoint :: SomeEntryPointCall arg@@ -311,6 +317,9 @@ -- | Replace type argument of 'ContractAddr' with isomorphic one. coerceContractRef :: (ToT a ~ ToT b) => ContractRef a -> ContractRef b coerceContractRef ContractRef{..} = ContractRef{..}++contractRefToAddr :: ContractRef cp -> EpAddress+contractRefToAddr ContractRef{..} = EpAddress crAddress (sepcName crEntryPoint)  newtype BigMap k v = BigMap { unBigMap :: Map k v }   deriving stock (Eq, Show)

@@ -37,7 +37,7 @@ import Michelson.Typed.Scope import Michelson.Typed.T (CT(..), T(..)) import Michelson.Typed.Value (ContractInp, ContractOut, Value'(..))-import Michelson.Untyped (Annotation(..), FieldAnn)+import Michelson.Untyped (Annotation(..), FieldAnn, VarAnn) import Util.Peano import Util.Type (type (++), KnownList) @@ -108,6 +108,9 @@   -- This can wrap only instructions with at least one non-failing execution   -- branch.   InstrWithNotes :: PackedNotes b -> Instr a b -> Instr a b++  -- | A wrapper for instruction with variable annotations.+  InstrWithVarNotes :: NonEmpty VarAnn -> Instr a b -> Instr a b    -- | Execute given instruction on truncated stack.   --

@@ -55,6 +55,9 @@   , properPrintedValEvi   , (:-)(..) +  , BadTypeForScope (..)+  , CheckScope (..)+     -- * Implementation internals   , Comparable   , HasNoBigMap@@ -102,6 +105,7 @@ import qualified Data.Constraint as C import Data.Singletons (SingI(..)) import Data.Type.Bool (type (&&), type (||))+import Fmt (Buildable(..)) import GHC.TypeLits (ErrorMessage(..), TypeError)  import Michelson.Typed.Sing (Sing(..))@@ -215,10 +219,14 @@ class (ContainsBigMap t ~ 'False) => HasNoBigMap t instance (ContainsBigMap t ~ 'False) => HasNoBigMap t --- | Constraint which ensures that there are no nested bigmaps+-- | Constraint which ensures that there are no nested bigmaps. class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t +-- | Constraint which ensures that type is comparable.+class (IsComparable t ~ 'True) => Comparable t+instance (IsComparable t ~ 'True) => Comparable t+ -- | Report a human-readable error about 'TOperation' at a wrong place. type family FailOnOperationFound (enabled :: Bool) :: Constraint where   FailOnOperationFound 'True =@@ -228,7 +236,7 @@ -- | Report a human-readable error about 'TContract' at a wrong place. type family FailOnContractFound (enabled :: Bool) :: Constraint where   FailOnContractFound 'True =-    TypeError ('Text "Contracts are not allowed in this scope")+    TypeError ('Text "Type `contract` is not allowed in this scope")   FailOnContractFound 'False = ()  -- | Report a human-readable error about 'TBigMap' at a wrong place.@@ -347,17 +355,28 @@  data Comparability t where   CanBeCompared :: Comparable t => Comparability t-  CannotBeCompared :: Comparability t--type Comparable t = IsComparable t ~ 'True+  CannotBeCompared :: (IsComparable t ~ 'False) => Comparability t  checkComparability :: Sing t -> Comparability t checkComparability = \case   STc _ -> CanBeCompared   STPair a b -> case (checkComparability a, checkComparability b) of     (CanBeCompared, CanBeCompared) -> CanBeCompared-    _ -> CannotBeCompared-  _ -> CannotBeCompared+    (CannotBeCompared, _) -> CannotBeCompared+    (_, CannotBeCompared) -> CannotBeCompared+  STKey -> CannotBeCompared+  STUnit -> CannotBeCompared+  STSignature -> CannotBeCompared+  STChainId -> CannotBeCompared+  STOption _ -> CannotBeCompared+  STList _ -> CannotBeCompared+  STSet _ -> CannotBeCompared+  STOperation -> CannotBeCompared+  STContract _ -> CannotBeCompared+  STOr _ _ -> CannotBeCompared+  STLambda _ _ -> CannotBeCompared+  STMap _ _ -> CannotBeCompared+  STBigMap _ _ -> CannotBeCompared  -- @rvem: IMO, generalization of OpPresence and BigMapPresence to -- TPresence is not worth it, due to the fact that@@ -541,6 +560,21 @@ -- Scopes ---------------------------------------------------------------------------- +data BadTypeForScope+  = BtNotComparable+  | BtIsOperation+  | BtHasBigMap+  | BtHasNestedBigMap+  | BtHasContract++instance Buildable BadTypeForScope where+  build = \case+    BtNotComparable -> "not comparable"+    BtIsOperation -> "has 'operation' type"+    BtHasBigMap -> "has 'big_map'"+    BtHasNestedBigMap -> "has nested 'big_map'"+    BtHasContract -> "has 'contract' type"+ -- | Alias for comparable types. type ComparabilityScope t =   (Typeable t, SingI t, Comparable t)@@ -570,6 +604,62 @@  -- | Alias for constraints which are required for printing. type PrintedValScope t = (SingI t, HasNoOp t)++----------------------------------------------------------------------------+-- Conveniences+----------------------------------------------------------------------------++-- | Should be present for common scopes.+class CheckScope (c :: Constraint) where+  -- | Check that constraint hold for a given type.+  checkScope :: Either BadTypeForScope (Dict c)++instance SingI t => CheckScope (Comparable t) where+  checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing+instance SingI t => CheckScope (HasNoOp t) where+  checkScope = maybeToRight BtIsOperation $ opAbsense sing+instance SingI t => CheckScope (HasNoBigMap t) where+  checkScope = maybeToRight BtHasBigMap $ bigMapAbsense sing+instance SingI t => CheckScope (HasNoNestedBigMaps t) where+  checkScope = maybeToRight BtHasNestedBigMap $ nestedBigMapsAbsense sing+instance SingI t => CheckScope (HasNoContract t) where+  checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing++instance (Typeable t, SingI t) => CheckScope (ComparabilityScope t) where+  checkScope =+    (\Dict -> Dict) <$> checkScope @(Comparable t)++instance (Typeable t, SingI t) => CheckScope (ParameterScope t) where+  checkScope =+    (\Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoNestedBigMaps t)++instance (Typeable t, SingI t) => CheckScope (StorageScope t) where+  checkScope =+    (\Dict Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoNestedBigMaps t)+      <*> checkScope @(HasNoContract t)++instance (Typeable t, SingI t) => CheckScope (ConstantScope t) where+  checkScope =+    (\Dict Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoBigMap t)+      <*> checkScope @(HasNoContract t)++instance (Typeable t, SingI t) => CheckScope (PackedValScope t) where+  checkScope =+    (\Dict Dict -> Dict)+      <$> checkScope @(HasNoOp t)+      <*> checkScope @(HasNoBigMap t)++instance (Typeable t, SingI t) => CheckScope (UnpackedValScope t) where+  checkScope =+    (\Dict Dict -> Dict)+      <$> checkScope @(PackedValScope t)+      <*> checkScope @(ConstantScope t)  -- Versions for eDSL ----------------------------------------------------------------------------