morley 1.12.0 → 1.13.0

raw patch · 54 files changed

+2858/−654 lines, 54 filesdep +Cabaldep +MonadRandomdep +base-nopreludedep −basedep ~morley-preludePVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, MonadRandom, base-noprelude, doctest, elliptic-curve, galois-field, pairing, process

Dependencies removed: base

Dependency ranges changed: morley-prelude

API changes (from Hackage documentation)

Files

• CHANGES.md +24/−1
• doctests/Main.hs +171/−0
• morley.cabal +32/−8
• src/Michelson/Doc.hs +1/−1
• src/Michelson/Interpret.hs +145/−63
• src/Michelson/Interpret/Pack.hs +49/−7
• src/Michelson/Interpret/Unpack.hs +108/−34
• src/Michelson/Macro.hs +15/−13
• src/Michelson/Optimizer.hs +10/−0
• src/Michelson/Parser.hs +3/−3
• src/Michelson/Parser/Instr.hs +50/−8
• src/Michelson/Parser/Macro.hs +0/−4
• src/Michelson/Parser/Type.hs +28/−6
• src/Michelson/Runtime.hs +6/−2
• src/Michelson/Runtime/Dummy.hs +3/−1
• src/Michelson/Runtime/GState.hs +49/−0
• src/Michelson/Text.hs +1/−1
• src/Michelson/TypeCheck/Error.hs +67/−83
• src/Michelson/TypeCheck/Helpers.hs +165/−42
• src/Michelson/TypeCheck/Instr.hs +348/−134
• src/Michelson/TypeCheck/Types.hs +5/−1
• src/Michelson/TypeCheck/Value.hs +15/−0
• src/Michelson/Typed/Annotation.hs +47/−14
• src/Michelson/Typed/Arith.hs +115/−23
• src/Michelson/Typed/Convert.hs +103/−79
• src/Michelson/Typed/Extract.hs +20/−4
• src/Michelson/Typed/Haskell/Doc.hs +6/−6
• src/Michelson/Typed/Haskell/Instr/Sum.hs +1/−1
• src/Michelson/Typed/Haskell/Value.hs +33/−2
• src/Michelson/Typed/Instr.hs +311/−22
• src/Michelson/Typed/Polymorphic.hs +13/−6
• src/Michelson/Typed/Scope.hs +16/−0
• src/Michelson/Typed/Sing.hs +20/−0
• src/Michelson/Typed/T.hs +9/−1
• src/Michelson/Typed/TypeLevel.hs +59/−0
• src/Michelson/Typed/Util.hs +29/−0
• src/Michelson/Typed/Value.hs +41/−13
• src/Michelson/Untyped/Annotation.hs +53/−4
• src/Michelson/Untyped/Instr.hs +20/−0
• src/Michelson/Untyped/OpSize.hs +17/−2
• src/Michelson/Untyped/Type.hs +14/−6
• src/Morley/Micheline/Binary.hs +1/−1
• src/Morley/Micheline/Expression.hs +46/−30
• src/Morley/Micheline/Json.hs +13/−0
• src/Tezos/Core.hs +6/−5
• src/Tezos/Crypto.hs +22/−2
• src/Tezos/Crypto/BLS12381.hs +449/−0
• src/Tezos/Crypto/Ed25519.hs +3/−0
• src/Tezos/Crypto/P256.hs +3/−0
• src/Tezos/Crypto/Secp256k1.hs +3/−0
• src/Util/Named.hs +3/−0
• src/Util/Peano.hs +33/−2
• src/Util/Type.hs +1/−1
• src/Util/TypeLits.hs +53/−18

@@ -2,10 +2,33 @@ ========== <!-- Append new entries here --> +1.13.0+======+* [!774](https://gitlab.com/morley-framework/morley/-/merge_requests/774)+  + Added support for `BLS12-381` crypto primitives.+* [!776](https://gitlab.com/morley-framework/morley/-/merge_requests/776)+  + Added support for `DUP n` instruction.+* [!755](https://gitlab.com/morley-framework/morley/-/merge_requests/755)+  Restricted `FAILWITH` only to packable values, except `CONTRACT`s+* [!781](https://gitlab.com/morley-framework/morley/-/merge_requests/781)+  + Replaced mixins and dependency on `base` with `base-noprelude`.+  + Added doctest examples and enabled `doctest` tests in `morley:lib`.+* [!764](https://gitlab.com/morley-framework/morley/-/merge_requests/764)+  + Added support for `never` type.+* [!750](https://gitlab.com/morley-framework/morley/-/merge_requests/750)+  [!769](https://gitlab.com/morley-framework/morley/-/merge_requests/769)+  [!786](https://gitlab.com/morley-framework/morley/-/merge_requests/786)+  [!791](https://gitlab.com/morley-framework/morley/-/merge_requests/791)+  + Added support for `PAIR n`, `UNPAIR n`, `GET n` and `UPDATE n` instructions.+* [!778](https://gitlab.com/morley-framework/morley/-/merge_requests/778)+  + Added support for `VOTING_POWER` and `TOTAL_VOTING_POWER` instructions.+* [!767](https://gitlab.com/morley-framework/morley/-/merge_requests/767)+  Made `unit`, `key`, `signature`, `chain_id`, `option`, `or` types+  comparable in preparation for `edo` switch.  1.12.0 ======-* [!751](https://gitlab.com/morley-framework/morley/-/merge_requests/741)+* [!751](https://gitlab.com/morley-framework/morley/-/merge_requests/751)   + Added support for `LEVEL` instruction.   + Added --level parameter to `morley` executable * [!753](https://gitlab.com/morley-framework/morley/-/merge_requests/753)

@@ -0,0 +1,171 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import qualified Data.ByteString as BS+import Data.Char (isSpace)+import qualified Data.List as List+import Distribution.Fields (runParseResult, showPError)+import Distribution.PackageDescription+  (BuildInfo(defaultExtensions, targetBuildDepends), CondTree(condTreeData),+  GenericPackageDescription(condLibrary), Library(libBuildInfo))+import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)+import Distribution.Simple (Extension(EnableExtension), depPkgName, unPackageName)+import Options.Applicative+  (ParserInfo, execParser, flag', fullDesc, help, helper, info, long, metavar, progDesc, short,+  showDefault, strArgument, strOption, value)+import System.Environment (lookupEnv)+import System.Process (readProcess)+import Test.DocTest (doctest)++-- | Runs 'doctest' on the 'morley' package.+--+-- To run via stack, simply run:+--+-- > stack test morley:test:doctests+--+-- Otherwise, you'll need to specify 3 things:+--+-- * The location of the GHC's package database+-- * The location of morley's source code+-- * The location of morley's cabal file+--+-- > ./doctests --cabal-file code/morley/morley.cabal -- -package-db=<pkg-db-dir> -i code/morley/src+--+-- Any other arguments passed to this program will be forwarded to @doctest@.+main :: IO ()+main = do+  opts <- execParser parserInfo+  doctestArgs <- getDoctestArgs opts++  log opts "Running doctest with args:"+  traverse_ (log opts . mappend "  ") doctestArgs++  putTextLn "Running doctest."+  doctest doctestArgs++data Options = Options+  { cabalFile :: FilePath+  , verbosity :: Maybe Int+  , otherArgs :: [String]+  }+  deriving stock Show++parserInfo :: ParserInfo Options+parserInfo =+  info+    (optionsParser <**> helper)+    (mconcat+      [ fullDesc+      , progDesc "Run doctests. All arguments passed after '--' will be passed down to doctest and GHC."+      ]+    )+  where+    optionsParser =+      Options+      <$> strOption+          (mconcat+            [ long "cabal-file"+            , value "morley.cabal"+            , showDefault+            , metavar "FILEPATH"+            , help "Filepath for the .cabal file"+            ]+          )+      <*> (fmap (fmap length) . optional . some . flag' () . mconcat $+            [ short 'V'+            , help "Increase verbosity (pass up to 5 times to increase further, e.g. '-VVV').\+                   \ This flag will be passed down to doctest and GHC."+            ]+          )+      <*> many (strArgument (metavar "ARGS..." ))++-- | Get all the arguments needed to run `doctest`.+getDoctestArgs :: Options -> IO [String]+getDoctestArgs opts = do+  lib <- getCabalLibComponent opts+  argsFromStack <- getArgsFromStack opts++  pure $+    [ "-package-env=-"+    , "-hide-all-packages"+    ]+    <> maybeToList (getGHCVerbosityFlag opts)+    <> argsFromStack+    <> (getDependencies lib <&> \pkg -> "-package=" <> pkg)+    <> (getEnabledExtensions lib <&> \ext -> "-X" <> ext)+    <> otherArgs opts++-- | If this program is running via @stack@, then we can:+--+-- * guess where the source code is located+-- * use @stack@ to find out where the package database is located+--+-- Otherwise, these arguments will have to be specified by the user, via the+-- @-package-db@ and @-i@ flags.+getArgsFromStack :: Options -> IO [String]+getArgsFromStack opts = do+  -- If 'STACK_EXE' is set, we assume we're running via 'stack' and not,+  -- for example, via cabal or haskell.nix.+  lookupEnv "STACK_EXE" >>= \case+    Nothing ->  do+      log opts "The environment variable 'STACK_EXE' is not set."+      pure []+    Just stackBin -> do+      log opts $ "The environment variable 'STACK_EXE' is set: " <> stackBin+      log opts "Assuming we're running via stack."+      snapshotPkgDb <- readProcess stackBin ["path", "--snapshot-pkg-db"] []+      localPkgDb <- readProcess stackBin ["path", "--local-pkg-db"] []+      pure+        [ "-package-db=" <> List.dropWhileEnd isSpace snapshotPkgDb+        , "-package-db=" <> List.dropWhileEnd isSpace localPkgDb+        , "-i", "src"+        ]++-- | Parse a cabal file and extract info about its "library" component.+getCabalLibComponent :: Options -> IO Library+getCabalLibComponent opts = do+  let cabalFilePath = cabalFile opts+  log opts $ "Reading cabal file:" <> cabalFilePath+  contents <- BS.readFile cabalFilePath+  case snd <$> runParseResult $ parseGenericPackageDescription contents of+    Left (version, errs) -> do+      die $ toString $ List.unlines $+        [ "Failed to parse .cabal file: " <> cabalFilePath+        , "Version: " <> show version+        , "Errors:"+        ]+        <> (showPError cabalFilePath <$> errs)+    Right cabal -> do+      case condLibrary cabal of+        Nothing -> die "Cabal file did not contain a library component."+        Just condTreeLib -> pure $ condTreeData condTreeLib++getEnabledExtensions :: Library -> [String]+getEnabledExtensions lib =+  libBuildInfo lib & defaultExtensions & mapMaybe \case+    EnableExtension extension -> Just $ show extension+    _ -> Nothing++getDependencies :: Library -> [String]+getDependencies lib =+  libBuildInfo lib & targetBuildDepends & fmap (unPackageName . depPkgName)++-- | Due to a limitation in optparse-applicative, our @-V@ flag has a+-- different syntax than GHC's @-v@ flag.+--+-- Our @-VVV@ corresponds to @-v3@ in GHC.+--+-- This function transforms our syntax into GHC's.+getGHCVerbosityFlag :: Options -> Maybe String+getGHCVerbosityFlag opts =+  verbosity opts <&> \i -> "-v" <> show i++log :: Options -> String -> IO ()+log opts msg =+  whenJust (verbosity opts) \_ ->+    putStrLn msg

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morley-version:        1.12.0+version:        1.13.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@@ -103,6 +103,7 @@       Michelson.Typed.Scope       Michelson.Typed.Sing       Michelson.Typed.T+      Michelson.Typed.TypeLevel       Michelson.Typed.Util       Michelson.Typed.Value       Michelson.Untyped@@ -124,6 +125,7 @@       Tezos.Address       Tezos.Core       Tezos.Crypto+      Tezos.Crypto.BLS12381       Tezos.Crypto.Ed25519       Tezos.Crypto.Hash       Tezos.Crypto.P256@@ -164,10 +166,11 @@   default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude   build-depends:-      aeson+      MonadRandom+    , aeson     , aeson-casing     , aeson-pretty-    , base >=4.7 && <5+    , base-noprelude >=4.7 && <5     , base58-bytestring     , binary     , bytestring@@ -175,8 +178,10 @@     , containers     , cryptonite     , data-default+    , elliptic-curve     , first-class-families >=0.5.0.0     , fmt+    , galois-field     , generic-deriving     , gitrev     , hex-text@@ -188,6 +193,7 @@     , mtl     , named     , optparse-applicative+    , pairing     , parser-combinators >=1.0.0     , scientific     , semigroups >=0.19.1@@ -207,8 +213,6 @@     , vinyl     , with-utf8     , wl-pprint-text-  mixins:-      base hiding (Prelude)   default-language: Haskell2010  executable morley@@ -224,7 +228,7 @@   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude   build-depends:       aeson-    , base >=4.7 && <5+    , base-noprelude >=4.7 && <5     , bytestring     , data-default     , fmt@@ -237,6 +241,26 @@     , text     , vinyl     , with-utf8-  mixins:-      base hiding (Prelude)+  default-language: Haskell2010++test-suite doctests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_morley+  hs-source-dirs:+      doctests+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      Cabal+    , base-noprelude >=4.7 && <5+    , bytestring+    , doctest+    , morley+    , morley-prelude+    , optparse-applicative+    , process   default-language: Haskell2010

@@ -689,7 +689,7 @@ -- | Make 'DGitRevision'. -- -- >>> :t $mkDGitRevision--- GitRepoSettings -> DGitRevision+-- ... :: GitRepoSettings -> DGitRevision mkDGitRevision :: TH.ExpQ mkDGitRevision = [e| \dgrRepoSettings ->   maybe DGitRevisionUnknown DGitRevisionKnown $

@@ -27,6 +27,7 @@   , EvalM   , InterpreterStateMonad (..)   , StkEl (..)+  , starNotesStkEl   , InstrRunner   , runInstr   , runInstrNoGas@@ -52,14 +53,16 @@  import Michelson.Interpret.Pack (packValue') import Michelson.Interpret.Unpack (UnpackError, unpackValue')+import Michelson.Runtime.GState import Michelson.TypeCheck (SomeParamType(..), TcOriginatedContracts, matchTypes)-import Michelson.Typed+import Michelson.Typed hiding (Branch(..)) import qualified Michelson.Typed as T import Michelson.Typed.Origination (OriginationOperation(..), mkOriginationOperationHash) import qualified Michelson.Untyped as U import Tezos.Address (Address(..), GlobalCounter(..), OriginationIndex(..), mkContractAddress) import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, keccak, sha256, sha3, sha512)+import Tezos.Crypto.BLS12381 (checkPairing) import Util.Peano (LongerThan, Peano, SingNat(SS, SZ)) import Util.TH import Util.Type@@ -84,6 +87,8 @@   -- ^ The contract that initiated the current internal transaction.   , ceAmount :: Mutez   -- ^ Amount of the current transaction.+  , ceVotingPowers :: VotingPowers+  -- ^ Distribution of voting power.   , ceChainId :: ChainId   -- ^ Identifier of the current chain.   , ceOperationHash :: Maybe U.OperationHash@@ -189,7 +194,6 @@ handleContractReturn (ei, s) =   bimap (InterpretError . (, isMorleyLogs s)) (constructIR . (, s)) ei --- | Function to change amount of remaining steps stored in State monad -- | Helper function to convert a record of @Value@ to @StkEl@. These will be -- created with @starNotes@. mapToStkEl :: Rec T.Value inp -> Rec StkEl inp@@ -224,7 +228,7 @@ mkInitStack param T.ParamNotesUnsafe{..} st stNotes = StkEl   (T.VPair (param, st))   U.noAnn-  (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn pnNotes stNotes)+  (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn "parameter" "storage" pnNotes stNotes)     :& RNil  fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st)@@ -322,8 +326,8 @@   modifyInterpreterState f = stateInterpreterState (((), ) . f)  instance InterpreterStateMonad (ExceptT MichelsonFailed $-                              ReaderT ContractEnv $-                                 State InterpreterState) where+                                ReaderT ContractEnv $+                                State InterpreterState) where   stateInterpreterState f = lift $ lift $ state f  type EvalM m =@@ -353,6 +357,7 @@ runInstr i@(WithLoc _ _) r = runInstrImpl runInstr i r runInstr i@(InstrWithNotes _ _i1) r = runInstrImpl runInstr i r runInstr i@(InstrWithVarNotes _ _i1) r = runInstrImpl runInstr i r+runInstr i@(InstrWithVarAnns _ _i1) r = runInstrImpl runInstr i r runInstr i@Nop r = runInstrImpl runInstr i r runInstr i@(Nested _) r = runInstrImpl runInstr i r runInstr i r = do@@ -371,17 +376,17 @@ runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r' runInstrImpl runner (WithLoc _ i) r = runner i r runInstrImpl runner (InstrWithNotes (PackedNotes n) i) inp =+  runner i inp <&> \(StkEl v vn _ :& r) -> StkEl v vn n :& r+runInstrImpl runner (InstrWithVarNotes _vns i) inp = runner i inp+runInstrImpl runner (InstrWithVarAnns vns i) inp = do   runner i inp <&> \case-    StkEl v vn _ :& r -> StkEl v vn n :& r-runInstrImpl runner (InstrWithVarNotes (toList -> vns) i) inp = do-  out <- runner i inp-  let zipRec :: [U.VarAnn] -> Rec StkEl rs -> Rec StkEl rs-      zipRec [] RNil = RNil-      zipRec (vn : rs) stk = case stk of-        StkEl v _ n :& r -> StkEl v vn n :& zipRec rs r-        RNil -> error "Output stack is exhausted but there are still var annotations"-      zipRec [] sm = sm-  pure $ zipRec vns out+    StkEl v1 _ n1 :& StkEl v2 vn2 n2 :& r -> case vns of+      U.OneVarAnn vn      -> StkEl v1 vn n1 :& StkEl v2 vn2 n2 :& r+      U.TwoVarAnns vn vn' -> StkEl v1 vn n1 :& StkEl v2 vn' n2 :& r+    StkEl v _ n :& r -> case vns of+      U.OneVarAnn vn   -> StkEl v vn n :& r+      U.TwoVarAnns _ _ -> error "Input stack is exhausted but there is still a variable annotation."+    RNil -> error "Input stack is exhausted but there is still variables annotations." runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do   let (inp, end) = rsplit @_ @_ @s r   out <- runInstrImpl runner i inp@@ -404,36 +409,86 @@       -- by a natural number like 'DIPN'.       (_ :& r) -> runInstrImpl runner (DROPN s') r runInstrImpl _ DUP (a :& r) = pure $ a :& a :& r+runInstrImpl _ (DUPN nSing) stack = pure $ go nSing stack+  where+    go :: forall (n :: Peano) inp out a. ConstraintDUPN n inp out a+       => Sing n -> Rec StkEl inp -> Rec StkEl out+    go = curry \case+      -- Discard variable annotations. This is consistent with tezos-client.+      (SS SZ, i@(StkEl a _ n :& _)) -> StkEl a U.noAnn n :& i+      (SS s@(SS _), b :& r) -> case go s r of+        (a :& resTail) -> a :& b :& resTail runInstrImpl _ SWAP (a :& b :& r) = pure $ b :& a :& r runInstrImpl _ (DIG nSing0) input0 =-  pure $ go (nSing0, input0)+  pure $ go nSing0 input0   where-    go :: forall (n :: Peano) inp out a. T.ConstraintDIG n inp out a =>-      (Sing n, Rec StkEl inp) -> Rec StkEl out-    go = \case-      (SZ, stack) ->  stack-      (SS nSing, b :& r) -> case go (nSing, r) of+    go :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a+       => Sing n -> Rec StkEl inp -> Rec StkEl out+    go = curry \case+      (SZ, stack) -> stack+      (SS nSing, b :& r) -> case go nSing r of         (a :& resTail) -> a :& b :& resTail runInstrImpl _ (DUG nSing0) input0 =-  pure $ go (nSing0, input0)+  pure $ go nSing0 input0   where-    go :: forall (n :: Peano) inp out a. T.ConstraintDUG n inp out a =>-      (Sing n, Rec StkEl inp) -> Rec StkEl out-    go = \case+    go :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a+       => Sing n -> Rec StkEl inp -> Rec StkEl out+    go = curry \case       (SZ, stack) -> stack-      (SS s', a :& b :& r) -> b :& go (s', a :& r)+      (SS s', a :& b :& r) -> b :& go s' (a :& r) runInstrImpl _ SOME ((seValue -> a) :& r) =   withValueTypeSanity a $     pure $ starNotesStkEl (VOption (Just a)) :& r runInstrImpl _ (PUSH v) r = pure $ starNotesStkEl v :& r runInstrImpl _ NONE r = pure $ starNotesStkEl (VOption Nothing) :& r runInstrImpl _ UNIT r = pure $ starNotesStkEl VUnit :& r-runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) _ _ :& r) =-  runner bJust (starNotesStkEl a :& r)+runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) vn (NTOption _ n) :& r) =+  runner bJust (StkEl a vn n :& r) runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) _ _ :& r) =   runner bNone r-runInstrImpl _ (AnnPAIR nt nf1 nf2) ((StkEl a _ na) :& (StkEl b _ nb) :& r) =-  pure $ StkEl (VPair (a, b)) U.noAnn (NTPair nt nf1 nf2 na nb) :& r+runInstrImpl _ NEVER inp = case inp of {}+runInstrImpl _ (AnnPAIR{}) ((StkEl a _ _) :& (StkEl b _ _) :& r) =+  pure $ starNotesStkEl (VPair (a, b)) :& r+runInstrImpl _ (PAIRN nSing) stack = pure $ go nSing stack+  where+    go :: forall n inp. ConstraintPairN n inp => Sing n -> Rec StkEl inp -> Rec StkEl (PairN n inp)+    go (SS (SS SZ)) (StkEl a _ _ :& StkEl b _ _ :& r) =+      -- if n=2+      starNotesStkEl (VPair (a, b)) :& r+    go (SS n@(SS (SS _))) (StkEl a _ _ :& r@(_ :& _ :& _)) =+      -- if n>2+      case go n r of+        StkEl combed _ _ :& r' ->+            starNotesStkEl (VPair (a, combed)) :& r'+runInstrImpl _ (UNPAIRN nSing) (StkEl pair0 _ pairNotes0 :& r) = do+  pure $ go nSing pair0 pairNotes0 <+> r+  where+    go+      :: forall n pair. ConstraintUnpairN n pair+      => Sing n -> Value pair -> Notes pair+      -> Rec StkEl (UnpairN n pair)+    go n pair pairNotes =+      case (n, pair, pairNotes) of+        -- if n=2+        (SS (SS SZ), VPair (a, b), NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes) ->+          -- @UNPAIR n@ converts field annotations into var annotations.+          --+          -- > /* [ @pair pair (int %aa) (int %bb) (int %cc) (int %dd) ] */ ;+          -- > UNPAIR 3+          -- > /* [ @aa int : @bb int : pair (int %cc) (int %dd) ] */ ;+          --+          -- Nested var annotations will be discarded.+          --+          -- > /* [ pair (int @c) (int @a) (int @b) ] */ ;+          -- UNPAIR 3+          -- /* [ int : int : int ] */ ;+          StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes+            :& StkEl b (U.convAnn @U.FieldTag @U.VarTag bFieldAnn) bNotes+            :& RNil+        -- if n>2+        (SS n'@(SS (SS _)), VPair (a, b@(VPair _)), NTPair _ aFieldAnn _ _ _ aNotes bNotes) ->+          StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes+            :& go n' b bNotes runInstrImpl _ (AnnCAR _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r runInstrImpl _ (AnnCDR _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r runInstrImpl _ LEFT ((seValue -> a) :& r) =@@ -442,42 +497,56 @@ runInstrImpl _ RIGHT ((seValue -> b) :& r) =   withValueTypeSanity b $     pure $ starNotesStkEl (VOr $ Right b) :& r-runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) _ _ :& r) =-  runner bLeft (starNotesStkEl a :& r)-runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) _ _ :& r) =-  runner bRight (starNotesStkEl a :& r)--- More here+runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) =+  runner bLeft (StkEl a vn nl :& r)+runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) vn (NTOr _ _ _ _ nr) :& r) =+  runner bRight (StkEl a vn nr :& r) runInstrImpl _ NIL r = pure $ starNotesStkEl (VList []) :& r runInstrImpl _ CONS (a :& StkEl (VList l) _ _ :& r) = pure $ starNotesStkEl (VList (seValue a : l)) :& r runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) _ _ :& r) = runner bNil r-runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) _ _ :& r) =-  runner bCons (starNotesStkEl lh :& starNotesStkEl (VList lr) :& r)+runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) vn ntl@(NTList _ nhd) :& r) =+  runner bCons (StkEl lh vn nhd :& StkEl (VList lr) vn ntl :& r) runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ (fromInteger . toInteger) $ evalSize $ seValue a) :& r runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r runInstrImpl _ EMPTY_BIG_MAP r = pure $ starNotesStkEl (VBigMap Map.empty) :& r-runInstrImpl runner (MAP ops) ((seValue -> a) :& r) =-  case ops of-    (code :: Instr (MapOpInp c ': s) (b ': s)) -> do-      -- Evaluation must preserve all stack modifications that @MAP@'s does.-      (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do-        res <- runner code (val :& curStack)-        case res of-          ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))-        (r, []) (starNotesStkEl <$> mapOpToList @c a)-      pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack-runInstrImpl runner (ITER ops) (a :& r) =-  case ops of-    (code :: Instr (IterOpEl c ': s) s) ->-      case iterOpDetachOne @c (seValue a) of-        (Just x, xs) -> do-          res <- runner code (starNotesStkEl x :& r)-          runner (ITER code) (starNotesStkEl xs :& res)-        (Nothing, _) -> pure r+runInstrImpl runner (MAP (code :: Instr (MapOpInp c ': s) (b ': s))) (StkEl a vn n :& r) = do+  -- Evaluation must preserve all stack modifications that @MAP@'s does.+  (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do+    res <- runner code (val :& curStack)+    case res of+      ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))+    (r, []) ((\el -> StkEl el vn (mapOpNotes n)) <$> mapOpToList @c a)+  pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack+runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a vn n :& r) =+  case iterOpDetachOne @c a of+    (Just x, xs) -> do+      res <- runner code (StkEl x vn (iterOpNotes n) :& r)+      runner (ITER code) (StkEl xs vn n :& res)+    (Nothing, _) -> pure r runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r-runInstrImpl _ UPDATE (a :& b :& c :& r) =-    pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) (seValue c)) :& r+runInstrImpl _ (GETN index0) (StkEl pair _ _ :& r) = do+  pure $ starNotesStkEl (go index0 pair) :& r+  where+    go+      :: forall ix a. ConstraintGetN ix a+      => Sing ix -> Value a+      -> Value (GetN ix a)+    go SZ           a                  = a+    go (SS SZ)      (VPair (left, _))  = left+    go (SS (SS n')) (VPair (_, right)) = go n' right+runInstrImpl _ UPDATE (a :& b :& StkEl c _ _ :& r) =+    pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) c) :& r+runInstrImpl _ (UPDATEN index0) (StkEl (val :: Value val) _ _  :& StkEl pair _ _ :& r) = do+  pure $ starNotesStkEl (go index0 pair) :& r+  where+    go+      :: forall ix pair. ConstraintUpdateN ix pair+      => Sing ix -> Value pair -> Value (UpdateN ix val pair)+    go SZ           _                      = val+    go (SS SZ)      (VPair (_, right))     = VPair (val, right)+    go (SS (SS n')) (VPair (left, right))  = VPair (left, go n' right) runInstrImpl runner (IF bTrue _) (StkEl (VBool True) _ _ :& r) = runner bTrue r runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) _ _ :& r) = runner bFalse r runInstrImpl _ (LOOP _) (StkEl (VBool False) _ _ :& r) = pure $ r@@ -485,8 +554,8 @@   res <- runner ops r   runner (LOOP ops) res runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) _ _ :& r) = pure $ starNotesStkEl a :& r-runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) _ _ :& r) = do-  res <- runner ops (starNotesStkEl a :& r)+runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) vn (NTOr _ _ _ nl _) :& r) = do+  res <- runner ops (StkEl a vn nl :& r)   runner (LOOP_LEFT ops) res runInstrImpl _ (LAMBDA lam) r = pure $ starNotesStkEl lam :& r runInstrImpl runner EXEC (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) _ _ :& r) = do@@ -506,8 +575,8 @@     SS s' -> case stack of       (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith (seValue a)-runInstrImpl _ CAST (StkEl a vn _ :& r) = pure $ StkEl a vn starNotes :& r-runInstrImpl _ RENAME (StkEl a _ n :& r) = pure $ StkEl a U.noAnn n :& r+runInstrImpl _ CAST (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl _ RENAME (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r runInstrImpl _ PACK ((seValue -> a) :& r) = pure $ starNotesStkEl (VBytes $ packValue' a) :& r runInstrImpl _ UNPACK (StkEl (VBytes a) _ _ :& r) =   pure $ starNotesStkEl (VOption . rightToMaybe $ runUnpack a) :& r@@ -548,7 +617,8 @@   pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Le) a) :& rest runInstrImpl _ GE ((seValue -> a) :& rest) =   pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest-runInstrImpl _ INT (StkEl (VNat n) _ _ :& r) = pure $ starNotesStkEl (VInt $ toInteger n) :& r+runInstrImpl _ INT (StkEl a _ _ :& r) =+  pure $ starNotesStkEl (evalToIntOp a) :& r runInstrImpl _ (SELF sepc :: Instr inp out) r = do   ContractEnv{..} <- ask   case Proxy @out of@@ -628,6 +698,12 @@ runInstrImpl _ BALANCE r = do   ContractEnv{..} <- ask   pure $ starNotesStkEl (VMutez ceBalance) :& r+runInstrImpl _ VOTING_POWER (StkEl (VKeyHash k) _ _ :& r) = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VNat $ vpPick k ceVotingPowers) :& r+runInstrImpl _ TOTAL_VOTING_POWER r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VNat $ vpTotal ceVotingPowers) :& r runInstrImpl _ CHECK_SIGNATURE   (StkEl (VKey k) _ _ :& StkEl (VSignature v) _ _ :& StkEl (VBytes b) _ _ :& r) =   pure $ starNotesStkEl (VBool $ checkSignature k v b) :& r@@ -643,6 +719,9 @@   pure $ starNotesStkEl (VBytes $ keccak b) :& r runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) =   pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r+runInstrImpl _ PAIRING_CHECK (StkEl (VList pairs) _ _ :& r) = do+  let pairs' = [ (g1, g2) | VPair (VBls12381G1 g1, VBls12381G2 g2) <- pairs ]+  pure $ starNotesStkEl (VBool $ checkPairing pairs') :& r runInstrImpl _ SOURCE r = do   ContractEnv{..} <- ask   pure $ starNotesStkEl (VAddress $ EpAddress ceSource DefEpName) :& r@@ -657,11 +736,14 @@ runInstrImpl _ LEVEL r = do   ContractEnv{..} <- ask   pure $ starNotesStkEl (VNat ceLevel) :& r+runInstrImpl _ SELF_ADDRESS r = do+  ContractEnv{..} <- ask+  pure $ starNotesStkEl (VAddress $ EpAddress ceSelf DefEpName) :& r   -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp-  :: (ArithOp aop n m, Typeable n, Typeable m, EvalM monad)+  :: (ArithOp aop n m, EvalM monad)   => proxy aop   -> StkEl n   -> StkEl m

@@ -37,6 +37,7 @@ import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core (ChainId(..), Mutez(..), timestampToSeconds) import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), signatureToBytes)+import qualified Tezos.Crypto.BLS12381 as BLS import qualified Tezos.Crypto.Ed25519 as Ed25519 import qualified Tezos.Crypto.P256 as P256 import qualified Tezos.Crypto.Secp256k1 as Secp256k1@@ -73,15 +74,14 @@ -- byte representation. encodeValue :: forall t. (SingI t, HasNoOp t) => Value t -> LByteString encodeValue val = case (val, sing @t) of-  (VKey s, _) -> encodeBytes . LBS.fromStrict $ case s of+  (VKey s, _) -> encodeBytes' $ case s of     PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk     PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk     PublicKeyP256 pk -> "\x02" <> P256.publicKeyToBytes pk   (VUnit, _) -> "\x03\x0b"-  (VSignature x, _) -> encodeBytes . LBS.fromStrict $ signatureToBytes x+  (VSignature x, _) -> encodeBytes' $ signatureToBytes x   (VChainId x, _) ->-    encodeBytes . LBS.fromStrict $-      ByteArray.convert (unChainId x)+    encodeBytes' $ ByteArray.convert (unChainId x)   (VOption (Just x), STOption _) -> "\x05\x09" <> encodeValue x   (VOption Nothing, _) -> "\x03\x06"   (VList xs, STList _) -> encodeList encodeValue xs@@ -105,11 +105,14 @@   (VInt x, STInt) -> encodeNumeric x   (VNat x, STNat) -> encodeNumeric x   (VString text, STString) -> encodeString text-  (VBytes bytes, STBytes) -> encodeBytes (LBS.fromStrict bytes)+  (VBytes bytes, STBytes) -> encodeBytes' bytes   (VMutez x, STMutez) -> encodeNumeric (unMutez x)   (VBool True, STBool) -> "\x03\x0a"   (VBool False, STBool) -> "\x03\x03"   (VKeyHash kh, STKeyHash) -> encodeBytes $ encodeKeyHashRaw kh+  (VBls12381Fr v, STBls12381Fr) -> encodeBytes' $ BLS.toMichelsonBytes v+  (VBls12381G1 v, STBls12381G1) -> encodeBytes' $ BLS.toMichelsonBytes v+  (VBls12381G2 v, STBls12381G2) -> encodeBytes' $ BLS.toMichelsonBytes v   (VTimestamp x, STTimestamp) -> encodeNumeric (timestampToSeconds @Integer x)   (VAddress addr, STAddress) -> encodeEpAddress addr @@ -133,6 +136,10 @@ encodeBytes bs =   "\x0a" <> encodeAsList bs +-- | Version of 'encodeBytes' that accepts a strict bytestring.+encodeBytes' :: ByteString -> LByteString+encodeBytes' = encodeBytes . LBS.fromStrict+ encodeEpName :: EpName -> LByteString encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize   where@@ -184,6 +191,8 @@     encodeNotedInstr a n []   InstrWithVarNotes varNotes a ->     encodeVarNotedInstr a varNotes+  InstrWithVarAnns _ a ->+    encodeInstr a   FrameInstr _ i ->     encodeInstr i   Seq a b ->@@ -202,6 +211,8 @@     "\x05\x20" <> encodeNumeric (peanoValSing s)   DUP ->     "\x03\x21"+  DUPN s ->+    "\x05\x21" <> encodeNumeric (peanoValSing s)   SWAP ->     "\x03\x4c"   DIG s ->@@ -220,6 +231,10 @@     "\x07\x2f" <> encodeInstrs a <> encodeInstrs b   AnnPAIR tn fn1 fn2 ->     encodeWithAnns [tn] [fn1, fn2] [] "\x03\x42"+  PAIRN n ->+    "\x05\x42" <> encodeNumeric (peanoValSing n)+  UNPAIRN n ->+    "\x05\x7a" <> encodeNumeric (peanoValSing n)   (AnnCAR fn) ->     encodeWithAnns [] [fn] [] "\x03\x16"   (AnnCDR fn) ->@@ -252,8 +267,12 @@     "\x03\x39"   GET ->     "\x03\x29"+  GETN n ->+    "\x05\x29" <> encodeNumeric (peanoValSing n)   UPDATE ->     "\x03\x50"+  UPDATEN n ->+    "\x05\x50" <> encodeNumeric (peanoValSing n)   IF a b ->     "\x07\x2c" <> encodeInstrs a <> encodeInstrs b   LOOP a ->@@ -355,6 +374,10 @@    "\x03\x13"   BALANCE ->    "\x03\x15"+  VOTING_POWER ->+   "\x03\x7b"+  TOTAL_VOTING_POWER ->+   "\x03\x7c"   CHECK_SIGNATURE ->    "\x03\x18"   SHA256 ->@@ -369,6 +392,8 @@    "\x03\x7d"   HASH_KEY ->    "\x03\x2b"+  PAIRING_CHECK ->+   "\x03\x7f"   SOURCE ->    "\x03\x47"   SENDER ->@@ -379,6 +404,10 @@    "\x03\x75"   LEVEL ->    "\x03\x76"+  SELF_ADDRESS ->+   "\x03\x77"+  NEVER ->+   "\x03\x79"   -- | Iff there are non-empty annotations it increments the value's tag and@@ -395,8 +424,9 @@  -- | Encode an instruction with variable annotations encodeVarNotedInstr :: Instr inp out -> NonEmpty VarAnn -> LByteString-encodeVarNotedInstr i (toList -> vns) = case i of+encodeVarNotedInstr i vns'@(toList -> vns) = case i of   InstrWithNotes n a -> encodeNotedInstr a n vns+  InstrWithVarAnns _ a -> encodeInstr $ InstrWithVarNotes vns' a   -- AnnPAIR, AnnCAR and AnnCDR are checked here because their cases on   -- `encodeInstr` increment them to \x04 when they have a field annotation, but   -- they would also get increment due to variable annotations, resulting in an@@ -474,6 +504,12 @@     encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)   (STKeyHash, NTKeyHash tn) ->     encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STBls12381Fr, NTBls12381Fr tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STBls12381G1, NTBls12381G1 tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STBls12381G2, NTBls12381G2 tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)   (STTimestamp, NTTimestamp tn) ->     encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)   (STAddress, NTAddress tn) ->@@ -483,6 +519,8 @@     encodeWithAnns [tn] [fn] [] $ "\x03\x5c"   (STUnit, NTUnit tn) ->     encodeWithAnns [tn] [fn] [] $ "\x03\x6c"+  (STNever, NTNever tn) ->+    encodeWithAnns [tn] [fn] [] $ "\x03\x78"   (STSignature, NTSignature tn) ->     encodeWithAnns [tn] [fn] [] $ "\x03\x67"   (STChainId, NTChainId tn) ->@@ -497,7 +535,7 @@     encodeWithAnns [tn] [fn] [] $ "\x03\x6d"   (STContract a, NTContract tn ns) ->     encodeWithAnns [tn] [fn] [] $ "\x05\x5a" <> encodeNotedST a noAnn ns-  (STPair a b, NTPair tn fn1 fn2 ns1 ns2) ->+  (STPair a b, NTPair tn fn1 fn2 _vn1 _vn2 ns1 ns2) ->     encodeWithAnns [tn] [fn] [] $       "\x07\x65" <> encodeNotedST a fn1 ns1 <> encodeNotedST b fn2 ns2   (STOr a b, NTOr tn fn1 fn2 ns1 ns2) ->@@ -517,6 +555,7 @@ encodeT = \case   TKey  -> "\x03\x5c"   TUnit -> "\x03\x6c"+  TNever -> "\x03\x78"   TSignature -> "\x03\x67"   TChainId -> "\x03\x74"   TOption t -> "\x05\x63" <> encodeT t@@ -536,6 +575,9 @@   TMutez -> "\x03" <> "\x6a"   TBool -> "\x03" <> "\x59"   TKeyHash -> "\x03" <> "\x5d"+  TBls12381Fr -> "\x03" <> "\x82"+  TBls12381G1 -> "\x03" <> "\x80"+  TBls12381G2 -> "\x03" <> "\x81"   TTimestamp -> "\x03" <> "\x6b"   TAddress -> "\x03" <> "\x6e" 

@@ -41,7 +41,7 @@ import qualified Data.Set as Set import Data.Singletons (Sing, SingI(..)) import Data.Typeable ((:~:)(..))-import Fmt (Buildable, fmt, hexF, pretty, (+|), (|+))+import Fmt (Buildable, Builder, fmt, hexF, padLeftF, pretty, (+|), (|+))  import Michelson.Parser (Parser, ParserException(..), parseNoEnv) import qualified Michelson.Parser.Annotations as PA@@ -58,6 +58,7 @@ import Michelson.Untyped import Tezos.Core import Tezos.Crypto hiding (sign)+import qualified Tezos.Crypto.BLS12381 as BLS import Util.Binary import Util.Num @@ -70,14 +71,18 @@ (?) = flip Get.label infix 0 ? +-- | Displays bytes sequence.+bytesF :: [Word8] -> Builder+bytesF bs = "0x" <> foldMap (padLeftF 2 '0' . hexF) bs+ -- | Read a byte and match it against given value. expectTag :: String -> Word8 -> Get () expectTag desc t =   Get.label desc $ do     t' <- Get.getWord8     unless (t == t') $-      fail . fmt $ "Unexpected tag value (expected 0x" +| hexF t |+-                   ", but got 0x" +| hexF t' |+ ")"+      fail . fmt $ "Unexpected tag value (expected " +| bytesF [t] |++                   ", but got " +| bytesF [t'] |+ ")"   -- | Read a byte describing the primitive going further and match it against@@ -91,7 +96,7 @@   Get.label desc $ do     tag <- Get.getWord8     unless (tag == expected) $-      fail . fmt $ "Unexpected preliminary tag: 0x" <> hexF tag+      fail . fmt $ "Unexpected preliminary tag: " <> bytesF [tag]   where     expected = case argsNum of       0 -> 0x03@@ -134,7 +139,7 @@ we need to know currently expected type. The reference implementation does the same. -* It occured to be easier to decode to typed values and untyped instructions.+* It occurred to be easier to decode to typed values and untyped instructions. When decoding lambda, we type check given instruction, and when decoding @PUSH@ call we untype decoded value. One may say that this gives unreasonable performance overhead, but with the@@ -253,12 +258,8 @@       withUnpackedValueScope @st $         withComparable st $ T.VMap <$> decodeMap -    STInt -> do-      expectTag "Int" 0x00-      T.VInt <$> decodeInt-    STNat -> do-      expectTag "Nat" 0x00-      T.VNat <$> decodeInt+    STInt -> T.VInt <$> decodeTaggedInt "Int"+    STNat -> T.VNat <$> decodeTaggedInt "Nat"     STString -> do       expectTag "String" 0x01       T.VString <$> decodeString@@ -266,8 +267,7 @@       expectTag "Bytes" 0x0a       T.VBytes <$> decodeBytes     STMutez -> do-      expectTag "Mutez" 0x00-      mmutez <- mkMutez <$> decodeInt+      mmutez <- mkMutez <$> decodeTaggedInt "Mutez"       maybe (fail "Negative mutez") (pure . T.VMutez) mmutez     STBool -> do       expectDescTag "Bool" 0@@ -279,6 +279,17 @@       ( decodeWithTag "key_hash" keyHashDecoders       , parseKeyHash       )+    STBls12381Fr -> fmap T.VBls12381Fr $+      Get.label "bls12_381_fr" $ Get.getWord8 >>= \case+        0x0A -> decodeBls12Bytes+        0x00 -> fromInteger <$> decodeInt+        other -> unknownTag "bytes or int" other+    STBls12381G1 -> do+      expectTag "Bls12381G1 bytes" 0x0A+      T.VBls12381G1 <$> decodeBls12Bytes+    STBls12381G2 -> do+      expectTag "Bls12381G2 bytes" 0x0A+      T.VBls12381G2 <$> decodeBls12Bytes     STTimestamp -> Get.label "Timestamp" $ Get.getWord8 >>= \case       0x00 -> do         T.VTimestamp . timestampFromSeconds <$> decodeInt@@ -292,7 +303,9 @@       ( decodeBytesLike "EpAddress" parseEpAddressRaw       , parseEpAddress       )+    STNever -> fail $ "cannot decode to `never` type" + withUnpackedValueScope   :: forall a v m. (KnownT a, MonadFail m)   => (T.UnpackedValScope a => m v)@@ -375,6 +388,12 @@ decodeBytes =   decodeAsBytesRaw $ Get.label "Bytes payload" . getByteStringCopy +decodeBls12Bytes :: BLS.CurveObject a => Get a+decodeBls12Bytes = do+  bs <- decodeBytes+  BLS.fromMichelsonBytes bs+    & either (fail . pretty) pure+ decodeMap   :: forall k v.(UnpackedValScope k, UnpackedValScope v)   => Get $ Map (T.Value k) (T.Value v)@@ -387,6 +406,12 @@     either (fail . toString) pure $       Map.fromDistinctAscList <$> ensureDistinctAsc fst es +-- | An integral expression always appears tagged with 0x00.+-- This function reads the tag, discards it, and reads the int that follows it.+decodeTaggedInt :: (Integral i, Bits.Bits i) => String -> Get i+decodeTaggedInt label =+  expectTag label 0x00 *> decodeInt+ -- | Read a numeric value. decodeInt :: (Integral i, Bits.Bits i) => Get i decodeInt = (Bits.toIntegralSized @Integer <$> loop 0 0 ? "Number")@@ -408,7 +433,7 @@           let upayload = Bits.clearBit payload 6           (sign *) <$> addAndCont 6 upayload --- | Type check instruction occured from a lambda.+-- | Type check instruction occurred from a lambda. decodeTypeCheckLam   :: forall inp out m.      (T.WellTyped inp, T.WellTyped out, MonadFail m)@@ -449,11 +474,12 @@   tag <- Get.getWord8 ? "Instr tag"   case (pretag, tag) of     (0x03, 0x20) -> pure $ DROP-    (0x05, 0x20) -> DROPN <$> (expectTag "'DROP n' parameter" 0x00 *> decodeInt)+    (0x05, 0x20) -> DROPN <$> decodeTaggedInt "'DROP n' parameter"     (0x03, 0x21) -> DUP <$> decodeNoAnn+    (0x05, 0x21) -> DUPN <$> decodeNoAnn <*> (expectTag "'DUP n' parameter" 0x00 *> decodeInt)     (0x03, 0x4C) -> pure $ SWAP-    (0x05, 0x70) -> DIG <$> (expectTag "'DIG n' parameter" 0x00 *> decodeInt)-    (0x05, 0x71) -> DUG <$> (expectTag "'DUG n' parameter" 0x00 *> decodeInt)+    (0x05, 0x70) -> DIG <$> decodeTaggedInt "'DIG n' parameter"+    (0x05, 0x71) -> DUG <$> decodeTaggedInt "'DUG n' parameter"     (0x07, 0x43) -> do       (typ, val) <- decodePushVal       an <- decodeNoAnn@@ -463,6 +489,11 @@     (0x03, 0x4F) -> UNIT <$> decodeNoAnn <*> decodeNoAnn     (0x07, 0x2F) -> IF_NONE <$> decodeOps <*> decodeOps     (0x03, 0x42) -> PAIR <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn+    (0x05, 0x42) -> do+      n <- decodeTaggedInt "'PAIR n' parameter"+      varAnn <- decodeNoAnn+      pure $ PAIRN varAnn n+    (0x05, 0x7a) -> UNPAIRN <$> decodeTaggedInt "'UNPAIR n' parameter"     (0x03, 0x16) -> CAR <$> decodeNoAnn <*> decodeNoAnn     (0x03, 0x17) -> CDR <$> decodeNoAnn <*> decodeNoAnn     (0x05, 0x33) -> LEFT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn@@ -483,7 +514,9 @@     (0x05, 0x52) -> ITER <$> decodeOps     (0x03, 0x39) -> MEM <$> decodeNoAnn     (0x03, 0x29) -> GET <$> decodeNoAnn+    (0x05, 0x29) -> GETN <$> decodeNoAnn <*> decodeTaggedInt "'GET n' parameter"     (0x03, 0x50) -> UPDATE <$> decodeNoAnn+    (0x05, 0x50) -> UPDATEN <$> decodeNoAnn <*> decodeTaggedInt "'UPDATE n' parameter"     (0x07, 0x2C) -> IF <$> decodeOps  <*> decodeOps     (0x05, 0x34) -> LOOP <$> decodeOps     (0x05, 0x53) -> LOOP_LEFT <$> decodeOps@@ -495,8 +528,7 @@     (0x03, 0x26) -> EXEC <$> decodeNoAnn     (0x03, 0x73) -> APPLY <$> decodeNoAnn     (0x05, 0x1F) -> DIP <$> decodeOps-    (0x07, 0x1F) ->-      DIPN <$> (expectTag "'DIP n' parameter" 0x00 *> decodeInt) <*> decodeOps+    (0x07, 0x1F) -> DIPN <$> decodeTaggedInt "'DIP n' parameter" <*> decodeOps     (0x03, 0x27) -> pure FAILWITH     (0x05, 0x57) -> CAST <$> decodeNoAnn <*> decodeType     (0x03, 0x58) -> RENAME <$> decodeNoAnn@@ -535,6 +567,8 @@     (0x03, 0x40) -> NOW <$> decodeNoAnn     (0x03, 0x13) -> AMOUNT <$> decodeNoAnn     (0x03, 0x15) -> BALANCE <$> decodeNoAnn+    (0x03, 0x7b) -> VOTING_POWER <$> decodeNoAnn+    (0x03, 0x7c) -> TOTAL_VOTING_POWER <$> decodeNoAnn     (0x03, 0x18) -> CHECK_SIGNATURE <$> decodeNoAnn     (0x03, 0x0F) -> SHA256 <$> decodeNoAnn     (0x03, 0x10) -> SHA512 <$> decodeNoAnn@@ -542,14 +576,18 @@     (0x03, 0x7E) -> SHA3 <$> decodeNoAnn     (0x03, 0x7D) -> KECCAK <$> decodeNoAnn     (0x03, 0x2B) -> HASH_KEY <$> decodeNoAnn+    (0x03, 0x7F) -> PAIRING_CHECK <$> decodeNoAnn     (0x03, 0x47) -> SOURCE <$> decodeNoAnn     (0x03, 0x48) -> SENDER <$> decodeNoAnn     (0x03, 0x49) -> SELF <$> decodeNoAnn <*> decodeNoAnn     (0x03, 0x54) -> ADDRESS <$> decodeNoAnn     (0x03, 0x75) -> CHAIN_ID <$> decodeNoAnn     (0x03, 0x76) -> LEVEL <$> decodeNoAnn+    (0x03, 0x77) -> SELF_ADDRESS <$> decodeNoAnn+    (0x03, 0x79) -> pure $ NEVER     -- Instructions with annotations from here on     (0x04, 0x21) -> DUP <$> decodeVAnn+    (0x06, 0x21) -> flip DUPN <$> (expectTag "'DUP n' parameter" 0x00 *> decodeInt) <*> decodeVAnn     (0x08, 0x43) -> do       (typ, val) <- decodePushVal       an <- decodeVAnn@@ -560,6 +598,10 @@       decodeWithTVAnns NONE <*> pure t     (0x04, 0x4F) -> decodeWithTVAnns UNIT     (0x04, 0x42) -> decodeWithTVF2Anns PAIR+    (0x06, 0x42) -> do+      n <- decodeTaggedInt "'PAIR n' parameter"+      varAnn <- decodeVAnn+      pure $ PAIRN varAnn n     (0x04, 0x16) -> decodeWithVFAnns CAR     (0x04, 0x17) -> decodeWithVFAnns CDR     (0x06, 0x33) -> do@@ -589,7 +631,15 @@       MAP <$> decodeVAnn <*> pure o     (0x04, 0x39) -> MEM <$> decodeVAnn     (0x04, 0x29) -> GET <$> decodeVAnn+    (0x06, 0x29) -> do+      n <- decodeTaggedInt "'GET n' parameter"+      varAnn <- decodeVAnn+      pure $ GETN varAnn n     (0x04, 0x50) -> UPDATE <$> decodeVAnn+    (0x06, 0x50) -> do+      n <- decodeTaggedInt "'UPDATE n' parameter"+      varAnn <- decodeVAnn+      pure $ UPDATEN varAnn n     (0x04, 0x26) -> EXEC <$> decodeVAnn     (0x04, 0x73) -> APPLY <$> decodeVAnn     (0x06, 0x57) -> do@@ -635,6 +685,8 @@     (0x04, 0x40) -> NOW <$> decodeVAnn     (0x04, 0x13) -> AMOUNT <$> decodeVAnn     (0x04, 0x15) -> BALANCE <$> decodeVAnn+    (0x04, 0x7b) -> VOTING_POWER <$> decodeVAnn+    (0x04, 0x7c) -> TOTAL_VOTING_POWER <$> decodeVAnn     (0x04, 0x18) -> CHECK_SIGNATURE <$> decodeVAnn     (0x04, 0x0F) -> SHA256 <$> decodeVAnn     (0x04, 0x10) -> SHA512 <$> decodeVAnn@@ -642,14 +694,16 @@     (0x04, 0x7E) -> SHA3 <$> decodeVAnn     (0x04, 0x7D) -> KECCAK <$> decodeVAnn     (0x04, 0x2B) -> HASH_KEY <$> decodeVAnn+    (0x04, 0x7F) -> PAIRING_CHECK <$> decodeVAnn     (0x04, 0x47) -> SOURCE <$> decodeVAnn     (0x04, 0x48) -> SENDER <$> decodeVAnn     (0x04, 0x49) -> decodeWithVFAnns SELF     (0x04, 0x54) -> ADDRESS <$> decodeVAnn     (0x04, 0x75) -> CHAIN_ID <$> decodeVAnn     (0x04, 0x76) -> LEVEL <$> decodeVAnn-    (other1, other2) -> fail $ "Unknown instruction tag: 0x" +|-                        hexF other1 |+ hexF other2 |+ ""+    (0x04, 0x77) -> SELF_ADDRESS <$> decodeVAnn+    (other1, other2) -> fail $ "Unknown instruction tag: " +|+                        bytesF [other1, other2]  decodePushVal :: Get (Type, Value) decodePushVal = do@@ -721,28 +775,38 @@ decodeComparableTWithAnns = Get.label "Comparable primitive type" $ do   pretag <- Get.getWord8 ? "Pre simple comparable type tag"   tag <- Get.getWord8 ? "Simple comparable type tag"-  let failMessage = "Unknown primitive tag: 0x" +| hexF pretag |+ hexF tag |+ ""+  let failMessage = "Unknown primitive tag: " +| bytesF [pretag, tag]   ct <- case tag of+    0x6C -> pure TUnit     0x5B -> pure TInt     0x62 -> pure TNat     0x68 -> pure TString     0x69 -> pure TBytes     0x6A -> pure TMutez     0x59 -> pure TBool+    0x5C -> pure TKey     0x5D -> pure TKeyHash+    0x67 -> pure TSignature     0x6B -> pure TTimestamp     0x6E -> pure TAddress+    0x74 -> pure TChainId+    0x63 -> TOption <$> decodeType     0x65 ->       case pretag of         0x07 -> decodeTPair         0x08 -> decodeTPair         0x09 -> decodeTPairN         _ -> fail failMessage+    0x64 -> decodeTOr     _ -> fail failMessage   case pretag of     0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn     0x04 -> decodeWithTFAnns (ct,,)-    0x05 -> decodeWithTFAnns (ct,,)+    0x05 ->+      case tag of+        0x63 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn+        _    -> decodeWithTFAnns (ct,,)+    0x06 -> decodeWithTFAnns (ct,,)     0x07 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn     0x08 -> decodeWithTFAnns (ct,,)     0x09 -> decodeWithTFAnns (ct,,)@@ -760,10 +824,18 @@           (,,) <$> pure TKey <*> decodeNoAnn <*> decodeNoAnn         (0x03, 0x6C) ->           (,,) <$> pure TUnit <*> decodeNoAnn <*> decodeNoAnn+        (0x03, 0x78) ->+          (,,) <$> pure TNever <*> decodeNoAnn <*> decodeNoAnn         (0x03, 0x67) ->           (,,) <$> pure TSignature <*> decodeNoAnn <*> decodeNoAnn         (0x03, 0x74) ->           (,,) <$> pure TChainId <*> decodeNoAnn <*> decodeNoAnn+        (0x03, 0x82) ->+          (,,) <$> pure TBls12381Fr <*> decodeNoAnn <*> decodeNoAnn+        (0x03, 0x80) ->+          (,,) <$> pure TBls12381G1 <*> decodeNoAnn <*> decodeNoAnn+        (0x03, 0x81) ->+          (,,) <$> pure TBls12381G2 <*> decodeNoAnn <*> decodeNoAnn         (0x05, 0x63) ->           (,,) <$> (TOption <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn         (0x05, 0x5F) ->@@ -774,9 +846,6 @@           (,,) <$> pure TOperation <*> decodeNoAnn <*> decodeNoAnn         (0x05, 0x5A) ->           (,,) <$> (TContract <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn-        (0x07, 0x64) -> do-          t <- decodeTOr-          (,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn         (0x07, 0x5E) ->           (,,) <$> (TLambda <$> decodeType <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn         (0x07, 0x60) ->@@ -786,6 +855,7 @@         -- T with annotations from here on         (0x04, 0x5C) -> decodeWithTFAnns (TKey,,)         (0x04, 0x6C) -> decodeWithTFAnns (TUnit,,)+        (0x04, 0x78) -> decodeWithTFAnns (TNever,,)         (0x04, 0x67) -> decodeWithTFAnns (TSignature,,)         (0x04, 0x74) -> decodeWithTFAnns (TChainId,,)         (0x06, 0x63) -> do@@ -801,9 +871,6 @@         (0x06, 0x5A) -> do           t <- TContract <$> decodeType           decodeWithTFAnns (t,,)-        (0x08, 0x64) -> do-          t <- decodeTOr-          decodeWithTFAnns (t,,)         (0x08, 0x5E) -> do           t <- TLambda <$> decodeType <*> decodeType           decodeWithTFAnns (t,,)@@ -813,17 +880,24 @@         (0x08, 0x61) -> do           t <- TBigMap <$> decodeComparable <*> decodeType           decodeWithTFAnns (t,,)-        (other1, other2) -> fail $ "Unknown primitive tag: 0x" +|-                            hexF other1 |+ hexF other2 |+ ""+        (other1, other2) -> fail $ "Unknown primitive tag: " +|+                            bytesF [other1, other2]  -- | "Normal" pair notation, e.g. `pair int int` or `pair int (pair int int)`+--+-- The pair type doesn't really carry its nested variable annotations, except+-- during execution. For this reason, they don't get decoded here and these+-- variable annotations fields will be empty. See !763 for more context. decodeTPair :: Get T decodeTPair = do   (t1, tAnn1, fAnn1) <- decodeTWithAnns   (t2, tAnn2, fAnn2) <- decodeTWithAnns-  pure $ TPair fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2)+  pure $ TPair fAnn1 fAnn2 noAnn noAnn (Type t1 tAnn1) (Type t2 tAnn2)  -- | Right-combed notation, e.g. `pair int int int`+--+-- Just like 'decodeTPair', nested variable annotations are not decoded, as they+-- exist only during execution. See !763 for more context. decodeTPairN :: Get T decodeTPairN = do   -- Find out how many bytes it took to encode the pair's fields, and decode them.@@ -836,10 +910,10 @@       [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."       [(t, _, _)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."       [(t1, tAnn1, fAnn1), (t2, tAnn2, fAnn2)] ->-        pure $ TPair fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2)+        pure $ TPair fAnn1 fAnn2 noAnn noAnn (Type t1 tAnn1) (Type t2 tAnn2)       (t1, t1Ann1, fAnn1) : fields -> do         rightCombedT <- go fields-        pure $ TPair fAnn1 noAnn (Type t1 t1Ann1) (Type rightCombedT noAnn)+        pure $ TPair fAnn1 noAnn noAnn noAnn (Type t1 t1Ann1) (Type rightCombedT noAnn)  decodeTOr :: Get T decodeTOr = do

@@ -228,6 +228,9 @@   -- (e. g. to avoid `error` usage inside `expandMacro`).   (Mac (DIIP n ops) pos) ->     WithSrcEx (ics pos) $ PrimEx (DIPN n (expand cs <$> ops))+  -- Similarly to above, DUUP is now always represented as a single instruction.+  (Mac (DUUP n v) pos) ->+    WithSrcEx (ics pos) $ PrimEx $ DUPN v n   (Mac m pos) -> WithSrcEx (ics pos) $ SeqEx $ expandMacro (ics pos) m   (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand cs <$> i   (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand cs <$> s@@ -242,7 +245,7 @@ expandMacro :: InstrCallStack -> Macro -> [ExpandedOp] expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case   VIEW a             -> expandMacro p (UNPAIR $ UP (UF (noAnn, noAnn)) (UF (noAnn, noAnn))) ++-                        [ PrimEx (DIP $ expandMacro p $ DUUP 2 noAnn) ] +++                        [ PrimEx (DIP $ oprimEx $ DUPN noAnn 2) ] ++                         [ PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++                         (expand cs <$> a) ++                         [ PrimEx (DIP [PrimEx $ AMOUNT noAnn])@@ -282,11 +285,10 @@   CADR c v f         -> expandCadr p c v f   SET_CADR c v f     -> expandSetCadr p c v f   MAP_CADR c v f ops -> expandMapCadr p c v f ops-  -- We handle DIIP outside.-  DIIP {}             -> error "expandMacro DIIP is unreachable"-  DUUP 1 v           -> oprimEx $ DUP v -- this case should be impossible in practice-  DUUP 2 v           -> PrimEx <$> [DIP [PrimEx $ DUP v], SWAP]-  DUUP n v           -> PrimEx <$> [DIPN (n - 1) [PrimEx $ DUP v], DIG n]+  -- We handle DIIP and DUUP outside.+  DIIP {}            -> error "expandMacro DIIP is unreachable"+  DUUP {}            -> error "expandMacro DUUP is unreachable"+   where     mac = flip Mac macroPos     oprimEx = one . PrimEx@@ -347,31 +349,31 @@   D:css -> PrimEx (CDR noAnn noAnn) : expandMacro ics (CADR css v f)  carNoAnn :: InstrAbstract op-carNoAnn = CAR noAnn noAnn+carNoAnn = CAR "%%" noAnn  cdrNoAnn :: InstrAbstract op-cdrNoAnn = CDR noAnn noAnn+cdrNoAnn = CDR "%%" noAnn  pairNoAnn :: VarAnn -> InstrAbstract op-pairNoAnn v = PAIR noAnn v noAnn noAnn+pairNoAnn v = PAIR noAnn v "@" "@"  expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp] expandSetCadr ics cs v f = PrimEx <$> case cs of   []    -> []   [A]   -> [DUP noAnn, CAR noAnn f, DROP,            -- ↑ These operations just check that the left element of pair has %f-           CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]+           cdrNoAnn, SWAP, PAIR noAnn v f "@"]   [D]   -> [DUP noAnn, CDR noAnn f, DROP,            -- ↑ These operations just check that the right element of pair has %f-           CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f]+           carNoAnn, PAIR noAnn v "@" f]   A:css -> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (SET_CADR css noAnn f)), cdrNoAnn, SWAP, pairNoAnn v]   D:css -> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (SET_CADR css noAnn f)), carNoAnn, pairNoAnn v]  expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp] expandMapCadr ics@InstrCallStack{icsCallStack=cls} cs v f ops = case cs of   []    -> []-  [A]   -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, pairNoAnn v]-  [D]   -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, pairNoAnn v]]+  [A]   -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, PAIR noAnn v f "@"]+  [D]   -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, PAIR noAnn v "@" f]]   A:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), cdrNoAnn, SWAP, pairNoAnn v]   D:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), carNoAnn, pairNoAnn v] 

@@ -111,6 +111,7 @@     `orSimpleRule` simpleDips     `orSimpleRule` adjacentDips     `orSimpleRule` adjacentDrops+    `orSimpleRule` isSomeOnIf     `orSimpleRule` specificPush     `orSimpleRule` pairUnpair     `orSimpleRule` unpairMisc@@ -318,6 +319,15 @@         _ -> Nothing        _ -> Nothing+++isSomeOnIf :: Rule+isSomeOnIf = \case+  Seq (IF (PUSH (VOption Just{})) (PUSH (VOption Nothing))) c -> case c of+    Seq (IF_NONE (PUSH (VBool False)) (Seq DROP (PUSH (VBool True)))) s -> Just s+    IF_NONE (PUSH (VBool False)) (Seq DROP (PUSH (VBool True))) -> Just Nop+    _ -> Nothing+  _ -> Nothing  -- UNPAIR with continuation pattern UNPAIR_c

@@ -258,8 +258,8 @@ primOrMac :: Parser ParsedOp primOrMac = (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)   <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))-  <|> (try (primWithPos pairOp) <|> macWithPos pairMac)-  <|> (try (macWithPos duupMac) <|> try (macWithPos dupNMac) <|> primWithPos dupOp)+  <|> (try (primWithPos pairOp) <|> try (primWithPos pairNOp) <|> macWithPos pairMac)+  <|> (try (macWithPos duupMac) <|> primWithPos dupOp)  ------------------------------------------------------------------------------- -- Safe construction of Haskell values@@ -280,7 +280,7 @@ -- | Creates 'U.Type' by its Morley representation. -- -- >>> [utypeQ| (int :a | nat :b) |]--- Type (TOr % % (Type (Tc CInt) :a) (Type (Tc CNat) :b)) :+-- Type (TOr % % (Type TInt :a) (Type TNat :b)) : utypeQ :: TH.QuasiQuoter utypeQ = parserToQuasiQuoter type_ 

@@ -10,6 +10,7 @@   -- * These are handled separately to have better error messages   , mapOp   , pairOp+  , pairNOp   , cmpOp   , dupOp   ) where@@ -36,13 +37,14 @@   , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser   , memOp, getOp, updateOp, loopLOp opParser, loopOp opParser   , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp-  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, addOp, subOp+  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, selfAddressOp, addOp, subOp   , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp   , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp   , transferTokensOp, setDelegateOp   , createContractOp contractParser, implicitAccountOp, nowOp, amountOp-  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp-  , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp+  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp, pairingCheckOp+  , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp, neverOp+  , votingPowerOp, totalVotingPowerOp, try unpairNOp   ]  -- | Parse a sequence of instructions.@@ -83,10 +85,13 @@ dropOp = parseWithOptionalParameter "DROP" DROPN DROP  dupOp :: Parser ParsedInstr-dupOp = word' "DUP" DUP <*> noteDef+dupOp = do+  symbol' "DUP"+  varAnn <- noteDef+  optional (lexeme L.decimal) <&> maybe (DUP varAnn) (DUPN varAnn)  swapOp :: Parser ParsedInstr-swapOp = word' "SWAP" SWAP;+swapOp = word' "SWAP" SWAP  digOp :: Parser ParsedInstr digOp = word' "DIG" DIG <*> lexeme L.decimal@@ -113,6 +118,8 @@ lambdaOp opParser =   word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser +neverOp :: Parser ParsedInstr+neverOp = word' "NEVER" NEVER -- Generic comparison  cmpOp :: Parser ParsedInstr@@ -193,8 +200,23 @@  -- Operations on pairs pairOp :: Parser ParsedInstr-pairOp = do symbol' "PAIR"; (t, v, (p, q)) <- notesTVF2; return $ PAIR t v p q+pairOp = do+  symbol' "PAIR";+  (t, v, (p, q)) <- notesTVF2;+  notFollowedBy (lexeme L.decimal :: Parser Word)+  return $ PAIR t v p q +pairNOp :: Parser ParsedInstr+pairNOp = do+  symbol' "PAIR"+  PAIRN+    <$> noteDef+    <*> lexeme L.decimal++unpairNOp :: Parser ParsedInstr+unpairNOp =+  word' "UNPAIR" UNPAIRN <*> lexeme L.decimal+ carOp :: Parser ParsedInstr carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ CAR v f @@ -219,7 +241,11 @@ memOp = word' "MEM" MEM <*> noteDef  updateOp :: Parser ParsedInstr-updateOp = word' "UPDATE" UPDATE <*> noteDef+updateOp = do+  symbol' "UPDATE"+  varAnn <- noteDef+  ix <- optional (lexeme L.decimal)+  pure $ maybe (UPDATE varAnn) (UPDATEN varAnn) ix  iterOp :: Parser ParsedOp -> Parser ParsedInstr iterOp opParser = word' "ITER" ITER <*> ops' opParser@@ -231,7 +257,11 @@ mapOp opParser = word' "MAP" MAP <*>  noteDef <*> ops' opParser  getOp :: Parser ParsedInstr-getOp = word' "GET" GET <*> noteDef+getOp = do+  symbol' "GET"+  varAnn <- noteDef+  ix <- optional (lexeme L.decimal)+  pure $ maybe (GET varAnn) (GETN varAnn) ix  nilOp :: Parser ParsedInstr nilOp = do symbol' "NIL"; (t, v) <- notesTV; NIL t v <$> type_@@ -300,6 +330,12 @@ amountOp :: Parser ParsedInstr amountOp = word' "AMOUNT" AMOUNT <*> noteDef +votingPowerOp :: Parser ParsedInstr+votingPowerOp = word' "VOTING_POWER" VOTING_POWER <*> noteDef++totalVotingPowerOp :: Parser ParsedInstr+totalVotingPowerOp = word' "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef+ implicitAccountOp :: Parser ParsedInstr implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef @@ -309,6 +345,9 @@ addressOp :: Parser ParsedInstr addressOp = word' "ADDRESS" ADDRESS <*> noteDef +selfAddressOp :: Parser ParsedInstr+selfAddressOp = word' "SELF_ADDRESS" SELF_ADDRESS <*> noteDef+ -- Special Operations  nowOp :: Parser ParsedInstr@@ -350,6 +389,9 @@  hashKeyOp :: Parser ParsedInstr hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef++pairingCheckOp :: Parser ParsedInstr+pairingCheckOp = word' "PAIRING_CHECK" PAIRING_CHECK <*> noteDef  -- Type operations 

@@ -7,7 +7,6 @@ module Michelson.Parser.Macro   ( macro   -- * These are handled separately to have better error messages-  , dupNMac   , duupMac   , pairMac   , ifCmpMac@@ -59,9 +58,6 @@   where    ops = ops' opParser    num str = fromIntegral . length <$> some (string' str)--dupNMac :: Parser Macro-dupNMac = do symbol' "DUP"; DUUP <$> lexeme decimal <*> noteDef  duupMac :: Parser Macro duupMac = do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef

@@ -56,7 +56,7 @@       return (f, Type TUnit t)   where     mergeTwo isOr _ (l, a) (r, b) =-      (noAnn, Type ((if isOr then TOr else TPair) l r a b) noAnn)+      (noAnn, Type ((if isOr then TOr l r else TPair l r noAnn noAnn) a b) noAnn)      mergeAnnots l r       | l == def  = return r@@ -68,7 +68,8 @@ typeInner fp = lexeme $ choice $ (\x -> x fp) <$>   [ t_int, t_nat, t_string, t_bytes, t_mutez, t_bool   , t_keyhash, t_timestamp, t_address-  , t_key, t_unit, t_signature, t_chain_id+  , t_key, t_unit, t_never, t_signature, t_chain_id+  , t_bls12381fr, t_bls12381g1, t_bls12381g2   , t_option, t_list, t_set   , t_operation, t_contract, t_pair, t_or   , t_lambda, t_map, t_big_map, t_view@@ -125,6 +126,21 @@ t_signature :: (Default a) => Parser a -> Parser (a, Type) t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp +t_bls12381fr :: (Default a) => Parser a -> Parser (a, Type)+t_bls12381fr fp = do+  symbol' "bls12_381_fr" <|> symbol' "Bls12381Fr"+  mkType TBls12381Fr <$> fieldType fp++t_bls12381g1 :: (Default a) => Parser a -> Parser (a, Type)+t_bls12381g1 fp = do+  symbol' "bls12_381_g1" <|> symbol' "Bls12381G1"+  mkType TBls12381G1 <$> fieldType fp++t_bls12381g2 :: (Default a) => Parser a -> Parser (a, Type)+t_bls12381g2 fp = do+  symbol' "bls12_381_g2" <|> symbol' "Bls12381G2"+  mkType TBls12381G2 <$> fieldType fp+ t_chain_id :: (Default a) => Parser a -> Parser (a, Type) t_chain_id fp = do   symbol' "ChainId" <|> symbol' "chain_id"@@ -146,6 +162,12 @@   (f,t) <- fieldType fp   return (f, Type TUnit t) +t_never :: (Default a) => Parser a -> Parser (a, Type)+t_never fp = do+  symbol' "Never" <|> symbol' "⊥"+  (f,t) <- fieldType fp+  return (f, Type TNever t)+ t_pair :: (Default a) => Parser a -> Parser (a, Type) t_pair fp = do   symbol' "Pair"@@ -159,10 +181,10 @@       [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."       [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."       [(fieldAnnL, typeL), (fieldAnnR, typeR)] ->-        pure $ TPair fieldAnnL fieldAnnR typeL typeR+        pure $ TPair fieldAnnL fieldAnnR noAnn noAnn typeL typeR       (fieldAnnL, typeL) : fields -> do         rightCombedT <- go fields-        pure $ TPair fieldAnnL noAnn typeL (Type rightCombedT noAnn)+        pure $ TPair fieldAnnL noAnn noAnn noAnn typeL (Type rightCombedT noAnn)  t_or :: (Default a) => Parser a -> Parser (a, Type) t_or fp = do@@ -255,7 +277,7 @@   r <- type_   (f, t) <- fieldType fp   let c' = Type (TContract r) noAnn-  return (f, Type (TPair noAnn noAnn a c') t)+  return (f, Type (TPair noAnn noAnn noAnn noAnn a c') t)  t_void :: Default a => Parser a -> Parser (a, Type) t_void fp = do@@ -264,7 +286,7 @@   b <- type_   (f, t) <- fieldType fp   let c = Type (TLambda b b) noAnn-  return (f, Type (TPair noAnn noAnn a c) t)+  return (f, Type (TPair noAnn noAnn noAnn noAnn a c) t)  t_letType :: Default fp => Parser fp -> Parser (fp, Type) t_letType fp = do

@@ -20,6 +20,9 @@   -- * Re-exports   , ContractState (..)   , AddressState (..)+  , VotingPowers+  , mkVotingPowers+  , mkVotingPowersFromMap   , TxData (..)   , TxParam (..) @@ -511,8 +514,8 @@     mSourceAddr <- use esSourceAddress      let addresses = gsAddresses gs-    let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr     let senderAddr = tdSenderAddress txData+    let sourceAddr = fromMaybe senderAddr mSourceAddr     let isKeyAddress (KeyAddress _) = True         isKeyAddress _ = False     let isZeroTransfer = tdAmount txData == toMutez 0@@ -530,7 +533,7 @@           -- Subtraction is safe because we have checked its           -- precondition in guard.           return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)-    when (not (isKeyAddress senderAddr) && isGlobalOp) $+    when (not (isKeyAddress senderAddr) && isGlobalOp && not isZeroTransfer) $       throwError $ EETransactionFromContract senderAddr $ tdAmount txData     let onlyUpdates updates = return (updates, [], Nothing, remainingSteps)     (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps)@@ -600,6 +603,7 @@             , ceSource = sourceAddr             , ceSender = senderAddr             , ceAmount = tdAmount txData+            , ceVotingPowers = gsVotingPowers gs             , ceChainId = gsChainId gs             , ceOperationHash = Just opHash             , ceGlobalCounter = gsCounter gs

@@ -8,12 +8,13 @@   ( dummyNow   , dummyLevel   , dummyMaxSteps+  , dummyVotingPowers   , dummyContractEnv   , dummyOrigination   ) where  import Michelson.Interpret (ContractEnv(..), RemainingSteps)-import Michelson.Runtime.GState (genesisAddress)+import Michelson.Runtime.GState (dummyVotingPowers, genesisAddress) import Michelson.Typed (ParameterScope, StorageScope) import qualified Michelson.Typed as T import Michelson.Typed.Origination (OriginationOperation(..))@@ -48,6 +49,7 @@   , ceSource = genesisAddress   , ceSender = genesisAddress   , ceAmount = unsafeMkMutez 100+  , ceVotingPowers = dummyVotingPowers   , ceChainId = dummyChainId   , ceOperationHash = Nothing   , ceGlobalCounter = 0

@@ -10,11 +10,18 @@     ContractState (..)   , AddressState (..)   , asBalance+  , VotingPowers (..)+  , vpPick+  , vpTotal+  , mkVotingPowers+  , mkVotingPowersFromMap+  , dummyVotingPowers    -- * GState   , GState (..)   , gsChainIdL   , gsAddressesL+  , gsVotingPowersL   , gsCounterL   , genesisAddresses   , genesisKeyHashes@@ -132,6 +139,37 @@     ASSimple b -> b     ASContract cs -> csBalance cs +-- | Distribution of voting power among the contracts.+--+-- Voting power reflects the ability of bakers to accept, deny or pass new+-- proposals for protocol updates. I.e. each baker has its vote weight.+--+-- This datatype definition may change in future, so its internals are not+-- exported.+newtype VotingPowers+  = VotingPowers (Map KeyHash Natural)+  deriving stock (Show)++deriveJSON morleyAesonOptions ''VotingPowers++-- | Get voting power of the given address.+vpPick :: KeyHash -> VotingPowers -> Natural+vpPick key (VotingPowers distr) = Map.lookup key distr ?: 0++-- | Get total voting power.+vpTotal :: VotingPowers -> Natural+vpTotal (VotingPowers distr) = sum distr++-- | Create voting power distribution from map.+mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers+mkVotingPowersFromMap = VotingPowers++-- | Create voting power distribution.+--+-- If some key is encountered multiple times, voting power will be summed up.+mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers+mkVotingPowers = mkVotingPowersFromMap . Map.fromListWith (+)+ -- | Persistent data passed to Morley contracts which can be updated -- as result of contract execution. data GState = GState@@ -139,6 +177,8 @@   -- ^ Identifier of chain.   , gsAddresses :: Map Address AddressState   -- ^ All known addresses and their state.+  , gsVotingPowers :: VotingPowers+  -- ^ Voting power distribution.   , gsCounter :: GlobalCounter   -- ^ Ever increasing operation counter.   } deriving stock (Show)@@ -190,6 +230,14 @@ genesisAddress5 = genesisAddresses !! 5 genesisAddress6 = genesisAddresses !! 6 +-- | Dummy 'VotingPowers'. We give all the voting power to two genesis addreses+-- as the addresses holding lot of money. Only two addresses are involved for+-- simplicity.+dummyVotingPowers :: VotingPowers+dummyVotingPowers = case genesisKeyHashes of+  k1 :| k2 : _ -> mkVotingPowers [(k1, 50), (k2, 50)]+  _ -> error "Insufficient number of genesis addresses"+ -- | Initial 'GState'. It's supposed to be used if no 'GState' is -- provided. It puts plenty of money on each genesis address. initGState :: GState@@ -202,6 +250,7 @@                     ?: error "Number of genesis addresses is 0"     , genesis <- toList genesisAddresses     ]+  , gsVotingPowers = dummyVotingPowers   , gsCounter = GlobalCounter 0   } 

@@ -61,7 +61,7 @@ -- * With QuasyQuotes when need to create a string literal. -- -- >>> [mt|Some text|]--- MTextUnsafe { unMText = "Some text" }+-- MTextUnsafe {unMText = "Some text"} -- -- * With 'mkMText' when constructing from a runtime text value. --

@@ -5,15 +5,16 @@ -- | Errors that can occur when some code is being typechecked.  module Michelson.TypeCheck.Error-  ( ExpectType (..)-  , TypeContext (..)+  ( TypeContext (..)   , TCTypeError (..)   , TCError (..)   , ExtError (..)   , StackSize (..)+  , pairWithNodeIndex+  , pairWithElems   ) where -import Fmt (Buildable(..), listF, pretty, (+|), (+||), (|+), (||+))+import Fmt (Buildable(..), listF, pretty, unlinesF, (+|), (+||), (|+), (||+)) import qualified Text.Show (show)  import Michelson.ErrorPos (InstrCallStack(..), Pos(..), SrcPos(..))@@ -28,77 +29,7 @@ import qualified Michelson.Untyped as U import Tezos.Address (Address) import Tezos.Crypto (CryptoParseError)---- | Description of the type to be expected by certain instruction.-data ExpectType-  = ExpectTypeVar-  | ExpectStackVar-  | ExpectBool-  | ExpectInt-  | ExpectNat-  | ExpectByte-  | ExpectString-  | ExpectAddress-  | ExpectKey-  | ExpectKeyHash-  | ExpectSignature-  | ExpectContract-  | ExpectMutez-  | ExpectList (Maybe ExpectType)-  | ExpectSet (Maybe ExpectType)-  | ExpectMap-  | ExpectBigMap-  | ExpectOption (Maybe ExpectType)-  | ExpectPair (Maybe ExpectType)  (Maybe ExpectType)-  | ExpectOr (Maybe ExpectType)  (Maybe ExpectType)-  | ExpectLambda (Maybe ExpectType)  (Maybe ExpectType)-  deriving stock (Show, Eq, Generic)--instance NFData ExpectType--instance Buildable ExpectType where-  build = \case-    ExpectTypeVar -> "'a"-    ExpectStackVar -> "'A"-    ExpectBool -> "bool"-    ExpectInt -> "int"-    ExpectNat -> "nat"-    ExpectByte -> "byte"-    ExpectString -> "string"-    ExpectAddress -> "address"-    ExpectKey -> "key"-    ExpectKeyHash -> "key_hash"-    ExpectSignature -> "signature"-    ExpectMutez -> "mutez"-    ExpectContract -> "contract 'p"-    ExpectList expType ->-      "list "-        +| maybe "'a" build expType-    ExpectSet expType ->-      "set "-        +| maybe "'a" build expType-    ExpectMap -> "map 'key 'val"-    ExpectBigMap -> "big_map 'key 'val"-    ExpectOption expType ->-      "option "-        +| maybe "'a" build expType-    ExpectPair expType1 expType2 ->-      "pair "-        +| (maybe "'a" build expType1) +| " "-        +| (maybe "'b" build expType2) +| ""-    ExpectOr expType1 expType2 ->-      "or "-        +| (maybe "'a" build expType1) +| " "-        +| (maybe "'b" build expType2) +| ""-    ExpectLambda expType1 expType2 ->-      "lambda "-        +| (maybe "'a"-            (\case-              ExpectPair a b -> "(" +| ExpectPair a b |+ ")" -- bracket is needed for APPLY-              x -> build x-            ) expType1-           ) +| " "-        +| (maybe "'b" build expType2) +| ""+import qualified Tezos.Crypto.BLS12381 as BLS  -- | Contexts where type error can occur. data TypeContext@@ -118,6 +49,7 @@   | ConcatArgument   | ContainerKeyType   | ContainerValueType+  | FailwithArgument   deriving stock (Show, Eq, Generic)   deriving anyclass (NFData) @@ -139,6 +71,7 @@     ConcatArgument -> "argument to CONCAT"     ContainerKeyType -> "container key type"     ContainerValueType -> "container value type"+    FailwithArgument -> "argument to FAILWITH"  -- | Data type that represents various errors -- which are related to type system.@@ -159,12 +92,14 @@   | NotNumericTypes T.T T.T   -- ^ Arithmetic operation is applied to types, at least one of which is not numeric   -- (e.g. @timestamp@ and @timestamp@ passed to @MUL@ instruction).-  | UnexpectedType (NonEmpty (NonEmpty ExpectType))+  | UnexpectedType (NonEmpty (NonEmpty Text))   -- ^ Error that happens when actual types are different from the type that instruction expects.   -- The param is an non-empty list of all expected stack types that the instruction would accept.   -- Each expected stack types is represented as non-empty list as well.-  | InvalidInstruction U.ExpandedInstr-  -- ^ Some instruction can not be used in a specific context, like @SELF@ in @LAMBDA@.+  | InvalidInstruction U.ExpandedInstr Text+  -- ^ Some instruction is invalid or used in an invalid way.+  -- For example, @PAIR 0@ or @PAIR 1@, or a @SELF@ instruction was used in a @LAMBDA@.+  -- The 'Text' argument is a user-readable explanation of why this instruction is invalid.   | InvalidValueType T.T   -- ^ Error that happens when a `U.Value` is never a valid source for this type   -- (e.g. @timestamp@ cannot be obtained from a `U.ValueTrue`)@@ -186,10 +121,14 @@   -- ^ Address couldn't be parsed from its textual representation   | InvalidKeyHash CryptoParseError   -- ^ KeyHash couldn't be parsed from its textual representation+  | InvalidBls12381Object BLS.DeserializationError+  -- ^ BLS12-381 primitive couldn't be parsed   | InvalidTimestamp   -- ^ Timestamp is not RFC339 compliant   | CodeAlwaysFails-  -- ^ Code always fails, but shouldn't, like ITER body.+  -- ^ Code always fails, but shouldn't, like in ITER body.+  -- This is actually more general, any instruction that allows no continuation+  -- (like @NEVER@) cannot appear as part of another instruction's body.   | EmptyCode   -- ^ Empty block of code, like ITER body.   | AnyError@@ -216,8 +155,10 @@           $ fmap (\(x :| xs) -> "" +| listF (x:xs) |+ "")           $ (t:ts)         ) |+ ""-    InvalidInstruction instr ->-      "Forbidden instruction " +| instr |+ ""+    InvalidInstruction instr reason -> unlinesF+      [ "Invalid instruction " +| instr |+ ""+      , "Reason: " <> reason+      ]     InvalidValueType t ->       "Value type is never a valid `" +| t |+ "`"     NotEnoughItemsOnStack ->@@ -232,8 +173,11 @@     MutezOverflow -> "Exceeds maximal value for mutez"     InvalidAddress e -> build e     InvalidKeyHash e -> build e+    InvalidBls12381Object e -> build e     InvalidTimestamp -> "Is not a valid RFC3339 timestamp"-    CodeAlwaysFails -> "Code always fails, but is not supposed to"+    CodeAlwaysFails ->+      "Cannot use a terminate instruction (like FAILWITH) as part of another \+      \instruction's body"     EmptyCode -> "Code block is empty"     AnyError -> "Some of the arguments have invalid types" @@ -264,7 +208,7 @@       +| (maybe "" (\e -> "\n" +| e |+ ".\n") mbTCTypeError)       +| buildCallStack ics     TCContractError msg typeError ->-      "Error occured during contract typecheck: "+      "Error occurred during contract typecheck: "       +|| msg ||+ (maybe "" (\e -> " " +| e |+ "") typeError)     TCUnreachableCode ics instrs ->       "Unreachable code: " +| buildTruncated 3 (toList instrs) |+ ". "@@ -282,7 +226,7 @@       | null (drop k l) = build l       | otherwise = build (take k l) <> " ..."     buildCallStack InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos line) (Pos col)} =-      "Error occured on line " +| line + 1 |+ " char " +| col + 1 |+ ""+      "Error occurred on line " +| line + 1 |+ " char " +| col + 1 |+ ""       +| case icsCallStack of            [] -> "."            _ -> " inside these let defenitions: " +| listF icsCallStack |+ "."@@ -335,3 +279,43 @@     InvalidStackReference i lhs ->       "InvalidStackReference: reference is out of the stack: "       +| i ||+ " >= " +| lhs ||+ ""++----------------------------------------------------------------------------+-- Helpers for formatting types+----------------------------------------------------------------------------++-- | Given a node index @ix@, creates a string representing the+-- smallest possible right-combed pair with at least @ix+1@ nodes.+--+-- Since the node index 0 is valid even for non-pair values+-- (e.g. we can run @GET 0@ on a @string@ or an @int@),+-- we simply return a type variable @'a@ in this case.+--+-- >>> pairWithNodeIndex 0+-- "'a"+--+-- >>> pairWithNodeIndex 4+-- "pair 'a1 'a2 'a3"+--+-- >>> pairWithNodeIndex 5+-- "pair 'a1 'a2 'a3 'a4"+pairWithNodeIndex :: Word -> Text+pairWithNodeIndex = \case+  0 -> "'a"+  ix -> pairWithElems (minPairLength ix)+  where+    -- | Given a node index @ix@, calculates the minimum number of+    -- elements a pair must have for that index to be valid.+    minPairLength :: Word -> Word+    minPairLength = \case+      0 -> 2+      ix -> (ix + 3) `div` 2++-- | Given a number @n@, creates a string representing a+-- right-combed pair of arity @n@.+--+-- > pairType 3 == "pair 'a1 'a2 'a3"+pairWithElems :: Word -> Text+pairWithElems n =+  "pair "+  <> mconcat (intersperse " " ([1 .. n] <&> \i -> "'a" <> show i))

@@ -45,67 +45,75 @@  import Prelude hiding (EQ, GT, LT) +import Control.Lens (unsnoc) import Control.Monad.Except (MonadError, throwError) import Data.Constraint (Dict(..), withDict) import Data.Default (def) import Data.Singletons (Sing, SingI(sing), demote) import qualified Data.Text as T-import Data.Typeable ((:~:)(..), eqT)+import Data.Typeable (eqT, (:~:)(..)) import Fmt ((+||), (||+))  import Michelson.ErrorPos (InstrCallStack) import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..), TypeContext(..)) import Michelson.TypeCheck.TypeCheck-import Michelson.TypeCheck.Types import Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..))+import Michelson.TypeCheck.Types import Michelson.Typed   (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, ExtInstr(COMMENT_ITEM),   Instr(..), KnownT, Notes(..), PackedNotes(..), SingT(..), T(..), WellTyped, converge,-  getComparableProofS, notesT, orAnn, starNotes)+  getComparableProofS, notesT, starNotes) 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(..))  import qualified Michelson.Untyped as Un-import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, VarAnn, ann)+import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, VarAnn, ann, orAnn) import Util.Type (onFirst)  -- | Function which derives special annotations -- for PAIR instruction. -- -- Namely, it does following transformation:--- @---  PAIR %@@ %@@ [ @@p.a int : @@p.b int : .. ]---  ~---  [ @@p (pair (int %a) (int %b) : .. ]--- @ --+-- > PAIR %@ %@ [ @p.a int : @p.b int : .. ]+-- > ~+-- > [ @p pair (int %a) (int %b) : .. ]+-- -- All relevant cases (e.g. @PAIR %myf %@@ @) -- are handled as they should be according to spec. deriveSpecialFNs   :: FieldAnn -> FieldAnn   -> VarAnn -> VarAnn+  -> VarAnn   -> (VarAnn, FieldAnn, FieldAnn)-deriveSpecialFNs "@" "@" pvn qvn = (vn, pfn, qfn)+deriveSpecialFNs pfn qfn pvn qvn vn = (vn', pfn', qfn')   where-    ps = T.splitOn "." $ unAnnotation pvn-    qs = T.splitOn "." $ unAnnotation qvn-    fns = fst <$> takeWhile (uncurry (==)) (zip ps qs)-    vn = ann $ T.intercalate "." fns-    pfn = ann $ T.intercalate "." $ drop (length fns) ps-    qfn = ann $ T.intercalate "." $ drop (length fns) qs-deriveSpecialFNs "@" qfn pvn _   = (def, Un.convAnn pvn, qfn)-deriveSpecialFNs pfn "@" _ qvn   = (def, pfn, Un.convAnn qvn)-deriveSpecialFNs pfn qfn _ _     = (def, pfn, qfn)+    (vn1, pfn') = bool (vn, pfn) (splitLastDot pvn) (pfn == "@")+    (vn2, qfn') = bool (vn, qfn) (splitLastDot qvn) (qfn == "@")+    vn' = bool vn (commonPrefix vn1 vn2) (vn == def) +    splitLastDot :: VarAnn -> (VarAnn, FieldAnn)+    splitLastDot v = case unsnoc $ T.splitOn "." $ unAnnotation v of+      Nothing      -> def+      Just (_, "") -> (def, Un.convAnn v)+      Just (vs, l) -> (foldMap ann vs, bool (ann l) def (l == "car" || l == "cdr"))++    commonPrefix :: VarAnn -> VarAnn -> VarAnn+    commonPrefix = curry \case+      (v1, v2) | v1 == v2 -> v1+      (v1, "") -> v1+      ("", v2) -> v2+      _ -> def+ -- | Function which derives special annotations -- for CDR / CAR instructions.-deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn-deriveSpecialVN vn elFn pairVN+deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn+deriveSpecialVN vn elFn pairVN elVn   | vn == "%" = Un.convAnn elFn-  | vn == "%%" && elFn /= def = pairVN <> Un.convAnn elFn-  | otherwise = vn+  | vn == "%%" = pairVN <> Un.convAnn elFn+  | otherwise = vn `orAnn` elVn  -- | Append suffix to variable annotation (if it's not empty) deriveVN :: VarAnn -> VarAnn -> VarAnn@@ -260,8 +268,8 @@   -> Un.ExpandedOp   -> HST inp   -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-typeCheckOpImpl tcInstr op' inputStack = case op' of-  Un.WithSrcEx _ op@Un.WithSrcEx{} -> typeCheckOpImpl tcInstr op inputStack+typeCheckOpImpl tcInstr op' hst = case op' of+  Un.WithSrcEx _ op@Un.WithSrcEx{} -> typeCheckOpImpl tcInstr op hst   Un.WithSrcEx loc (Un.PrimEx op)  -> typeCheckPrimWithLoc loc op   Un.WithSrcEx loc (Un.SeqEx sq)   -> typeCheckSeqWithLoc loc sq   Un.PrimEx op                     -> typeCheckPrim op@@ -273,21 +281,21 @@       (wrapWithLoc loc <$> typeCheckPrim op)      typeCheckPrim :: Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    typeCheckPrim op = tcInstr op inputStack <&> mapSeq addNotes+    typeCheckPrim op = tcInstr op hst <&> mapSeq addNotes      typeCheckSeqWithLoc :: InstrCallStack -> [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)     typeCheckSeqWithLoc loc = fmap (wrapWithLoc loc) . local (const loc) . typeCheckSeq      typeCheckSeq :: [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)-    typeCheckSeq sq = typeCheckImpl tcInstr sq inputStack+    typeCheckSeq sq = typeCheckImpl tcInstr sq hst                   <&> mapSeq (addNotes . mapSomeInstr Nested)      addNotes :: SomeInstr inp -> SomeInstr inp-    addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes out i ::: out+    addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes inp out i ::: out     addNotes i = i -    wrapWithNotes :: HST d -> Instr c d -> Instr c d-    wrapWithNotes outputStack instr = case instr of+    wrapWithNotes :: HST c -> HST d -> Instr c d -> Instr c d+    wrapWithNotes inputStack outputStack instr = case instr of       -- Abstractions for instructions:       Nop -> instr'       Seq _ _ -> instr'@@ -296,12 +304,14 @@       Ext _ -> instr'       FrameInstr _ _ -> instr'       WithLoc _ _ -> instr'-      -- These two shouldn't happen, since annotations are added here.+      -- These three shouldn't happen, since annotations are added here.       InstrWithNotes _ _ -> instr'+      InstrWithVarAnns _ _ -> instr'       InstrWithVarNotes _ _ -> instr'        -- Instructions that don't produce notes:       DROP -> instr'+      DROPN _ -> instr'       SWAP -> instr'       DIG _ -> instr'       DUG _ -> instr'@@ -315,29 +325,131 @@       DIP _ -> instr'       DIPN _ _ -> instr'       FAILWITH -> instr'+      NEVER -> instr' +      -- We purposefully don't wrap `UNPAIRN` in meta-instructions+      -- like `InstrWithNotes` and `InstrWithVarAnns`.+      -- See !769 for a lengthy explanation.+      UNPAIRN _ -> instr+       -- Instructions that produce at most two notes:       CREATE_CONTRACT _ -> case outputStack of         ((np, _, vp) ::& (_, _, vs) ::& _) ->           let withNotes = if isStar np then id else InstrWithNotes (PackedNotes np)               withVarNotes = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarNotes (vp :| [vs])-           in withNotes . withVarNotes $ instr+              withVarNotes' = if vp == Un.noAnn && vs == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns vp vs+           in withNotes . withVarNotes . withVarNotes' $ instr        -- Instructions that produce at most one note:-      _ -> case outputStack of-        ((n, _, v) ::& _) ->-          let withNotes = if isStar n then id else InstrWithNotes (PackedNotes n)-              withVarNotes = if v == Un.noAnn then id else InstrWithVarNotes (one v)-           in withNotes . withVarNotes $ instr-        SNil -> instr+      -- The cases for Ann{CAR,CDR} basically try to answer the question:+      -- were the var annotations explicitly written or do they come from+      -- unnesting nested annotations?+      AnnCAR _ -> case (inputStack, outputStack) of+        ((NTPair _ _ _ vn1 _vn2 _ _, _, _) ::& _, (_, _, vn) ::& _)+          | vn  /= def && vn /= vn1 -> instr''+          | vn1 == def -> instr''+          | otherwise -> instr'+      AnnCDR _ -> case (inputStack, outputStack) of+        ((NTPair _ _ _ _vn1 vn2 _ _, _, _) ::& _, (_, _, vn) ::& _)+          | vn  /= def && vn /= vn2 -> instr''+          | vn2 == def -> instr''+          | otherwise -> instr'+      DUP -> instr''+      DUPN _ -> instr''+      PUSH _ -> instr''+      UNIT -> instr''+      SOME -> instr''+      NONE -> instr''+      AnnPAIR{} -> instr''+      LEFT -> instr''+      RIGHT -> instr''+      NIL -> instr''+      CONS -> instr''+      SIZE -> instr''+      MAP _ -> instr''+      MEM -> instr''+      EMPTY_SET -> instr''+      EMPTY_MAP -> instr''+      EMPTY_BIG_MAP -> instr''+      UPDATE -> instr''+      UPDATEN _ -> instr''+      GET -> instr''+      GETN _ -> instr''+      LAMBDA _ -> instr''+      EXEC -> instr''+      ADD -> instr''+      SUB -> instr''+      CONCAT -> instr''+      CONCAT' -> instr''+      MUL -> instr''+      OR -> instr''+      AND -> instr''+      XOR -> instr''+      NOT -> instr''+      ABS -> instr''+      ISNAT -> instr''+      INT -> instr''+      NEG -> instr''+      EDIV -> instr''+      LSL -> instr''+      LSR -> instr''+      COMPARE -> instr''+      EQ -> instr''+      NEQ -> instr''+      LT -> instr''+      GT -> instr''+      LE -> instr''+      GE -> instr''+      ADDRESS -> instr''+      CONTRACT _ _ -> instr''+      SET_DELEGATE -> instr''+      IMPLICIT_ACCOUNT -> instr''+      NOW -> instr''+      LEVEL -> instr''+      AMOUNT -> instr''+      BALANCE -> instr''+      HASH_KEY -> instr''+      CHECK_SIGNATURE -> instr''+      BLAKE2B -> instr''+      SOURCE -> instr''+      SENDER -> instr''+      SELF _ -> instr''+      SELF_ADDRESS -> instr''+      CAST -> instr''+      RENAME -> instr''+      CHAIN_ID -> instr''+      APPLY -> instr''+      PAIRN _ -> instr''+      PACK -> instr''+      UNPACK -> instr''+      SLICE -> instr''+      TRANSFER_TOKENS -> instr''+      VOTING_POWER -> instr''+      TOTAL_VOTING_POWER -> instr''+      SHA256 -> instr''+      SHA512 -> instr''+      SHA3 -> instr''+      KECCAK -> instr''+      PAIRING_CHECK -> instr''       where         instr' = addNotesNoVarAnn outputStack instr+        instr'' = addNotesOneVarAnn outputStack instr +    addNotesOneVarAnn :: HST d -> Instr c d -> Instr c d+    addNotesOneVarAnn outputStack instr = case outputStack of+      ((n, _, v) ::& _) ->+        let withNotes = if isStar n then id else InstrWithNotes (PackedNotes n)+            withVarNotes = if v == Un.noAnn then id else InstrWithVarNotes (one v)+            withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v+         in withNotes . withVarNotes . withVarNotes' $ instr+      SNil -> instr+     addNotesNoVarAnn :: HST d -> Instr c d -> Instr c d     addNotesNoVarAnn outputStack instr = case outputStack of-      ((n, _, _) ::& _)-        | isStar n -> instr-        | otherwise -> InstrWithNotes (PackedNotes n) instr+      ((n, _, v) ::& _) ->+          let withNotes = if isStar n then id else InstrWithNotes (PackedNotes n)+              withVarNotes' = if v == Un.noAnn then id else InstrWithVarAnns $ Un.OneVarAnn v+           in withNotes . withVarNotes' $ instr       SNil -> instr  -- | Like 'typeCheckImpl' but doesn't add a stack type comment after the@@ -562,8 +674,9 @@         (Just ContainerKeyType) (converge updKeyNotes cKeyNotes)       _ <- onTypeCheckInstrAnnErr uInstr inputHST         (Just ContainerValueType) (converge updValueNotes cValueNotes)+      let vn = varAnn `orAnn` (cTuple ^. _3)       pure $ inputHST :/-        UPDATE ::: ((cTuple & _3 .~ varAnn) ::& hstTail)+        UPDATE ::: ((cTuple & _3 .~ vn) ::& hstTail)     (Left m, _) ->       typeCheckInstrErr' uInstr (SomeHST inputHST) (Just ContainerKeyType) m     (_, Left m) ->@@ -656,6 +769,9 @@   (STInt, STTimestamp) -> arithImpl @Add ADD   (STTimestamp, STInt) -> arithImpl @Add ADD   (STMutez, STMutez) -> arithImpl @Add ADD+  (STBls12381Fr, STBls12381Fr) -> arithImpl @Add ADD+  (STBls12381G1, STBls12381G1) -> arithImpl @Add ADD+  (STBls12381G2, STBls12381G2) -> arithImpl @Add ADD   _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b) @@ -745,6 +861,13 @@   (STNat, STNat) -> arithImpl @Mul MUL   (STNat, STMutez) -> arithImpl @Mul MUL   (STMutez, STNat) -> arithImpl @Mul MUL+  (STInt, STBls12381Fr) -> arithImpl @Mul MUL+  (STNat, STBls12381Fr) -> arithImpl @Mul MUL+  (STBls12381Fr, STInt) -> arithImpl @Mul MUL+  (STBls12381Fr, STNat) -> arithImpl @Mul MUL+  (STBls12381Fr, STBls12381Fr) -> arithImpl @Mul MUL+  (STBls12381G1, STBls12381Fr) -> arithImpl @Mul MUL+  (STBls12381G2, STBls12381Fr) -> arithImpl @Mul MUL   _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b) 

@@ -43,7 +43,7 @@  import Prelude hiding (EQ, GT, LT) -import Control.Monad.Except (MonadError, liftEither, throwError, catchError)+import Control.Monad.Except (MonadError, catchError, liftEither, throwError) import Data.Default (def) import Data.Generics (everything, mkQ) import Data.Singletons (Sing, demote)@@ -55,17 +55,18 @@ import Michelson.TypeCheck.Helpers import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.TypeCheckedSeq-  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), tcsEither, someInstrToOp)+  (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp,+  tcsEither) import Michelson.TypeCheck.Types import Michelson.TypeCheck.Value import Michelson.Typed.Value -import Michelson.Typed+import Michelson.Typed hiding (Branch(..)) import Util.Peano-import Util.Type (onFirst)+import Util.Type (onFirst, type (++))  import qualified Michelson.Untyped as U-import Michelson.Untyped.Annotation (VarAnn)+import Michelson.Untyped.Annotation (FieldTag, VarAnn, VarTag, convAnn, orAnn)  -- | Type check a contract and verify that the given storage -- is of the type expected by the contract.@@ -123,7 +124,9 @@             $ checkScope @(ParameterScope param)           Dict <- either (hasTypeError @st "storage") pure             $ checkScope @(StorageScope st)-          let inpNote = NTPair def def def paramNote storageNote+          let param = "parameter"+          let store = "storage"+          let inpNote = NTPair def def def param store paramNote storageNote           let inp = (inpNote, Dict, def) ::& SNil            codeRes <- usingReaderT def $@@ -131,7 +134,7 @@                      typeCheckImpl typeCheckInstr pCode inp           codeRes & tcsEither             (onFailedTypeCheck)-            (onSuccessfulTypeCheck (NTPair def def def starNotes storageNote))+            (onSuccessfulTypeCheck (NTPair def def def def def starNotes storageNote))   where     hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a     hasTypeError name reason = throwError $@@ -158,7 +161,7 @@       -> TypeCheck SomeContract     onSuccessfulTypeCheck outNote i@(inp' :/ instrOut) = wrapErrorsIfVerbose i $ do       let (paramNotesRaw, cStoreNotes) = case inp' of-            (NTPair _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)+            (NTPair _ _ _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)       cParamNotes <-         liftEither $         mkParamNotes paramNotesRaw rootAnn `onFirst`@@ -270,28 +273,75 @@   withSomeSingT (fromUType typeU) $ \(_ :: Sing t) ->     SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU --- Helper data type we use to typecheck DROPN.+-- | Helper data type we use to typecheck DUPN.+data TCDupNHelper inp where+  TCDupNHelper ::+    forall (n :: Peano) inp out a.+    (Typeable out, ConstraintDUPN n inp out a) =>+    Sing n -> HST out -> TCDupNHelper inp++-- | Helper data type we use to typecheck DROPN. data TCDropHelper inp where   TCDropHelper ::     forall (n :: Peano) inp out.     (Typeable out, SingI n, KnownPeano n, LongerOrSameLength inp n, Drop n inp ~ out) =>     Sing n -> HST out -> TCDropHelper inp --- Helper data type we use to typecheck DIG.+-- | Helper data type we use to typecheck DIG. data TCDigHelper inp where   TCDigHelper ::     forall (n :: Peano) inp out a.     (Typeable out, ConstraintDIG n inp out a) =>     Sing n -> HST out -> TCDigHelper inp --- Helper data type we use to typecheck DUG.+-- | Helper data type we use to typecheck DUG. data TCDugHelper inp where   TCDugHelper ::     forall (n :: Peano) inp out a.     (Typeable out, ConstraintDUG n inp out a) =>     Sing n -> HST out -> TCDugHelper inp --- Helper function to convert a simple throwing typechecking action into a+-- | Helper data type we use to typecheck PAIRN.+--+-- It holds all the necessary data to construct a typed PAIRN+-- instruction once we're done traversing the stack.+data TCPairNHelper inp where+  TCPairNHelper ::+    forall (n :: Peano) (inp :: [T]).+    (Typeable (PairN n inp), ConstraintPairN n inp) =>+    Sing n -> HST (PairN n inp) -> TCPairNHelper inp++-- | Helper data type we use to typecheck UNPAIRN.+--+-- It holds all the necessary data to construct a typed UNPAIRN+-- instruction once we're done traversing the pair.+data TCUnpairNHelper (inp :: [T]) where+  TCUnpairNHelper ::+    forall (n :: Peano) (a :: T) (b :: T) (rest :: [T]).+    (Typeable (UnpairN n ('TPair a b) ++ rest), ConstraintUnpairN n ('TPair a b)) =>+    Sing n -> HST (UnpairN n ('TPair a b) ++ rest) -> TCUnpairNHelper ('TPair a b : rest)++-- | Helper data type we use to typecheck GETN.+--+-- It holds all the necessary data to construct a typed GETN+-- instruction once we're done traversing the pair.+data TCGetNHelper (inp :: [T]) where+  TCGetNHelper ::+    forall (ix :: Peano) (pair :: T) (rest :: [T]).+    (Typeable (GetN ix pair ': rest), ConstraintGetN ix pair) =>+    Sing ix -> HST (GetN ix pair ': rest) -> TCGetNHelper (pair : rest)++-- | Helper data type we use to typecheck UPDATEN.+--+-- It holds all the necessary data to construct a typed UPDATEN+-- instruction once we're done traversing the pair.+data TCUpdateNHelper (inp :: [T]) where+  TCUpdateNHelper ::+    forall (ix :: Peano) (val :: T) (pair :: T) (rest :: [T]).+    (Typeable (UpdateN ix val pair ': rest), ConstraintUpdateN ix pair) =>+    Sing ix -> HST (UpdateN ix val pair ': rest) -> TCUpdateNHelper (val : pair : rest)++-- | Helper function to convert a simple throwing typechecking action into a -- non-throwing one, embedding possible errors into the type checking tree. workOnInstr   :: U.ExpandedInstr@@ -301,7 +351,7 @@   (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])   (pure . WellTypedSeq) --- Less verbose version of `lift ... typeCheckListNoExcept`.+-- | Less verbose version of `lift ... typeCheckListNoExcept`. tcList   :: (Typeable inp)   => [U.ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)@@ -337,56 +387,75 @@         => Word         -> HST inp         -> TypeCheckInstr (TCDropHelper inp)-      go n i = case (n, i) of-        (0, _) -> pure (TCDropHelper SZ i)+      go = curry \case+        (0, i) -> pure (TCDropHelper SZ i)          (_, SNil) -> notEnoughItemsOnStack' -        (_, (_ ::& iTail)) -> do-          go (n - 1) iTail <&> \case TCDropHelper s out -> TCDropHelper (SS s) out+        (n, (_ ::& iTail)) -> do+          go (n - 1) iTail <&> \(TCDropHelper s out) -> TCDropHelper (SS s) out    (U.DUP vn1, a@(n, d, _vn2) ::& rs) -> workOnInstr uInstr $     pure (inp :/ DUP ::: ((n, d, vn1) ::& a ::& rs))    (U.DUP _vn, SNil) -> notEnoughItemsOnStack +  (U.DUPN vn nTotal, inputHST) -> workOnInstr uInstr $+    go nTotal inputHST <&> \(TCDupNHelper s out) -> inputHST :/ DUPN s ::: out+    where+      go :: forall inp. Typeable inp+        => Word+        -> HST inp+        -> TypeCheckInstr (TCDupNHelper inp)+      go = curry \case+        (_, SNil) -> notEnoughItemsOnStack'++        (0, _) ->+          typeCheckInstrErr' uInstr (SomeHST inp) Nothing (InvalidInstruction uInstr "'DUP n' expects n > 0")++        -- Don't bind whatever variable annotation is here because DUP n doesn't+        -- duplicate variable annotations. This is consistent with tezos-client.+        (1, i@((an, dict, _) ::& _)) -> pure (TCDupNHelper (SS SZ) ((an, dict, vn) ::& i))++        (n, (b ::& iTail)) ->+          go (n - 1) iTail <&> \(TCDupNHelper s@(SS _) (a ::& resTail)) ->+            TCDupNHelper (SS s) (a ::& b ::& resTail)+   (U.SWAP, a ::& b ::& rs) -> workOnInstr uInstr $     pure (inp :/ SWAP ::: (b ::& a ::& rs))    (U.SWAP, _) -> notEnoughItemsOnStack    (U.DIG nTotal, inputHST) -> workOnInstr uInstr $-    go nTotal inputHST <&> \case-      TCDigHelper s out -> inputHST :/ DIG s ::: out+    go nTotal inputHST <&> \(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+      go = curry \case         -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).         (_, SNil) -> notEnoughItemsOnStack' -        (0, (_ ::& _)) -> pure (TCDigHelper SZ i)+        (0, i@(_ ::& _)) -> pure (TCDigHelper SZ i) -        (_, (b ::& iTail)) ->-          go (n - 1) iTail <&> \case-          TCDigHelper s (a ::& resTail) -> TCDigHelper (SS s) (a ::& b ::& resTail)+        (n, (b ::& iTail)) ->+          go (n - 1) iTail <&> \(TCDigHelper s (a ::& resTail)) ->+            TCDigHelper (SS s) (a ::& b ::& resTail)    (U.DUG nTotal, inputHST) -> workOnInstr uInstr $-    go nTotal inputHST <&> \case-      TCDugHelper s out -> inputHST :/ DUG s ::: out+    go nTotal inputHST <&> \(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)+      go = curry \case+        (0, i@(_ ::& _)) -> pure (TCDugHelper SZ i) -        (_, (a ::& b ::& iTail)) ->-          go (n - 1) (a ::& iTail) <&> \case-          TCDugHelper s resTail -> TCDugHelper (SS s) (b ::& resTail)+        (n, (a ::& b ::& iTail)) ->+          go (n - 1) (a ::& iTail) <&> \(TCDugHelper s resTail) ->+            TCDugHelper (SS s) (b ::& resTail)          -- Two cases:         -- 1. Input stack is empty.@@ -420,42 +489,121 @@       genericIf IF_NONE U.IF_NONE mp mq rs ((an, Dict, avn) ::& rs) inp    (U.IF_NONE _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ (ExpectOption Nothing :| []) :| []+    failWithErr $ UnexpectedType $ ("option 'a" :| []) :| []    (U.IF_NONE _ _, SNil) -> notEnoughItemsOnStack -  (U.PAIR tn vn pfn qfn, (an, _, avn) ::& (bn, _, bvn) ::& rs) -> workOnInstr uInstr $ do-    let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn-    case NTPair tn pfn' qfn' an bn of-      (ns :: Notes ('TPair a b)) -> withWTPInstr @('TPair a b) $-        pure (inp :/ AnnPAIR tn pfn qfn ::: ((ns, Dict, vn `orAnn` vn') ::& rs))+  (U.PAIR tn vn pfn qfn, (an :: Notes a, _, avn) ::& (bn :: Notes b, _, bvn) ::& rs) -> workOnInstr uInstr $ do+    let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn vn+    withWTPInstr @('TPair a b) $+      pure (inp :/ AnnPAIR tn pfn qfn ::: ((NTPair tn pfn' qfn' avn bvn an bn, Dict, vn') ::& rs))    (U.PAIR {}, _) -> notEnoughItemsOnStack -  (U.CAR vn fn, (STPair{}, NTPair pairTN pfn qfn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> workOnInstr uInstr $ do-    pfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeAnns fn pfn)+  (U.PAIRN varAnn nTotal, _) -> workOnInstr uInstr $ do+    go nTotal inp <&> \case+      TCPairNHelper s out -> inp :/ PAIRN s ::: addVarAnn out+    where+      go :: forall inp. Word -> HST inp -> TypeCheckInstr (TCPairNHelper inp)+      go n hst+        | n < 2 =+            typeCheckInstrErr' uInstr (SomeHST inp) Nothing+              (InvalidInstruction uInstr "'PAIR n' expects n ≥ 2")+        | n == 2 =+            case hst of+              (an :: Notes a, _, avn) ::& (bn :: Notes b, _, bvn) ::& hstTail -> do+                withWTPInstr @('TPair a b) $ do+                  pure $ TCPairNHelper (SS (SS SZ)) $+                    (mkNotes an bn avn bvn, Dict, U.noAnn) ::& hstTail+              _ -> notEnoughItemsOnStack'+        | otherwise =+            case hst of+              (an :: Notes a, _, avn) ::& hstTail@(_ ::& _ ::& _) -> do+                go (n - 1) hstTail >>= \case+                  TCPairNHelper nSing@(SS (SS _)) ((bn :: Notes b, _, bvn) ::& hstTail') -> do+                    withWTPInstr @('TPair a b) $ do+                      pure $ TCPairNHelper (SS nSing) $+                        (mkNotes an bn avn bvn, Dict, U.noAnn) ::& hstTail'+              _ -> notEnoughItemsOnStack'++      -- | @PAIR n@ instructions take the variable annotations of each+      -- element in the stack and turn them into field annotations. E.g.:+      --+      -- > /* [ @bb nat : @aa nat ] */ ;+      -- > PAIR 2+      -- > /* [ pair (nat %bb) (nat %aa) ] */ ;+      mkNotes :: forall a b. Notes a -> Notes b -> VarAnn -> VarAnn -> Notes ('TPair a b)+      mkNotes an bn avn bvn =+        NTPair U.noAnn+          (convAnn @VarTag @FieldTag avn) (convAnn @VarTag @FieldTag bvn)+          U.noAnn U.noAnn+          an bn++      -- | If a @PAIR n@ instruction has a variable annotation,+      -- the var annotation should be added ONLY to the top-most @pair@ value.+      --+      -- > /* [ nat : nat : nat ] */ ;+      -- > PAIR @aa 3+      -- > /* [ @aa pair nat nat nat ] */ ;+      addVarAnn :: forall a inp. HST (a ': inp) -> HST (a ': inp)+      addVarAnn = \case+        (an, dict, _) ::& hstTail -> (an, dict, varAnn) ::& hstTail++  (U.UNPAIRN _, SNil) -> notEnoughItemsOnStack+  (U.UNPAIRN nTotal, _ ::& _) -> workOnInstr uInstr $ do+    go nTotal inp <&> \case+      TCUnpairNHelper s out ->+        inp :/ UNPAIRN s ::: out+    where+      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCUnpairNHelper (x : xs))+      go n hst+        | n < 2 =+            typeCheckInstrErr' uInstr (SomeHST inp) Nothing+              (InvalidInstruction uInstr "UNPAIR expects an argument of at least 2.")+        | n == 2 =+            case hst of+              (NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes, Dict, _) ::& rest -> do+                pure $ TCUnpairNHelper (SS (SS SZ)) $+                  (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn)+                  ::& (bNotes, Dict, convAnn @FieldTag @VarTag bFieldAnn)+                  ::& rest+              _ -> unexpectedType+        | otherwise =+            case hst of+              (NTPair _ aFieldAnn _ _ _ aNotes bNotes, Dict, _) ::& rest -> do+                go (n - 1) ((bNotes, Dict, U.noAnn) ::& rest) >>= \case+                  TCUnpairNHelper nSing@(SS (SS _)) out -> do+                    pure $ TCUnpairNHelper (SS nSing) $+                      (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn) ::& out+              _ -> unexpectedType++      unexpectedType :: TypeCheckInstr a+      unexpectedType = failWithErr' $ UnexpectedType $ (pairWithElems nTotal :| []) :| []++  (U.CAR vn fn, (STPair{}, NTPair pairTN pfn qfn pvn qvn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> workOnInstr uInstr $ do+    pfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeDestrAnns fn pfn)     withWTPInstr @p $       withWTPInstr @('TPair p q) $ do-        let vn' = deriveSpecialVN vn pfn' pairVN-            i' = (NTPair pairTN pfn' qfn pns qns, Dict, pairVN) ::& rs+        let vn' = deriveSpecialVN vn pfn' pairVN pvn+            i' = (NTPair pairTN pfn' qfn pvn qvn pns qns, Dict, pairVN) ::& rs         pure $ i' :/ AnnCAR fn ::: ((pns, Dict, vn') ::& rs)    (U.CAR _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ (ExpectPair Nothing Nothing :| []) :| []+    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []    (U.CAR _ _, SNil) -> notEnoughItemsOnStack -  (U.CDR vn fn, (STPair{}, NTPair pairTN pfn qfn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> workOnInstr uInstr $ do-    qfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeAnns fn qfn)+  (U.CDR vn fn, (STPair{}, NTPair pairTN pfn qfn pvn qvn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> workOnInstr uInstr $ do+    qfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeDestrAnns fn qfn)      withWTPInstr @q $       withWTPInstr @('TPair p q) $ do-        let vn' = deriveSpecialVN vn qfn' pairVN-            i' = (NTPair pairTN pfn qfn' pns qns, Dict, pairVN) ::& rs+        let vn' = deriveSpecialVN vn qfn' pairVN qvn+            i' = (NTPair pairTN pfn qfn' pvn qvn pns qns, Dict, pairVN) ::& rs         pure $ i' :/ AnnCDR fn ::: ((qns, Dict, vn') ::& rs)    (U.CDR _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ (ExpectPair Nothing Nothing :| []) :| []+    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []    (U.CDR _ _, SNil) -> notEnoughItemsOnStack @@ -473,7 +621,7 @@         let ns = NTOr tn pfn qfn an bn         pure (inp :/ RIGHT ::: ((ns, Dict, vn) ::& rs)) -  ( U.RIGHT {}, SNil) -> notEnoughItemsOnStack+  (U.RIGHT {}, SNil) -> notEnoughItemsOnStack    (U.IF_LEFT mp mq, (STOr{}, ons, _, ovn) ::&+ rs) -> do     case deriveNsOr ons ovn of@@ -486,7 +634,7 @@             genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp    (U.IF_LEFT _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ (ExpectOr Nothing Nothing :| []) :| []+    failWithErr $ UnexpectedType $ ("or 'a 'b" :| []) :| []    (U.IF_LEFT _ _, SNil) -> notEnoughItemsOnStack @@ -513,7 +661,7 @@         genericIf IF_CONS U.IF_CONS mp mq ait rs inp    (U.IF_CONS _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ (ExpectList Nothing :| []) :| []+    failWithErr $ UnexpectedType $ ("list 'a" :| []) :| []    (U.IF_CONS _ _, SNil)-> notEnoughItemsOnStack @@ -524,11 +672,11 @@   (U.SIZE vn, (NTBytes{}, _, _) ::& _) -> workOnInstr uInstr $ sizeImpl inp vn   (U.SIZE _, _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectList Nothing :| []) :|-      [ (ExpectSet Nothing :| [])-      , (ExpectMap :| [])-      , (ExpectString :| [])-      , (ExpectByte :| [])+      $ ("list 'a" :| []) :|+      [ ("set 'a" :| [])+      , ("map 'k 'v" :| [])+      , ("string" :| [])+      , ("bytes" :| [])       ]    (U.SIZE _, SNil) -> notEnoughItemsOnStack@@ -553,10 +701,10 @@   (U.MAP vn mp, (STList _, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> do     withWTPInstr' @t1 $       mapImpl (U.MAP vn) vns uInstr mp inp-        (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $  (NTList def rn, Dict, vn) ::& hst)+        (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $ (NTList def rn, Dict, vn) ::& hst)    (U.MAP vn mp, (STMap{}, NTMap _ kns vns, Dict, _vn) ::&+ _) -> do-    case NTPair def def def kns vns of+    case NTPair def def def def def kns vns of       (pns :: Notes ('TPair k v1)) ->         withWTPInstr' @('TPair k v1) $           mapImpl (U.MAP vn) pns uInstr mp inp@@ -564,8 +712,8 @@    (U.MAP _ _, _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectList Nothing :| []) :|-      [ (ExpectMap :| [])+      $ ("list 'a" :| []) :|+      [ ("map 'k 'v" :| [])       ]    (U.MAP _ _, SNil) -> notEnoughItemsOnStack@@ -579,15 +727,15 @@       iterImpl en uInstr is inp    (U.ITER is, (STMap _ _, NTMap _ kns vns, _, _) ::&+ _) -> do-    case NTPair def def def kns vns of+    case NTPair def def def def def kns vns of       (en :: Notes ('TPair a b)) ->         withWTPInstr' @('TPair a b) $ iterImpl en uInstr is inp    (U.ITER _, _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectSet Nothing :| []) :|-      [ (ExpectList Nothing :| [])-      , (ExpectMap :| [])+      $ ("set 'a" :| []) :|+      [ ("list 'a" :| [])+      , ("map 'k 'v" :| [])       ]    (U.ITER _, SNil) -> notEnoughItemsOnStack@@ -603,14 +751,13 @@     memImpl notesK inp varNotes   (U.MEM _, _ ::& _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectTypeVar :| [ExpectSet Nothing]) :|-      [ (ExpectTypeVar :| [ExpectMap])-      , (ExpectTypeVar :| [ExpectBigMap])+      $ ("'a" :| ["set 'a"]) :|+      [ ("'k" :| ["map 'k 'v"])+      , ("'k" :| ["big_map 'k 'v"])       ]    (U.MEM _, _) -> notEnoughItemsOnStack -   (U.GET varNotes,    _ ::& (STMap{}, NTMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->     workOnInstr uInstr $ withWTPInstr @v $@@ -622,12 +769,28 @@    (U.GET _, _ ::& _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectTypeVar :| [ExpectMap]) :|-      [ (ExpectTypeVar :| [ExpectBigMap])+      $ ("'k" :| ["map 'k 'v"]) :|+      [ ("'k" :| ["big_map 'k 'v"])       ]    (U.GET _, _) -> notEnoughItemsOnStack +  (U.GETN _ _, SNil) -> notEnoughItemsOnStack+  (U.GETN getNVarAnn ix0, _ ::& _) -> workOnInstr uInstr $ do+    go ix0 inp <&> \case+      TCGetNHelper s out ->+        inp :/ GETN s ::: out+    where+      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCGetNHelper (x : xs))+      go 0 ((a, Dict, _) ::& rest) =+        pure $ TCGetNHelper SZ ((a, Dict, getNVarAnn) ::& rest)+      go 1 ((NTPair _ _ _ _ _ leftNotes _, Dict, _) ::& rest) =+        pure $ TCGetNHelper (SS SZ) $ (leftNotes, Dict, getNVarAnn) ::& rest+      go ix ((NTPair _ _ _ _ _ _ rightNotes, Dict, _) ::& rest) =+        go (ix - 2) ((rightNotes, Dict, U.noAnn) ::& rest) <&> \(TCGetNHelper ixSing out) ->+          TCGetNHelper (SS (SS ixSing)) out+      go _ _ = failWithErr' $ UnexpectedType $ (pairWithNodeIndex ix0 :| []) :| []+   (U.UPDATE varNotes,    _ ::& _ ::& (STMap{}, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->     workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varNotes@@ -640,18 +803,38 @@    (U.UPDATE _, _ ::& _ ::& _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectTypeVar :| [ExpectTypeVar, ExpectMap]) :|-      [ (ExpectTypeVar :| [ExpectTypeVar, ExpectBigMap])-      , (ExpectTypeVar :| [ExpectTypeVar, ExpectSet Nothing])+      $ ("'a" :| ["bool", "set 'a"]) :|+      [ ("'k" :| ["option 'v", "map 'k 'v"])+      , ("'k" :| ["option 'v", "big_map 'k 'v"])       ]    (U.UPDATE _, _) -> notEnoughItemsOnStack +  (U.UPDATEN updateNVarAnn ix0, _ ::& _ ::& _) -> workOnInstr uInstr $ do+    go ix0 inp <&> \case+      TCUpdateNHelper s out ->+        inp :/ UPDATEN s ::: out+    where+      go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr (TCUpdateNHelper (val : pair : rest))+      go 0 ((valNotes, Dict, _) ::& (_, _, _) ::& rest) =+        pure $ TCUpdateNHelper SZ $+          (valNotes, Dict, updateNVarAnn) ::& rest+      go 1 ((valNotes, Dict, _) ::& (NTPair pairTA leftFA rightFA leftVA rightVA _ rightNotes, Dict, _) ::& rest) =+        pure $ TCUpdateNHelper (SS SZ) $+          (NTPair pairTA leftFA rightFA leftVA rightVA valNotes rightNotes, Dict, updateNVarAnn) ::& rest+      go ix (val ::& (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes rightNotes, Dict, _) ::& rest) =+        go (ix - 2) (val ::& (rightNotes, Dict, U.noAnn) ::& rest) <&>+          \(TCUpdateNHelper ixSing ((updatedRightNotes, Dict, _) ::& outRest)) ->+            TCUpdateNHelper (SS (SS ixSing)) $+              (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes updatedRightNotes, Dict, updateNVarAnn) ::& outRest+      go _ _ = failWithErr' $ UnexpectedType $ ("'val" :| [pairWithNodeIndex ix0]) :| []+  (U.UPDATEN _ _, _) -> notEnoughItemsOnStack+   (U.IF mp mq, (NTBool{}, _, _) ::& rs) ->     genericIf IF U.IF mp mq rs rs inp    (U.IF _ _, _ ::& _) ->-    failWithErr $ UnexpectedType $ (ExpectBool :| []) :| []+    failWithErr $ UnexpectedType $ ("bool" :| []) :| []    (U.IF _ _, SNil) -> notEnoughItemsOnStack @@ -659,17 +842,15 @@     preserving (tcList is rs) U.LOOP $ \(_ :/ tp) ->       case tp of         subI ::: (o :: HST o) -> do-          case eqHST o (sing @('TBool) -:& rs) of-            Right Refl -> do-              let _ ::& rs' = o-              pure $ inp :/ LOOP subI ::: rs'+          case eqHST o (sing @'TBool -:& rs) of+            Right Refl -> pure $ inp :/ LOOP subI ::: rs             Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m         AnyOutInstr subI ->           pure $ inp :/ LOOP subI ::: rs    (U.LOOP _, _ ::& _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectBool :| [ExpectStackVar]) :| []+      $ ("bool" :| []) :| []    (U.LOOP _, _) -> notEnoughItemsOnStack @@ -695,7 +876,7 @@    (U.LOOP_LEFT _, _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectOr Nothing Nothing :| [ExpectStackVar]) :| []+      $ ("or 'a 'b" :| []) :| []    (U.LOOP_LEFT _, _) -> notEnoughItemsOnStack @@ -723,13 +904,13 @@    (U.EXEC _, _ ::& _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectTypeVar :| [ExpectLambda Nothing Nothing]) :| []+      $ ("'a" :| ["lambda 'a 'b"]) :| []    (U.EXEC _, _) -> notEnoughItemsOnStack    (U.APPLY vn, ((_ :: Notes a'), _, _)                   ::& ( STLambda (STPair _ _) _-                      , NTLambda vann (NTPair _ _ _ (_ :: Notes a) (nb :: Notes b)) sc+                      , NTLambda vann (NTPair _ _ _ _ _ (_ :: Notes a) (nb :: Notes b)) sc                       , _                       , _)                   ::&+ rs) -> workOnInstr uInstr $ do@@ -746,7 +927,7 @@    (U.APPLY _, _ ::& _ ::& _) ->     failWithErr $ UnexpectedType-      $ (ExpectTypeVar :| [ExpectLambda (Just $ ExpectPair Nothing Nothing) Nothing]) :| []+      $ ("'a" :| ["lambda (pair 'a 'b) 'c"]) :| []    (U.APPLY _, _) -> notEnoughItemsOnStack @@ -780,7 +961,9 @@           TCDipHelperErr err rest -> TCDipHelperErr err rest    (u, v) -> case (u, v) of -- Workaround for not exceeding -fmax-pmcheck-iterations limit-    (U.FAILWITH, (_ ::& _)) -> workOnInstr uInstr $+    (U.FAILWITH, ((_ :: Notes a, _, _) ::& _)) -> workOnInstr uInstr $ do+      Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just FailwithArgument)+        $ checkScope @(ConstantScope a)       pure $ inp :/ AnyOutInstr FAILWITH      (U.FAILWITH, _) -> notEnoughItemsOnStack@@ -810,7 +993,7 @@             pure $ inp :/ UNPACK ::: ((ns, Dict, vn) ::& rs)      (U.UNPACK {}, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectByte :| []) :| []+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []      (U.UNPACK {}, SNil) -> notEnoughItemsOnStack @@ -829,15 +1012,12 @@       workOnInstr uInstr $ concatImpl' inp vn     (U.CONCAT vn, (STList STString, _, _, _) ::&+ _) ->       workOnInstr uInstr $ concatImpl' inp vn-    (U.CONCAT _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType-        $ (ExpectByte :| [ExpectByte]) :|-        [ (ExpectString :| [ExpectString])-        ]     (U.CONCAT _, _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectList (Just ExpectByte) :| [ExpectList (Just ExpectByte)]) :|-        [ (ExpectList (Just ExpectString) :| [ExpectList (Just ExpectString)])+        $ ("string" :| ["string"]) :|+        [ ("bytes" :| ["bytes"])+        , ("list string" :| ["list string"])+        , ("list bytes" :| ["list bytes"])         ]     (U.CONCAT _, SNil) -> notEnoughItemsOnStack @@ -850,8 +1030,8 @@      (U.SLICE _, _ ::& _ ::& _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectNat :| [ExpectNat, ExpectString]) :|-        [ (ExpectNat :| [ExpectNat, ExpectByte])+        $ ("nat" :| ["nat", "string"]) :|+        [ ("nat" :| ["nat", "bytes"])         ]     (U.SLICE _, _) -> notEnoughItemsOnStack @@ -860,7 +1040,7 @@       pure $ inp :/ ISNAT ::: ((starNotes, Dict, vn) ::& rs)      (U.ISNAT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []      (U.ISNAT _, SNil)-> notEnoughItemsOnStack @@ -888,7 +1068,7 @@     (U.ABS vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $       unaryArithImpl @Abs ABS inp vn     (U.ABS _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []      (U.ABS _, SNil) -> notEnoughItemsOnStack @@ -896,10 +1076,19 @@       unaryArithImplAnnotated @Neg NEG inp vn     (U.NEG vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $       unaryArithImpl @Neg NEG inp vn+    (U.NEG vn, (STBls12381Fr, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn+    (U.NEG vn, (STBls12381G1, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn+    (U.NEG vn, (STBls12381G2, _, _, _) ::&+ _) -> workOnInstr uInstr $+      unaryArithImplAnnotated @Neg NEG inp vn     (U.NEG _, _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectInt :| []) :|-        [ (ExpectNat :| [])+        $ ("int" :| []) :|+        [ ("nat" :| [])+        , ("bls12_381_fr" :| [])+        , ("bls12_381_g1" :| [])+        , ("bls12_381_g2" :| [])         ]     (U.NEG _, SNil) -> notEnoughItemsOnStack @@ -907,14 +1096,14 @@                (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $       arithImpl @Lsl LSL inp vn uInstr     (U.LSL _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectNat :| [ExpectNat]) :| []+      failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []     (U.LSL _, _) -> notEnoughItemsOnStack      (U.LSR vn, (STNat, _, _, _) ::&+                (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $       arithImpl @Lsr LSR inp vn uInstr     (U.LSR _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectNat :| [ExpectNat]) :| []+      failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []     (U.LSR _, _) -> notEnoughItemsOnStack      (U.OR vn, (STBool, _, _, _) ::&+@@ -925,8 +1114,8 @@       arithImpl @Or OR inp vn uInstr     (U.OR _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectBool :| [ExpectBool]) :|-        [ (ExpectNat :| [ExpectNat])+        $ ("bool" :| ["bool"]) :|+        [ ("nat" :| ["nat"])         ]     (U.OR _, _) -> notEnoughItemsOnStack @@ -941,9 +1130,9 @@       arithImpl @And AND inp vn uInstr     (U.AND _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectInt :| [ExpectNat]) :|-        [ (ExpectNat :| [ExpectNat])-        , (ExpectBool :| [ExpectBool])+        $ ("int" :| ["nat"]) :|+        [ ("nat" :| ["nat"])+        , ("bool" :| ["bool"])         ]     (U.AND _, _) -> notEnoughItemsOnStack @@ -955,8 +1144,8 @@       arithImpl @Xor XOR inp vn uInstr     (U.XOR _, _ ::& _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectBool :| [ExpectBool]) :|-        [ (ExpectNat :| [ExpectNat])+        $ ("bool" :| ["bool"]) :|+        [ ("nat" :| ["nat"])         ]     (U.XOR _, _) -> notEnoughItemsOnStack @@ -968,9 +1157,9 @@       unaryArithImplAnnotated @Not NOT inp vn     (U.NOT _, _ ::& _) ->       failWithErr $ UnexpectedType-        $ (ExpectNat :| []) :|-        [ (ExpectBool :| [])-        , (ExpectInt :| [])+        $ ("nat" :| []) :|+        [ ("bool" :| [])+        , ("int" :| [])         ]     (U.NOT _, SNil) -> notEnoughItemsOnStack @@ -1000,43 +1189,45 @@     (U.EQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $       unaryArithImpl @Eq' EQ inp vn     (U.EQ _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []     (U.EQ _, SNil) -> notEnoughItemsOnStack      (U.NEQ vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $       unaryArithImpl @Neq NEQ inp vn     (U.NEQ _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []     (U.NEQ _, SNil) -> notEnoughItemsOnStack      (U.LT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $       unaryArithImpl @Lt LT inp vn     (U.LT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []     (U.LT _, SNil) -> notEnoughItemsOnStack      (U.GT vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $       unaryArithImpl @Gt GT inp vn     (U.GT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []     (U.GT _, SNil) -> notEnoughItemsOnStack      (U.LE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $       unaryArithImpl @Le LE inp vn     (U.LE _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []     (U.LE _, SNil) -> notEnoughItemsOnStack      (U.GE vn, (NTInt{}, _, _) ::& _) -> workOnInstr uInstr $       unaryArithImpl @Ge GE inp vn     (U.GE _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectInt :| []) :| []+      failWithErr $ UnexpectedType $ ("int" :| []) :| []     (U.GE _, SNil) -> notEnoughItemsOnStack      (U.INT vn, (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs)+    (U.INT vn, (NTBls12381Fr{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs)     (U.INT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectNat :| []) :| []+      failWithErr $ UnexpectedType $ ("nat" :| []) :| ["bls12_381_fr" :| []]     (U.INT _, SNil) -> notEnoughItemsOnStack      (U.SELF vn fn, _) -> workOnInstr uInstr $ do@@ -1071,7 +1262,7 @@             withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs)      (U.CONTRACT {}, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectAddress :| []) :| []+      failWithErr $ UnexpectedType $ ("address" :| []) :| []     (U.CONTRACT {}, SNil) -> notEnoughItemsOnStack      (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _, _)@@ -1086,7 +1277,7 @@           typeCheckInstrErr' uInstr (SomeHST inp) (Just ContractParameter) m      (U.TRANSFER_TOKENS _, _ ::& _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectTypeVar :| [ExpectMutez, ExpectContract]) :| []+      failWithErr $ UnexpectedType $ ("'p" :| ["mutez", "contract 'p"]) :| []      (U.TRANSFER_TOKENS _, _) -> notEnoughItemsOnStack @@ -1096,7 +1287,7 @@         pure $ inp :/ SET_DELEGATE ::: ((starNotes, Dict, vn) ::& rs)      (U.SET_DELEGATE _,  _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectOption (Just ExpectKeyHash) :| []) :| []+      failWithErr $ UnexpectedType $ ("option key_hash" :| []) :| []      (U.SET_DELEGATE _, _) -> notEnoughItemsOnStack @@ -1119,7 +1310,7 @@           ::: ((starNotes, Dict, ovn) ::& (starNotes, Dict, avn) ::& rs)      (U.CREATE_CONTRACT {}, _ ::& _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectOption Nothing :| [ExpectMutez, ExpectTypeVar]) :| []+      failWithErr $ UnexpectedType $ ("option key_hash" :| ["mutez", "'a"]) :| []      (U.CREATE_CONTRACT {},  _) -> notEnoughItemsOnStack @@ -1127,7 +1318,7 @@       pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, Dict, vn) ::& rs)      (U.IMPLICIT_ACCOUNT _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectKeyHash :| []) :| []+      failWithErr $ UnexpectedType $ ("key_hash" :| []) :| []     (U.IMPLICIT_ACCOUNT _, SNil) -> notEnoughItemsOnStack      (U.NOW vn, _) -> workOnInstr uInstr $@@ -1139,6 +1330,12 @@     (U.BALANCE vn, _) -> workOnInstr uInstr $       pure $ inp :/ BALANCE ::: ((starNotes, Dict, vn) ::& inp) +    (U.VOTING_POWER vn, (NTKeyHash{}, _, _) ::& rs) -> workOnInstr uInstr $+      pure $ inp :/ VOTING_POWER ::: ((starNotes, Dict, vn) ::& rs)++    (U.TOTAL_VOTING_POWER vn, _) -> workOnInstr uInstr $+      pure $ inp :/ TOTAL_VOTING_POWER ::: ((starNotes, Dict, vn) ::& inp)+     (U.CHECK_SIGNATURE vn,                (NTKey _, _, _)                ::& (NTSignature _, _, _) ::& (NTBytes{}, _, _) ::& rs) ->@@ -1146,45 +1343,53 @@         pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, Dict, vn) ::& rs)      (U.CHECK_SIGNATURE _, _ ::& _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectKey :| [ExpectSignature]) :| []+      failWithErr $ UnexpectedType $ ("key" :| ["signature", "bytes"]) :| []     (U.CHECK_SIGNATURE _, _) -> notEnoughItemsOnStack      (U.SHA256 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ SHA256 ::: ((starNotes, Dict, vn) ::& rs)     (U.SHA256 _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectByte :| []) :| []+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []     (U.SHA256 _, SNil) -> notEnoughItemsOnStack      (U.SHA512 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ SHA512 ::: ((starNotes, Dict, vn) ::& rs)     (U.SHA512 _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectByte :| []) :| []+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []     (U.SHA512 _, SNil) -> notEnoughItemsOnStack      (U.BLAKE2B vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ BLAKE2B ::: ((starNotes, Dict, vn) ::& rs)     (U.BLAKE2B _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectByte :| []) :| []+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []     (U.BLAKE2B _, SNil) -> notEnoughItemsOnStack      (U.SHA3 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ SHA3 ::: ((starNotes, Dict, vn) ::& rs)     (U.SHA3 _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectByte :| []) :| []+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []     (U.SHA3 _, SNil) -> notEnoughItemsOnStack      (U.KECCAK vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ KECCAK ::: ((starNotes, Dict, vn) ::& rs)     (U.KECCAK _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectByte :| []) :| []+      failWithErr $ UnexpectedType $ ("bytes" :| []) :| []     (U.KECCAK _, SNil) -> notEnoughItemsOnStack      (U.HASH_KEY vn, (NTKey{}, _, _) ::& rs) -> workOnInstr uInstr $       pure $ inp :/ HASH_KEY ::: ((starNotes, Dict, vn) ::& rs)     (U.HASH_KEY _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectKey :| []) :| []+      failWithErr $ UnexpectedType $ ("key" :| []) :| []     (U.HASH_KEY _, SNil) -> notEnoughItemsOnStack +    (U.PAIRING_CHECK vn, (NTList _ (NTPair _ _ _ _ _ (NTBls12381G1 _)+                                                     (NTBls12381G2 _)), _, _) ::& rs) ->+      workOnInstr uInstr $+        pure $ inp :/ PAIRING_CHECK ::: ((starNotes, Dict, vn) ::& rs)+    (U.PAIRING_CHECK _, _ ::& _) ->+      failWithErr $ UnexpectedType $ ("list (pair bls12_381_g1 bls12_381_g2)" :| []) :| []+    (U.PAIRING_CHECK _, SNil) -> notEnoughItemsOnStack+     (U.SOURCE vn, _) -> workOnInstr uInstr $       pure $ inp :/ SOURCE ::: ((starNotes, Dict, vn) ::& inp) @@ -1195,7 +1400,7 @@       pure $ inp :/ ADDRESS ::: ((starNotes, Dict, vn) ::& rs)      (U.ADDRESS _, _ ::& _) ->-      failWithErr $ UnexpectedType $ (ExpectContract :| []) :| []+      failWithErr $ UnexpectedType $ ("contract 'p" :| []) :| []     (U.ADDRESS _, SNil) -> notEnoughItemsOnStack      (U.CHAIN_ID vn, _) -> workOnInstr uInstr $@@ -1204,7 +1409,12 @@     (U.LEVEL vn, _) -> workOnInstr uInstr $       pure $ inp :/ LEVEL ::: ((starNotes, Dict, vn) ::& inp) +    (U.SELF_ADDRESS vn, _) -> workOnInstr uInstr $+      pure $ inp :/ SELF_ADDRESS ::: ((starNotes, Dict, vn) ::& inp) +    (U.NEVER, (NTNever{}, _, _) ::& _) -> workOnInstr uInstr $+      pure $ inp :/ AnyOutInstr NEVER+     -- Could not get rid of the catch all clause due to this warning:     -- @     -- Pattern match checker exceeded (2000000) iterations in@@ -1212,7 +1422,7 @@     -- to set the maximum number of iterations to n)     -- @     i ->-      error $ "Pattern matches should be exhuastive, but instead got: " <> show i+      error $ "Pattern matches should be exhaustive, but instead got: " <> show i   where     withWTPInstr'       :: forall t inp. SingI t@@ -1225,13 +1435,16 @@     withWTPInstr = withWTPInstr_ @t uInstr (SomeHST inp)      failWithErr :: TCTypeError -> TypeCheckInstrNoExcept (TypeCheckedSeq a)-    failWithErr = workOnInstr uInstr . typeCheckInstrErr' uInstr (SomeHST inp) Nothing+    failWithErr = workOnInstr uInstr . failWithErr' +    failWithErr' :: TCTypeError -> TypeCheckInstr a+    failWithErr' = typeCheckInstrErr' uInstr (SomeHST inp) Nothing+     notEnoughItemsOnStack :: TypeCheckInstrNoExcept (TypeCheckedSeq a)     notEnoughItemsOnStack = failWithErr NotEnoughItemsOnStack      notEnoughItemsOnStack' :: TypeCheckInstr a-    notEnoughItemsOnStack' = typeCheckInstrErr' uInstr (SomeHST inp) Nothing NotEnoughItemsOnStack+    notEnoughItemsOnStack' = failWithErr' NotEnoughItemsOnStack  -- | Helper function for two-branch if where each branch is given a single -- value.@@ -1335,8 +1548,9 @@   -> TypeCheckInstrNoExcept (TypeCheckedSeq ts) lamImpl cons instr is vn ins ons i =   guarding_ instr-    (whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr ->-      typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) $ InvalidInstruction selfInstr) $+    (whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr -> do+      let err = InvalidInstruction selfInstr "SELF instruction cannot be used in a LAMBDA"+      typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) err) $     preserving (tcList is ((ins, Dict, def) ::& SNil)) cons $ \(_ :/ lamI) -> do       let lamNotes onsr = NTLambda def ins onsr       let lamSt onsr = (lamNotes onsr, Dict, vn) ::& i

@@ -266,8 +266,12 @@   STMutez -> Right Dict   STBool -> Right Dict   STKeyHash -> Right Dict+  STBls12381Fr -> Right Dict+  STBls12381G1 -> Right Dict+  STBls12381G2 -> Right Dict   STTimestamp -> Right Dict   STAddress -> Right Dict+  STNever -> Right Dict   where     getWTP_ :: forall t1. SingI t1 => Sing t1 -> Either NotWellTyped (Dict (WellTyped t1))     getWTP_ _ = getWTP @t1@@ -279,7 +283,7 @@   Right Dict -> a   Left e -> fail (pretty e) --- | Similar to @withWTPm@ but is mean to be used within tests.+-- | Similar to @withWTPm@ but is meant to be used within tests. unsafeWithWTP :: forall t a. SingI t => (WellTyped t => a) -> a unsafeWithWTP fn = case getWTP @t of   Right Dict -> fn

@@ -29,6 +29,7 @@ import Tezos.Address (Address(..)) import Tezos.Core import Tezos.Crypto+import qualified Tezos.Crypto.BLS12381 as BLS import Util.Type (onFirst)  tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a@@ -84,6 +85,20 @@         case parseKeyHashRaw (U.unInternalByteString b) of           Right kHash -> pure $ VKeyHash kHash           Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)+      (U.ValueInt i, STBls12381Fr) ->+        pure $ VBls12381Fr (fromIntegral i)+      (v@(U.ValueBytes b), t@STBls12381Fr) ->+        case BLS.fromMichelsonBytes (U.unInternalByteString b) of+          Right val -> pure $ VBls12381Fr val+          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidBls12381Object err)+      (v@(U.ValueBytes b), t@STBls12381G1) ->+        case BLS.fromMichelsonBytes (U.unInternalByteString b) of+          Right val -> pure $ VBls12381G1 val+          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidBls12381Object err)+      (v@(U.ValueBytes b), t@STBls12381G2) ->+        case BLS.fromMichelsonBytes (U.unInternalByteString b) of+          Right val -> pure $ VBls12381G2 val+          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidBls12381Object err)       (v@(U.ValueString s), t@STTimestamp) -> case parseTimestamp $ unMText s of         Just tstamp -> pure $ VTimestamp tstamp         Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)

@@ -21,15 +21,14 @@   , AnnConvergeError(..)   , converge   , convergeAnns+  , convergeDestrAnns   , insertTypeAnn-  , orAnn   , isStar   , starNotes   , notesSing   , notesT   ) where -import Data.Default (Default(..)) import qualified Data.Kind as Kind import Data.Singletons (Sing, SingI(..)) import Fmt (Buildable(..), (+|), (|+))@@ -41,7 +40,7 @@ import Michelson.Typed.Sing import Michelson.Typed.T (T(..)) import Michelson.Untyped.Annotation-  (Annotation, FieldAnn, TypeAnn, fullAnnSet, noAnn, singleAnnSet, unifyAnn)+  (Annotation, FieldAnn, TypeAnn, VarAnn, convergeVarAnns, fullAnnSet, noAnn, singleAnnSet, unifyAnn, unifyPairFieldAnn) import Util.TH import Util.Typeable @@ -61,6 +60,7 @@   NTOperation :: TypeAnn -> Notes 'TOperation   NTContract  :: TypeAnn -> Notes t -> Notes ('TContract t)   NTPair      :: TypeAnn -> FieldAnn -> FieldAnn+              -> VarAnn -> VarAnn               -> Notes p -> Notes q -> Notes ('TPair p q)   NTOr        :: TypeAnn -> FieldAnn -> FieldAnn               -> Notes p -> Notes q -> Notes ('TOr p q)@@ -74,8 +74,12 @@   NTMutez     :: TypeAnn -> Notes 'TMutez   NTBool      :: TypeAnn -> Notes 'TBool   NTKeyHash   :: TypeAnn -> Notes 'TKeyHash+  NTBls12381Fr :: TypeAnn -> Notes 'TBls12381Fr+  NTBls12381G1 :: TypeAnn -> Notes 'TBls12381G1+  NTBls12381G2 :: TypeAnn -> Notes 'TBls12381G2   NTTimestamp :: TypeAnn -> Notes 'TTimestamp   NTAddress   :: TypeAnn -> Notes 'TAddress+  NTNever     :: TypeAnn -> Notes 'TNever  deriving stock instance Eq (Notes t) $(deriveGADTNFData ''Notes)@@ -96,18 +100,22 @@     NTMutez ta              -> "NTMutez" <+> rendT ta     NTBool ta               -> "NTBool" <+> rendT ta     NTKeyHash ta            -> "NTKeyHash" <+> rendT ta+    NTBls12381Fr ta         -> "NTBls12381Fr" <+> rendT ta+    NTBls12381G1 ta         -> "NTBls12381G1" <+> rendT ta+    NTBls12381G2 ta         -> "NTBls12381G2" <+> rendT ta     NTTimestamp ta          -> "NTTimestamp" <+> rendT ta     NTAddress ta            -> "NTAddress" <+> rendT ta     NTKey ta                -> "NTKey" <+> rendT ta     NTUnit ta               -> "NTUnit" <+> rendT ta     NTSignature ta          -> "NTSignature" <+> rendT ta     NTChainId ta            -> "NTChainId" <+> rendT ta+    NTNever ta              -> "NTNever" <+> rendT ta     NTOption ta nt          -> "NTOption" <+> rendT ta <+> rendN nt     NTList ta nt            -> "NTList" <+> rendT ta <+> rendN nt     NTSet ta nt             -> "NTSet" <+> rendT ta <+> rendN nt     NTOperation ta          -> "NTOperation" <+> rendT ta     NTContract ta nt        -> "NTContract" <+> rendT ta <+> rendN nt-    NTPair ta fa1 fa2 np nq -> "NTPair" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq+    NTPair ta fa1 fa2 va1 va2 np nq -> "NTPair" <+> rendTFV2 ta fa1 fa2 va1 va2 <+> rendN np <+> rendN nq     NTOr ta fa1 fa2 np nq   -> "NTOr" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq     NTLambda ta np nq       -> "NTLambda" <+> rendT ta <+> rendN np <+> rendN nq     NTMap ta np nq          -> "NTMap" <+> rendT ta <+> rendN np <+> rendN nq@@ -122,6 +130,9 @@       rendTF2 :: TypeAnn -> FieldAnn -> FieldAnn -> Doc       rendTF2 t f1 f2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] [] +      rendTFV2 :: TypeAnn -> FieldAnn -> FieldAnn -> VarAnn -> VarAnn -> Doc+      rendTFV2 t f1 f2 v1 v2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] [v1, v2]+ -- | Forget information about annotations, pick singleton with the same type. -- -- Note: currently we cannot derive 'Sing' from 'Notes' without 'SingI' because@@ -144,10 +155,14 @@   STMutez -> NTMutez noAnn   STBool -> NTBool noAnn   STKeyHash -> NTKeyHash noAnn+  STBls12381Fr -> NTBls12381Fr noAnn+  STBls12381G1 -> NTBls12381G1 noAnn+  STBls12381G2 -> NTBls12381G2 noAnn   STTimestamp -> NTTimestamp noAnn   STAddress -> NTAddress noAnn   STKey -> NTKey noAnn   STUnit -> NTUnit noAnn+  STNever -> NTNever noAnn   STSignature -> NTSignature noAnn   STChainId -> NTChainId noAnn   STOperation -> NTOperation noAnn@@ -157,7 +172,7 @@   STContract _ -> NTContract noAnn starNotes   STMap _ _ -> NTMap noAnn starNotes starNotes   STBigMap _ _ -> NTBigMap noAnn starNotes starNotes-  STPair _ _ -> NTPair noAnn noAnn noAnn starNotes starNotes+  STPair _ _ -> NTPair noAnn noAnn noAnn noAnn noAnn starNotes starNotes   STOr _ _ -> NTOr noAnn noAnn noAnn starNotes starNotes   STLambda _ _ -> NTLambda noAnn starNotes starNotes @@ -165,9 +180,6 @@ isStar :: SingI t => Notes t -> Bool isStar = (== starNotes) -orAnn :: Annotation t -> Annotation t -> Annotation t-orAnn a b = bool a b (a == def)- -- | Combines two annotations trees `a` and `b` into a new one `c` -- in such a way that `c` can be obtained from both `a` and `b` by replacing -- some empty leaves with type or/and field annotations.@@ -180,10 +192,14 @@   (NTMutez a, NTMutez b) -> NTMutez <$> convergeAnns a b   (NTBool a, NTBool b) -> NTBool <$> convergeAnns a b   (NTKeyHash a, NTKeyHash b) -> NTKeyHash <$> convergeAnns a b+  (NTBls12381Fr a, NTBls12381Fr b) -> NTBls12381Fr <$> convergeAnns a b+  (NTBls12381G1 a, NTBls12381G1 b) -> NTBls12381G1 <$> convergeAnns a b+  (NTBls12381G2 a, NTBls12381G2 b) -> NTBls12381G2 <$> convergeAnns a b   (NTTimestamp a, NTTimestamp b) -> NTTimestamp <$> convergeAnns a b   (NTAddress a, NTAddress b) -> NTAddress <$> convergeAnns a b   (NTKey a, NTKey b) -> NTKey <$> convergeAnns a b   (NTUnit a, NTUnit b) -> NTUnit <$> convergeAnns a b+  (NTNever a, NTNever b) -> NTNever <$> convergeAnns a b   (NTSignature a, NTSignature b) ->     NTSignature <$> convergeAnns a b   (NTChainId a, NTChainId b) ->@@ -198,9 +214,11 @@     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+  (NTPair a pF qF pV qV pN qN, NTPair b pG qG pW qW pM qM) ->+    NTPair <$> convergeAnns a b+           <*> convergeAnns pF pG <*> convergeAnns qF qG+           <*> pure (convergeVarAnns pV pW) <*> pure (convergeVarAnns qV qW)+           <*> converge pN pM <*> converge qN qM   (NTOr a pF qF pN qN, NTOr b pG qG pM qM) ->     NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG          <*> converge pN pM <*> converge qN qM@@ -221,6 +239,9 @@   NTMutez _ -> NTMutez nt   NTBool _ -> NTBool nt   NTKeyHash _ -> NTKeyHash nt+  NTBls12381Fr _ -> NTBls12381Fr nt+  NTBls12381G1 _ -> NTBls12381G1 nt+  NTBls12381G2 _ -> NTBls12381G2 nt   NTTimestamp _ -> NTTimestamp nt   NTAddress _ -> NTAddress nt   NTKey _ -> NTKey nt@@ -231,12 +252,13 @@   NTSet _ n1 -> NTSet nt n1   NTOperation _ -> NTOperation nt   NTContract _ n1 -> NTContract nt n1-  NTPair _ n1 n2 n3 n4 -> NTPair nt n1 n2 n3 n4+  NTPair _ n1 n2 n3 n4 n5 n6 -> NTPair nt n1 n2 n3 n4 n5 n6   NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4   NTLambda _ n1 n2 -> NTLambda nt n1 n2   NTMap _ n1 n2 -> NTMap nt n1 n2   NTBigMap _ n1 n2 -> NTBigMap nt n1 n2   NTChainId _ -> NTChainId nt+  NTNever _ -> NTNever nt  data AnnConvergeError where   AnnConvergeError@@ -254,12 +276,23 @@   build (AnnConvergeError ann1 ann2) =     "Annotations do not converge: " +| ann1 |+ " /= " +| ann2 |+ "" +convergeAnnsImpl+  :: forall (tag :: Kind.Type).+     (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)+  => (Annotation tag -> Annotation tag -> Maybe (Annotation tag))+  -> Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)+convergeAnnsImpl unify a b = maybe (Left $ AnnConvergeError a b) pure $ unify a b+ -- | Converge two type or field notes (which may be wildcards). convergeAnns   :: forall (tag :: Kind.Type).      (Buildable (Annotation tag), Show (Annotation tag), Typeable tag)   => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)-convergeAnns a b = maybe (Left $ AnnConvergeError a b)-                          pure $ unifyAnn a b+convergeAnns = convergeAnnsImpl unifyAnn++-- | Converge two field notes in CAR or CDR, given that one of them may be a+-- special annotation.+convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn+convergeDestrAnns = convergeAnnsImpl unifyPairFieldAnn  $(deriveGADTNFData ''AnnConvergeError)

@@ -8,6 +8,7 @@ module Michelson.Typed.Arith   ( ArithOp (..)   , UnaryArithOp (..)+  , ToIntArithOp (..)   , ArithError (..)   , ShiftArithErrorType (..)   , MutezArithErrorType (..)@@ -30,24 +31,30 @@   , Le   , Ge   , compareOp++  -- * Misc+  , Bls12381MulBadOrder   ) where  import Data.Bits (complement, shift, (.&.), (.|.)) import Data.Constraint (Dict(..))-import Data.Singletons (Sing, SingI(..)) import Fmt (Buildable(build))  import Michelson.Typed.Annotation (AnnConvergeError, Notes(..), converge, convergeAnns, starNotes)-import Michelson.Typed.Sing (SingT(..)) import Michelson.Typed.T (T(..))-import Michelson.Typed.Value (Comparability(..), Comparable, Value'(..), checkComparability)+import Michelson.Typed.Value (Comparable, Value'(..)) import Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds)+import qualified Tezos.Crypto.BLS12381 as BLS+import Util.TypeLits  -- | Class for binary arithmetic operation. -- -- Takes binary operation marker as @op@ parameter, -- types of left operand @n@ and right operand @m@.-class ArithOp aop (n :: T) (m :: T) where+--+-- 'Typeable' constraints in superclass are necessary for error messages.+class (Typeable n, Typeable m) =>+      ArithOp aop (n :: T) (m :: T) where    -- | Type family @ArithRes@ denotes the type resulting from   -- computing operation @op@ from operands of types @n@ and @m@.@@ -105,11 +112,15 @@  instance (NFData n, NFData m) => NFData (ArithError n m) --- | Marker data type for add operation.+-- | Class for unary arithmetic operation. class UnaryArithOp aop (n :: T) where   type UnaryArithRes aop n :: T   evalUnaryArithOp :: proxy aop -> Value' instr n -> Value' instr (UnaryArithRes aop n) +-- | Class for conversions to an integer value.+class ToIntArithOp (n :: T) where+  evalToIntOp :: Value' instr n -> Value' instr 'TInt+ data Add data Sub data Mul@@ -131,6 +142,10 @@ data Le data Ge +-- For implementation hints see the reference implementation:+-- (note that you may need to change the branch)+-- https://gitlab.com/metastatedev/tezos/blob/master/src/proto_alpha/lib_protocol/script_ir_translator.ml#L4601+ instance ArithOp Add 'TNat 'TInt where   type ArithRes Add 'TNat 'TInt = 'TInt   convergeArith _ _ n2 = Right n2@@ -170,6 +185,24 @@     where       res = maybe (Left $ MutezArithError AddOverflow n m) (Right . VMutez) $ i `addMutez` j   commutativityProof = Just Dict+instance ArithOp Add 'TBls12381Fr 'TBls12381Fr where+  type ArithRes Add 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBls12381Fr i) (VBls12381Fr j) =+    Right $ VBls12381Fr (BLS.add i j)+  commutativityProof = Just Dict+instance ArithOp Add 'TBls12381G1 'TBls12381G1 where+  type ArithRes Add 'TBls12381G1 'TBls12381G1 = 'TBls12381G1+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBls12381G1 i) (VBls12381G1 j) =+    Right $ VBls12381G1 (BLS.add i j)+  commutativityProof = Just Dict+instance ArithOp Add 'TBls12381G2 'TBls12381G2 where+  type ArithRes Add 'TBls12381G2 'TBls12381G2 = 'TBls12381G2+  convergeArith _ n1 n2 = converge n1 n2+  evalOp _ (VBls12381G2 i) (VBls12381G2 j) =+    Right $ VBls12381G2 (BLS.add i j)+  commutativityProof = Just Dict  instance ArithOp Sub 'TNat 'TInt where   type ArithRes Sub 'TNat 'TInt = 'TInt@@ -239,7 +272,61 @@     where       res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ i `mulMutez` j   commutativityProof = Just Dict+instance ArithOp Mul 'TInt 'TBls12381Fr where+  type ArithRes Mul 'TInt 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ (NTInt n1) _ = Right $ (NTBls12381Fr n1)+  evalOp _ (VInt i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegral i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TNat 'TBls12381Fr where+  type ArithRes Mul 'TNat 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ (NTNat n1) _ = Right (NTBls12381Fr n1)+  evalOp _ (VNat i) (VBls12381Fr j) = Right $ VBls12381Fr (fromIntegral i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381Fr 'TInt where+  type ArithRes Mul 'TBls12381Fr 'TInt = 'TBls12381Fr+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381Fr i) (VInt j) = Right $ VBls12381Fr (i * fromIntegral j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381Fr 'TNat where+  type ArithRes Mul 'TBls12381Fr 'TNat = 'TBls12381Fr+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381Fr i) (VNat j) = Right $ VBls12381Fr (i * fromIntegral j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381Fr 'TBls12381Fr where+  type ArithRes Mul 'TBls12381Fr 'TBls12381Fr = 'TBls12381Fr+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381Fr i) (VBls12381Fr j) = Right $ VBls12381Fr (i * j)+  commutativityProof = Just Dict+instance ArithOp Mul 'TBls12381G1 'TBls12381Fr where+  type ArithRes Mul 'TBls12381G1 'TBls12381Fr = 'TBls12381G1+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381G1 i) (VBls12381Fr j) = Right $ VBls12381G1 (BLS.multiply j i)+  commutativityProof = Nothing+instance ArithOp Mul 'TBls12381G2 'TBls12381Fr where+  type ArithRes Mul 'TBls12381G2 'TBls12381Fr = 'TBls12381G2+  convergeArith _ n1 _ = Right n1+  evalOp _ (VBls12381G2 i) (VBls12381Fr j) = Right $ VBls12381G2 (BLS.multiply j i)+  commutativityProof = Nothing+instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G1 =>+         ArithOp Mul 'TBls12381Fr 'TBls12381G1 where+  type ArithRes Mul 'TBls12381Fr 'TBls12381G1 = 'TBls12381G1+  convergeArith = error "impossible"+  evalOp = error "impossible"+  commutativityProof = error "impossible"+instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G2 =>+         ArithOp Mul 'TBls12381Fr 'TBls12381G2 where+  type ArithRes Mul 'TBls12381Fr 'TBls12381G2 = 'TBls12381G2+  convergeArith = error "impossible"+  evalOp = error "impossible"+  commutativityProof = error "impossible" +type family Bls12381MulBadOrder a1 a2 where+  Bls12381MulBadOrder a1 a2 = TypeError+    ('Text "Multiplication of "+       ':<>: 'ShowType a2 ':<>: 'Text " and "+       ':<>: 'ShowType a1 ':<>: 'Text " works only other way around"+    )+ instance UnaryArithOp Abs 'TInt where   type UnaryArithRes Abs 'TInt = 'TNat   evalUnaryArithOp _ (VInt i) = VNat (fromInteger $ abs i)@@ -250,6 +337,15 @@ instance UnaryArithOp Neg 'TNat where   type UnaryArithRes Neg 'TNat = 'TInt   evalUnaryArithOp _ (VNat i) = VInt (- fromIntegral i)+instance UnaryArithOp Neg 'TBls12381Fr where+  type UnaryArithRes Neg 'TBls12381Fr = 'TBls12381Fr+  evalUnaryArithOp _ (VBls12381Fr i) = VBls12381Fr (BLS.negate i)+instance UnaryArithOp Neg 'TBls12381G1 where+  type UnaryArithRes Neg 'TBls12381G1 = 'TBls12381G1+  evalUnaryArithOp _ (VBls12381G1 i) = VBls12381G1 (BLS.negate i)+instance UnaryArithOp Neg 'TBls12381G2 where+  type UnaryArithRes Neg 'TBls12381G2 = 'TBls12381G2+  evalUnaryArithOp _ (VBls12381G2 i) = VBls12381G2 (BLS.negate i)  instance ArithOp Or 'TNat 'TNat where   type ArithRes Or 'TNat 'TNat = 'TNat@@ -314,24 +410,15 @@   type UnaryArithRes Not 'TBool = 'TBool   evalUnaryArithOp _ (VBool i) = VBool (not i) -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-  (STInt, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STNat, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STString, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STBytes, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STMutez, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STBool, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STKeyHash, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STTimestamp, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STAddress, i, j) -> toInteger $ fromEnum (compare i j) - 1-  (STPair l m, VPair (a, b), VPair (c, d)) ->-    case checkComparability l of-      CanBeCompared ->-        case compareOp a c of-          0  -> case checkComparability m of-            CanBeCompared -> compareOp b d-          r' -> r'+-- | Implementation for 'COMPARE' instruction.+compareOp :: Comparable t => Value' i t -> Value' i t -> Integer+compareOp a b =+  -- If at some point we need to return a number outside of [-1; 1] range,+  -- let's extend 'tcompare' respectively and use it here.+  -- Such situation seems unlikely to happen though, our previous communication+  -- with the Tezos developers shows that even if in Tezos 'COMPARE' returns+  -- something unusual, that is probably a bug.+  toInteger $ fromEnum (compare a b) - 1  instance UnaryArithOp Eq' 'TInt where   type UnaryArithRes Eq' 'TInt = 'TBool@@ -358,6 +445,11 @@   type UnaryArithRes Ge 'TInt = 'TBool   evalUnaryArithOp _ (VInt i) = VBool (i >= 0) +instance ToIntArithOp 'TNat where+  evalToIntOp (VNat i) = VInt (toInteger i)++instance ToIntArithOp 'TBls12381Fr where+  evalToIntOp (VBls12381Fr i) = VInt (toInteger i)  instance Buildable ShiftArithErrorType where   build = \case

@@ -9,10 +9,11 @@   , convertContractCode   , convertContract   , instrToOps+  , untypeDemoteT   , untypeValue    -- Helper for generating documentation-  , sampleValueFromUntype+  , sampleTypedValue    -- * Misc   , flattenEntrypoints@@ -20,7 +21,6 @@  import Data.Constraint (Dict(..)) import qualified Data.Map as Map-import qualified Data.Set as Set import Data.Singletons (Sing, demote) import Fmt (Buildable(..), fmt, listF, pretty) @@ -28,15 +28,16 @@ import Michelson.Typed.Aliases import Michelson.Typed.Annotation (Notes(..)) import Michelson.Typed.Entrypoints-import Michelson.Typed.Extract (fromUType, mkUType, toUType)+import Michelson.Typed.Extract (mkUType, toUType) import Michelson.Typed.Instr as Instr import Michelson.Typed.Scope-import Michelson.Typed.Sing (SingT(..), withSomeSingT)+import Michelson.Typed.Sing (SingT(..)) import Michelson.Typed.T (T(..)) import Michelson.Typed.Value import qualified Michelson.Untyped as U import Tezos.Core (mformatChainId, parseChainId, timestampFromSeconds, unMutez, unsafeMkMutez) import Tezos.Crypto+import qualified Tezos.Crypto.BLS12381 as BLS import Util.Peano import Util.Typeable @@ -83,9 +84,14 @@   (VBool True, _) -> U.ValueTrue   (VBool False, _) -> U.ValueFalse   (VKeyHash h, _) -> U.ValueString $ mformatKeyHash h+  -- Here we intentionally diverge from the reference implementation.+  -- Tezos prints bls12_381_fr as bytes, but printing a number is more convenient+  -- (numbers are shorter, and Tezos can parse numbers to bls12_381_fr)+  (VBls12381Fr v, _) -> U.ValueInt $ toInteger v+  (VBls12381G1 v, _) -> U.ValueBytes $ U.InternalByteString $ BLS.toMichelsonBytes v+  (VBls12381G2 v, _) -> U.ValueBytes $ U.InternalByteString $ BLS.toMichelsonBytes v   (VTimestamp t, _) -> U.ValueString $ mkMTextUnsafe $ pretty t   (VAddress a, _) -> U.ValueString $ mformatEpAddress a-   (VKey b, _) ->     U.ValueString $ mformatPublicKey b   (VUnit, _) ->@@ -149,6 +155,7 @@   -- TODO [#283] After representation of locations is polished,   -- this place should be updated to pass it from typed to untyped ASTs.   WithLoc _ i -> instrToOps i+  InstrWithVarAnns _ i -> instrToOps i   InstrWithNotes n i -> case i of     Nop -> instrToOps i     Seq _ _ -> instrToOps i@@ -161,7 +168,9 @@     -- annotations to and delegate it's conversion to this function itself.     -- If none of the above, convert a single instruction and copy annotations     -- to it.+    InstrWithVarNotes n0 (InstrWithVarAnns _ i0) -> instrToOps $ InstrWithNotes n $ InstrWithVarNotes n0 i0     InstrWithVarNotes n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n n0]+    InstrWithVarAnns _ _ -> instrToOps i     _ -> [U.PrimEx $ handleInstrAnnotate i n]   InstrWithVarNotes n i -> case i of     Nop -> instrToOps i@@ -170,8 +179,10 @@     DocGroup _ _ -> instrToOps i     Ext _ -> instrToOps i     WithLoc _ i0 -> instrToOps (InstrWithVarNotes n i0)+    InstrWithNotes n0 (InstrWithVarAnns _ i0) -> instrToOps $ InstrWithNotes n0 $ InstrWithVarNotes n i0     InstrWithNotes n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n0 n]     InstrWithVarNotes _ _ -> instrToOps i+    InstrWithVarAnns _ i0 -> instrToOps $ InstrWithVarNotes n i0     _ -> [U.PrimEx $ handleInstrVarNotes i n]   i -> [U.PrimEx $ handleInstr i]   where@@ -200,6 +211,7 @@         (STOption _, U.NONE _ va _, NTOption ta nt) -> U.NONE ta va (mkUType nt)         (_, U.UNIT _ va, NTUnit ta) -> U.UNIT ta va         (_, U.PAIR ta va f1 f2, _) -> U.PAIR ta va f1 f2+        (_, U.PAIRN va n, _) -> U.PAIRN va n         (_, U.CAR va f1, _) -> U.CAR va f1         (_, U.CDR va f1, _) -> U.CDR va f1         (STOr _ _, U.LEFT _ va _ _ _, NTOr ta f1 f2 _ n2) ->@@ -226,6 +238,7 @@         (_, a@(U.DROP), _) -> a         (_, a@(U.DROPN _), _) -> a         (_, a@(U.DUP _), _) -> a+        (_, a@(U.DUPN _ _), _) -> a         (_, a@(U.SWAP), _) -> a         (_, a@(U.DIG {}), _) -> a         (_, a@(U.DUG {}), _) -> a@@ -238,7 +251,9 @@         (_, a@(U.ITER _), _) -> a         (_, a@(U.MEM _), _) -> a         (_, a@(U.GET _), _) -> a+        (_, a@(U.GETN _ _), _) -> a         (_, a@(U.UPDATE _), _) -> a+        (_, a@(U.UPDATEN _ _), _) -> a         (_, a@(U.IF _ _), _) -> a         (_, a@(U.LOOP _), _) -> a         (_, a@(U.LOOP_LEFT _), _) -> a@@ -280,6 +295,8 @@         (_, a@(U.LEVEL _), _) -> a         (_, a@(U.AMOUNT _), _) -> a         (_, a@(U.BALANCE _), _) -> a+        (_, a@(U.VOTING_POWER _), _) -> a+        (_, a@(U.TOTAL_VOTING_POWER _), _) -> a         (_, a@(U.CHECK_SIGNATURE _), _) -> a         (_, a@(U.SHA256 _), _) -> a         (_, a@(U.SHA512 _), _) -> a@@ -290,6 +307,8 @@         (_, a@(U.SOURCE _), _) -> a         (_, a@(U.SENDER _), _) -> a         (_, a@(U.ADDRESS _), _) -> a+        (_, a@(U.SELF_ADDRESS _), _) -> a+        (_, a@(U.NEVER), _) -> a         (_, b, c) -> error $ "addInstrNote: Unexpected instruction/annotation combination: " <> show (b, c)      handleInstrVarNotes :: forall inp' out' . HasCallStack@@ -307,11 +326,13 @@           "addVarNotes: Cannot add two var annotations to instr: " <> show ins       va :| [] -> case ins of         U.DUP _ -> U.DUP va+        U.DUPN _ s -> U.DUPN va s         U.PUSH _ t v -> U.PUSH va t v         U.SOME ta _ -> U.SOME ta va         U.NONE ta _ t -> U.NONE ta va t         U.UNIT ta _ -> U.UNIT ta va         U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2+        U.PAIRN _ n -> U.PAIRN va n         U.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@@ -325,7 +346,9 @@         U.MAP _ ops -> U.MAP va ops         U.MEM _ -> U.MEM va         U.GET _ -> U.GET va+        U.GETN _ n -> U.GETN va n         U.UPDATE _ -> U.UPDATE va+        U.UPDATEN _ n -> U.UPDATEN va n         U.LAMBDA _ t1 t2 ops -> U.LAMBDA va t1 t2 ops         U.EXEC _ -> U.EXEC va         U.APPLY _ -> U.APPLY va@@ -365,6 +388,8 @@         U.NOW _ -> U.NOW va         U.AMOUNT _ -> U.AMOUNT va         U.BALANCE _ -> U.BALANCE va+        U.VOTING_POWER _ -> U.VOTING_POWER va+        U.TOTAL_VOTING_POWER _ -> U.TOTAL_VOTING_POWER va         U.CHECK_SIGNATURE _ -> U.CHECK_SIGNATURE va         U.SHA256 _ -> U.SHA256 va         U.SHA512 _ -> U.SHA512 va@@ -377,6 +402,7 @@         U.ADDRESS _ -> U.ADDRESS va         U.CHAIN_ID _ -> U.CHAIN_ID va         U.LEVEL _ -> U.LEVEL va+        U.SELF_ADDRESS _ -> U.SELF_ADDRESS va         _ -> error $           "addVarNotes: Cannot add single var annotation to instr: " <> (show ins) <> " with " <> show va       _ -> error $@@ -387,6 +413,7 @@       (WithLoc _ _) -> error "impossible"       (InstrWithNotes _ _) -> error "impossible"       (InstrWithVarNotes _ _) -> error "impossible"+      (InstrWithVarAnns _ _) -> error "impossible"       (FrameInstr _ _) -> error "impossible"       (Seq _ _) -> error "impossible"       Nop -> error "impossible"@@ -396,6 +423,7 @@       DROP -> U.DROP       (DROPN s) -> U.DROPN (fromIntegral $ peanoValSing s)       DUP -> U.DUP U.noAnn+      (DUPN s) -> U.DUPN U.noAnn (fromIntegral $ peanoValSing s)       SWAP -> U.SWAP       (DIG s) -> U.DIG (fromIntegral $ peanoValSing s)       (DUG s) -> U.DUG (fromIntegral $ peanoValSing s)@@ -408,6 +436,8 @@       UNIT -> U.UNIT U.noAnn U.noAnn       (IF_NONE i1 i2) -> U.IF_NONE (instrToOps i1) (instrToOps i2)       AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2+      PAIRN n -> U.PAIRN U.noAnn (fromIntegral $ peanoValSing n)+      UNPAIRN n -> U.UNPAIRN (fromIntegral $ peanoValSing n)       (AnnCAR fn) -> U.CAR U.noAnn fn       (AnnCDR fn) -> U.CDR U.noAnn fn       i@LEFT | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->@@ -432,7 +462,9 @@       (ITER op) -> U.ITER $ instrToOps op       MEM -> U.MEM U.noAnn       GET -> U.GET U.noAnn+      GETN n -> U.GETN U.noAnn (fromIntegral $ peanoValSing n)       UPDATE -> U.UPDATE U.noAnn+      UPDATEN n -> U.UPDATEN U.noAnn (fromIntegral $ peanoValSing n)       (IF op1 op2) -> U.IF (instrToOps op1) (instrToOps op2)       (LOOP op) -> U.LOOP (instrToOps op)       (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOps op)@@ -495,6 +527,8 @@       NOW -> U.NOW U.noAnn       AMOUNT -> U.AMOUNT U.noAnn       BALANCE -> U.BALANCE U.noAnn+      VOTING_POWER -> U.VOTING_POWER U.noAnn+      TOTAL_VOTING_POWER -> U.TOTAL_VOTING_POWER U.noAnn       CHECK_SIGNATURE -> U.CHECK_SIGNATURE U.noAnn       SHA256 -> U.SHA256 U.noAnn       SHA512 -> U.SHA512 U.noAnn@@ -502,11 +536,14 @@       SHA3 -> U.SHA3 U.noAnn       KECCAK -> U.KECCAK U.noAnn       HASH_KEY -> U.HASH_KEY U.noAnn+      PAIRING_CHECK -> U.PAIRING_CHECK U.noAnn       SOURCE -> U.SOURCE U.noAnn       SENDER -> U.SENDER U.noAnn       ADDRESS -> U.ADDRESS U.noAnn       CHAIN_ID -> U.CHAIN_ID U.noAnn       LEVEL -> U.LEVEL U.noAnn+      SELF_ADDRESS -> U.SELF_ADDRESS U.noAnn+      NEVER -> U.NEVER  untypeStackRef :: StackRef s -> U.StackRef untypeStackRef (StackRef n) = U.StackRef (peanoVal n)@@ -551,81 +588,68 @@ instance (SingI t, HasNoOp t) => Buildable (Value' Instr t) where   build = build . untypeValue --- | Get 'sampleTypedValue' from untyped value.+-- | Generate a value used for generating examples in documentation. ----- Throw error if @U.Type@ contains @TOperation@.-sampleValueFromUntype :: HasCallStack => U.Type -> U.Value' U.ExpandedOp-sampleValueFromUntype ty = withSomeSingT (fromUType ty) $ \(_ :: Sing t) ->-  case checkScope @(ParameterScope t) of-    Left bt -> error $ "Scope error: " <> pretty bt-    Right Dict -> untypeValue $ sampleTypedValue @t---- | Sample values used for generating examples of entrypoint parameter in documentation.-sampleTypedValue :: forall t. (HasCallStack, ParameterScope t) => Value t-sampleTypedValue = case sing @t of-    STInt              -> VInt -1-    STNat              -> VNat 0-    STString           -> VString [mt|hello|]-    STMutez            -> VMutez (unsafeMkMutez 100)-    STBool             -> VBool True-    STKey              -> VKey samplePublicKey-    STKeyHash          -> VKeyHash $ hashKey samplePublicKey-    STTimestamp        -> VTimestamp $ timestampFromSeconds 1564142952-    STBytes            -> VBytes "\10"-    STAddress          -> VAddress $ sampleAddress-    STUnit             -> VUnit-    STSignature        -> VSignature $ sampleSignature-    STChainId          -> VChainId sampleChainId-    STOption (_ :: Sing t2) -> VOption $ Just $ sampleTypedValue @t2-    STList (_ :: Sing t2) -> VList [sampleTypedValue @t2]-    STSet (s2 :: Sing t2) ->-      case ( checkComparability s2-           , checkNestedBigMapsPresence s2-           ) of-        (CanBeCompared, NestedBigMapsAbsent) ->-          VSet $ Set.fromList [sampleTypedValue @t2]-        _ -> error $ "Error generating sample value: scope error"-    STContract _ ->-      VContract (eaAddress sampleAddress) $ SomeEpc epcCallRootUnsafe-    STPair (s2 :: Sing t2) (s3 :: Sing t3) ->-      case ( checkOpPresence s2-           , checkNestedBigMapsPresence s2-           , checkOpPresence s3-           , checkNestedBigMapsPresence s3-           ) of-        (OpAbsent, NestedBigMapsAbsent, OpAbsent, NestedBigMapsAbsent) ->-          VPair (sampleTypedValue @t2, sampleTypedValue @t3)-    STOr (s2 :: Sing t2) _ ->-      case (checkNestedBigMapsPresence s2, checkOpPresence s2) of-        (NestedBigMapsAbsent, OpAbsent) ->-          VOr $ Left $ sampleTypedValue @t2-    STMap (s2 :: Sing t2) (s3 :: Sing t3) ->-      case ( checkNestedBigMapsPresence s2-           , checkComparability s2-           , checkOpPresence s2-           , checkNestedBigMapsPresence s3-           ) of-        (NestedBigMapsAbsent, CanBeCompared, OpAbsent, NestedBigMapsAbsent) ->-            VMap $ Map.fromList [(sampleTypedValue @t2, sampleTypedValue @t3)]-        _ -> error $ "Error generating sample value: scope error"-    STBigMap (s2 :: Sing t2) (s3 :: Sing t3) ->-      case ( checkNestedBigMapsPresence s2-           , checkComparability s2-           , checkOpPresence s2-           , checkNestedBigMapsPresence s3-           ) of-        (NestedBigMapsAbsent, CanBeCompared, OpAbsent, NestedBigMapsAbsent) ->-            VBigMap $ Map.fromList [(sampleTypedValue @t2, sampleTypedValue @t3)]-        _ -> error $ "Error generating sample value: scope error"-    STLambda (_ :: Sing t2) (s3 :: Sing t3) ->-      case ( checkNestedBigMapsPresence s3-           , checkBigMapPresence s3-           , checkContractTypePresence s3-           , checkOpPresence s3-           ) of-        (NestedBigMapsAbsent, BigMapAbsent, ContractAbsent, OpAbsent) ->-          VLam $ RfNormal (DROP `Seq` PUSH (sampleTypedValue @t3))-        _ -> VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)+-- Since not for all types it is possible to produce a sensible example,+-- the result is optional. E.g. for operations, @never@, not proper+-- types like @contract operation@ we return 'Nothing'.+sampleTypedValue :: Sing t -> Maybe (Value t)+sampleTypedValue = \case+    STInt              -> Just $ VInt -1+    STNat              -> Just $ VNat 0+    STString           -> Just $ VString [mt|hello|]+    STMutez            -> Just $ VMutez (unsafeMkMutez 100)+    STBool             -> Just $ VBool True+    STKey              -> Just $ VKey samplePublicKey+    STKeyHash          -> Just $ VKeyHash $ hashKey samplePublicKey+    STBls12381Fr       -> Just $ VBls12381Fr 1+    STBls12381G1       -> Just $ VBls12381G1 BLS.g1One+    STBls12381G2       -> Just $ VBls12381G2 BLS.g2One+    STTimestamp        -> Just $ VTimestamp $ timestampFromSeconds 1564142952+    STBytes            -> Just $ VBytes "\10"+    STAddress          -> Just $ VAddress $ sampleAddress+    STUnit             -> Just $ VUnit+    STSignature        -> Just $ VSignature $ sampleSignature+    STChainId          -> Just $ VChainId sampleChainId+    STOperation        -> Nothing+    STNever            -> Nothing+    STOption t ->+      VOption . Just <$> sampleTypedValue t+    STList t ->+      VList . one <$> sampleTypedValue t+    STSet t -> do+      Dict <- comparabilityPresence t+      VSet . one <$> sampleTypedValue t+    STContract t -> do+      Dict <- opAbsense t+      Dict <- nestedBigMapsAbsense t+      pure . VContract (eaAddress sampleAddress) $ SomeEpc epcCallRootUnsafe+    STPair t1 t2 -> do+      val1 <- sampleTypedValue t1+      val2 <- sampleTypedValue t2+      pure $ VPair (val1, val2)+    STOr tl tr -> asum+      [ VOr . Left <$> sampleTypedValue tl+      , VOr . Right <$> sampleTypedValue tr+      ]+    STMap t1 t2 -> do+      val1 <- sampleTypedValue t1+      val2 <- sampleTypedValue t2+      case checkComparability t1 of+        CanBeCompared -> pure $ VMap $ Map.fromList [(val1, val2)]+        CannotBeCompared -> Nothing+    STBigMap t1 t2 -> do+      val1 <- sampleTypedValue t1+      val2 <- sampleTypedValue t2+      case checkComparability t1 of+        CanBeCompared -> pure $ VBigMap $ Map.fromList [(val1, val2)]+        CannotBeCompared -> Nothing+    STLambda _ (t2 :: Sing t2) ->+      case checkScope @(ConstantScope t2) of+        Right Dict -> do+          val <- sampleTypedValue t2+          pure $ VLam $ RfNormal (DROP `Seq` PUSH val)+        _ -> pure $ VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)     where       sampleAddress =  unsafeParseEpAddress "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"       samplePublicKey = fromRight (error "impossible") $ parsePublicKey

@@ -40,6 +40,9 @@   (STMutez, NTMutez tn)           -> Un.Type Un.TMutez tn   (STBool, NTBool tn)             -> Un.Type Un.TBool tn   (STKeyHash, NTKeyHash tn)       -> Un.Type Un.TKeyHash tn+  (STBls12381Fr, NTBls12381Fr tn) -> Un.Type Un.TBls12381Fr tn+  (STBls12381G1, NTBls12381G1 tn) -> Un.Type Un.TBls12381G1 tn+  (STBls12381G2, NTBls12381G2 tn) -> Un.Type Un.TBls12381G2 tn   (STTimestamp, NTTimestamp tn)   -> Un.Type Un.TTimestamp tn   (STAddress, NTAddress tn)       -> Un.Type Un.TAddress tn   (STKey, NTKey tn)               -> Un.Type Un.TKey tn@@ -50,10 +53,11 @@   (STList _, NTList tn n)         -> Un.Type (Un.TList (mkUType n)) tn   (STSet _, NTSet tn n)           -> Un.Type (Un.TSet (mkUType n)) tn   (STOperation, NTOperation tn)   -> Un.Type Un.TOperation tn+  (STNever, NTNever tn)           -> Un.Type Un.TNever tn   (STContract _, NTContract tn n) ->     Un.Type (Un.TContract (mkUType n)) tn-  (STPair _ _, NTPair tn fl fr nl nr) ->-    Un.Type (Un.TPair fl fr (mkUType nl) (mkUType nr)) tn+  (STPair _ _, NTPair tn fl fr vl vr nl nr) ->+    Un.Type (Un.TPair fl fr vl vr (mkUType nl) (mkUType nr)) tn   (STOr _ _, NTOr tn fl fr nl nr) ->     Un.Type (Un.TOr fl fr (mkUType nl) (mkUType nr)) tn   (STLambda _ _, NTLambda tn np nq) ->@@ -91,6 +95,15 @@   Un.TKeyHash ->     cont (NTKeyHash tn) +  Un.TBls12381Fr ->+    cont (NTBls12381Fr tn)++  Un.TBls12381G1 ->+    cont (NTBls12381G1 tn)++  Un.TBls12381G2 ->+    cont (NTBls12381G2 tn)+   Un.TTimestamp ->     cont (NTTimestamp tn) @@ -109,6 +122,9 @@   Un.TChainId ->     cont (NTChainId tn) +  Un.TNever ->+    cont (NTNever tn)+   Un.TOption internalT -> withUType internalT $     \(notesInternalT :: Notes internalT) ->       cont (NTOption tn notesInternalT)@@ -128,10 +144,10 @@     \(notesContractT :: Notes contractT) ->       cont (NTContract tn notesContractT) -  Un.TPair la ra lt rt ->+  Un.TPair la ra lv rv lt rt ->     withUType lt $ \ln ->       withUType rt $ \rn ->-        cont (NTPair tn la ra ln rn)+        cont (NTPair tn la ra lv rv ln rn)    Un.TOr la ra lt rt ->     withUType lt $ \ln ->

@@ -48,7 +48,7 @@   , applyWithinParens   ) where -import Control.Lens (each, to, _Just)+import Control.Lens (_Just, each, to) import Data.Char (isLower, isUpper, toLower) import qualified Data.Kind as Kind import Data.List (lookup)@@ -84,7 +84,7 @@ -- each field of the datatype, e.g. information about field type. -- -- This representation also includes descriptions of constructors and fields.-type ADTRep a = NonEmpty (ConstructorRep a)+type ADTRep a = [ConstructorRep a]  -- | Representation of a constructor with an optional description. data ConstructorRep a = ConstructorRep@@ -106,7 +106,8 @@ -- | Show given 'ADTRep' in a neat way. buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown buildADTRep buildField = \case-  ctor@ConstructorRep{..} :| [] -> renderProduct (WithinParens False) ctor crFields+  [] -> mdItalic "no values"+  [ctor@ConstructorRep{..}] -> renderProduct (WithinParens False) ctor crFields   ps -> (mappend (mdItalic "one of" <> " \n")) $         foldMap         (toListItem . renderNamedProduct (WithinParens True)) (toList ps)@@ -622,9 +623,8 @@     where       conName = toText $ symbolVal (Proxy @ctor) -instance TypeError ('Text "Cannot derive documentation for void-like type") =>-    GTypeHasDoc G.V1 where-  gTypeDocHaskellRep = error "impossible"+instance GTypeHasDoc G.V1 where+  gTypeDocHaskellRep _ = []  -- | Product type traversal for 'TypeHasDoc'. class GProductHasDoc (x :: Kind.Type -> Kind.Type) where

@@ -59,7 +59,7 @@ import Michelson.Typed.T import Michelson.Typed.Value import Tezos.Address (Address)-import Tezos.Core (Mutez, Timestamp, ChainId)+import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, PublicKey, Signature) import Util.Label (Label) import Util.Type

@@ -37,7 +37,7 @@   , totsAppendLemma   ) where -import Data.Constraint ((:-)(..), Dict(..))+import Data.Constraint (Dict(..), (:-)(..)) import Data.Default (Default(..)) import qualified Data.Kind as Kind import qualified Data.Map.Strict as Map@@ -56,7 +56,7 @@ import Michelson.Typed.Value import Tezos.Address (Address) import Tezos.Core (ChainId, Mutez, Timestamp)-import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature) import Util.Type  ----------------------------------------------------------------------------@@ -103,6 +103,11 @@ -- Instances ---------------------------------------------------------------------------- +instance WellTyped t => IsoValue (Value t) where+  type ToT (Value t) = t+  toVal = id+  fromVal = id+ instance IsoValue Integer where   type ToT Integer = 'TInt   toVal = VInt@@ -143,6 +148,21 @@   toVal = VKeyHash   fromVal (VKeyHash x) = x +instance IsoValue Bls12381Fr where+  type ToT Bls12381Fr = 'TBls12381Fr+  toVal = VBls12381Fr+  fromVal (VBls12381Fr x) = x++instance IsoValue Bls12381G1 where+  type ToT Bls12381G1 = 'TBls12381G1+  toVal = VBls12381G1+  fromVal (VBls12381G1 x) = x++instance IsoValue Bls12381G2 where+  type ToT Bls12381G2 = 'TBls12381G2+  toVal = VBls12381G2+  fromVal (VBls12381G2 x) = x+ instance IsoValue Timestamp where   type ToT Timestamp = 'TTimestamp   toVal = VTimestamp@@ -185,6 +205,8 @@   toVal = VOption . fmap toVal   fromVal (VOption x) = fmap fromVal x +instance IsoValue Void+ instance (IsoValue l, IsoValue r) => IsoValue (Either l r)  instance (IsoValue a, IsoValue b) => IsoValue (a, b)@@ -313,6 +335,11 @@   gToValue G.U1 = VUnit   gFromValue VUnit = G.U1 +instance GIsoValue G.V1 where+  type GValueType G.V1 = 'TNever+  gToValue = \case+  gFromValue = \case+ instance IsoValue a => GIsoValue (G.Rec0 a) where   type GValueType (G.Rec0 a) = ToT a   gToValue = toVal . G.unK1@@ -378,6 +405,7 @@  instance WellTyped 'TKey where instance WellTyped 'TUnit where+instance WellTyped 'TNever where instance WellTyped 'TSignature where instance WellTyped 'TChainId where instance WellTyped t => WellTyped ('TOption t) where@@ -406,5 +434,8 @@ instance WellTyped 'TMutez instance WellTyped 'TBool instance WellTyped 'TKeyHash+instance WellTyped 'TBls12381Fr+instance WellTyped 'TBls12381G1+instance WellTyped 'TBls12381G2 instance WellTyped 'TTimestamp instance WellTyped 'TAddress

@@ -2,10 +2,7 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ -{-# LANGUAGE QuantifiedConstraints #-}- -- | Module, containing data types for Michelson value.- module Michelson.Typed.Instr   ( Instr (..)   , ExtInstr (..)@@ -24,17 +21,29 @@   , pattern PAIR   , pattern UNPAIR   , PackedNotes(..)+  , ConstraintDUPN+  , ConstraintDUPN'   , ConstraintDIPN   , ConstraintDIPN'   , ConstraintDIG   , ConstraintDIG'   , ConstraintDUG   , ConstraintDUG'+  , ConstraintPairN+  , PairN+  , RightComb+  , ConstraintUnpairN+  , UnpairN+  , ConstraintGetN+  , GetN+  , ConstraintUpdateN+  , UpdateN   ) where  import Data.Default import Data.Singletons (Sing) import Fmt (Buildable(..), (+||), (||+))+import GHC.TypeNats (type (+)) import qualified GHC.TypeNats as GHC (Nat) import qualified Text.Show @@ -48,13 +57,23 @@ import Michelson.Typed.Scope import Michelson.Typed.Sing (KnownT) import Michelson.Typed.T (T(..))+import Michelson.Typed.TypeLevel+  (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,+  CombedPairNodeIndexIsValid, IsPair) import Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..)) import Michelson.Untyped-  (Annotation(..), EntriesOrder(..), FieldAnn, TypeAnn, VarAnn, entriesOrderToInt)+  (Annotation(..), EntriesOrder(..), FieldAnn, TypeAnn, VarAnn, VarAnns, entriesOrderToInt) import Util.Peano import Util.TH-import Util.Type (type (++), KnownList)+import Util.Type (If, KnownList, type (++))+import Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)), TypeErrorUnless) +-- This next comment is needed to run the doctest examples throughout this module.++-- $setup+-- >>> :m +Michelson.Typed.T Util.Peano Data.Singletons+-- >>> :set -XPartialTypeSignatures+ -- | A wrapper to wrap annotations and corresponding singleton. -- Apart from packing notes along with the corresponding Singleton, -- this wrapper type, when included with `Instr` also helps to derive@@ -75,6 +94,16 @@ instance RenderDoc (PackedNotes a) where   renderDoc pn (PackedNotes n) = renderDoc pn n +-- | Constraint that is used in DUPN, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =+  ( SingI n, KnownPeano n, RequireLongerOrSameLength inp n, n > 'Z ~ 'True+  , inp ~ (Take (Decrement n) inp ++ (a ': Drop n inp))+  , out ~ (a ': inp)+  )++type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a+ -- | Constraint that is used in DIPN, we want to share it with -- typechecking code and eDSL code. type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])@@ -86,6 +115,8 @@  type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s' +-- | Constraint that is used in DIG, we want to share it with+-- typechecking code and eDSL code. type ConstraintDIG' kind (n :: Peano) (inp :: [kind])   (out :: [kind]) (a :: kind) =   ( SingI n, KnownPeano n, RequireLongerThan inp n@@ -95,6 +126,8 @@  type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a +-- | Constraint that is used in DUG, we want to share it with+-- typechecking code and eDSL code. type ConstraintDUG' kind (n :: Peano) (inp :: [kind])   (out :: [kind]) (a :: kind) =   ( SingI n, KnownPeano n, RequireLongerThan out n@@ -104,6 +137,109 @@  type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a +type ConstraintPairN (n :: Peano) (inp :: [T]) =+  ( RequireLongerOrSameLength inp n+  , TypeErrorUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")+  , SingI n+  , KnownPeano n+  )++type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) ': Drop n s)++-- | Folds a stack into a right-combed pair.+--+-- > RightComb '[ 'TInt,  'TString, 'TUnit ]+-- > ~+-- > 'TPair 'TInt ('TPair 'TString 'TUnit)+type family RightComb (s :: [T]) :: T where+  RightComb '[ x, y ] = 'TPair x y+  RightComb (x ': xs) = 'TPair x (RightComb xs)++type ConstraintUnpairN (n :: Peano) (pair :: T) =+  ( TypeErrorUnless (n >= ToPeano 2)+      ('Text "'UNPAIR n' expects n ≥ 2")++  , TypeErrorUnless (CombedPairLeafCountIsAtLeast n pair)+      (If (IsPair pair)+        ('Text "'UNPAIR "+          ':<>: 'ShowType (FromPeano n)+          ':<>: 'Text "' expects a right-combed pair with at least "+          ':<>: 'ShowType (FromPeano n)+          ':<>: 'Text " elements at the top of the stack,"+          ':$$: 'Text "but the pair only contains "+          ':<>: 'ShowType (FromPeano (CombedPairLeafCount pair))+          ':<>: 'Text " elements.")+        ('Text "Expected a pair at the top of the stack, but found: "+          ':<>: 'ShowType pair+        )+      )+  , SingI n+  , KnownPeano n+  )++-- | Splits a right-combed pair into @n@ elements.+--+-- > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString 'TUnit))+-- > ~+-- > '[ 'TInt, 'TString, 'TUnit]+--+-- > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString ('TPair 'TUnit 'TInt)))+-- > ~+-- > '[ 'TInt, 'TString, 'TPair 'TUnit 'TInt]+type family UnpairN (n :: Peano) (s :: T) :: [T] where+  UnpairN ('S ('S 'Z)) ('TPair x y) = [x, y]+  UnpairN ('S n)       ('TPair x y) = x : UnpairN n y++type ConstraintGetN (ix :: Peano) (pair :: T) =+  ( TypeErrorUnless (CombedPairNodeIndexIsValid ix pair)+      (If (IsPair pair)+        ('Text "'GET "+          ':<>: 'ShowType (FromPeano ix)+          ':<>: 'Text "' expects a right-combed pair with at least "+          ':<>: 'ShowType (FromPeano ix + 1)+          ':<>: 'Text " nodes at the top of the stack,"+          ':$$: 'Text "but the pair only contains "+          ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))+          ':<>: 'Text " nodes.")+        ('Text "Expected a pair at the top of the stack, but found: "+          ':<>: 'ShowType pair+        )+      )+  , SingI ix+  , KnownPeano ix+  )++-- | Get the node at index @ix@ of a right-combed pair.+type family GetN (ix :: Peano) (pair :: T) :: T where+  GetN 'Z val                       = val+  GetN ('S 'Z) ('TPair left _)      = left+  GetN ('S ('S n)) ('TPair _ right) = GetN n right++type ConstraintUpdateN (ix :: Peano) (pair :: T) =+  ( TypeErrorUnless (CombedPairNodeIndexIsValid ix pair)+      (If (IsPair pair)+        ('Text "'UPDATE "+          ':<>: 'ShowType (FromPeano ix)+          ':<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least "+          ':<>: 'ShowType (FromPeano ix + 1)+          ':<>: 'Text " nodes,"+          ':$$: 'Text "but the pair only contains "+          ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))+          ':<>: 'Text " nodes.")+        ('Text "Expected the 2nd element of the stack to be a pair, but found: "+          ':<>: 'ShowType pair+        )+      )+  , SingI ix+  , KnownPeano ix+  )++-- | Update the node at index @ix@ of a right-combed pair.+type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T where+  UpdateN 'Z          val _                   = val+  UpdateN ('S 'Z)     val ('TPair _  right)   = 'TPair val right+  UpdateN ('S ('S n)) val ('TPair left right) = 'TPair left (UpdateN n val right)+ -- | Representation of Michelson instruction or sequence -- of instructions. --@@ -126,20 +262,31 @@   -- TODO [#283]: replace this wrapper with something more clever and abstract.   WithLoc :: InstrCallStack -> Instr a b -> Instr a b -  -- | A wrapper for instruction that also contain annotations for the+  -- | A wrapper for an instruction that also contains annotations for the   -- top type on the result stack.   --   -- As of now, when converting from untyped representation,-  -- we only preserve field annotations and type annotations in @PackedNotes@.-  -- Variable annotations are preserved in @InstrWithVarNotes@.+  -- we only preserve field annotations and type annotations in 'PackedNotes'.+  -- Variable annotations are preserved in 'InstrWithVarAnns'.   --   -- 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.+  -- | A wrapper for an instruction which produces variable annotations on the+  -- top stack element(s). See also: 'InstrWithVarAnns'.   InstrWithVarNotes :: NonEmpty VarAnn -> Instr a b -> Instr a b +  -- | A wrapper for an instruction that also contains a variable annotation for+  -- the top type on the result stack.+  --+  -- This differs from 'InstrWithVarNotes' in a subtle but significant way: that+  -- constructor is only present on instructions which explicitly produce+  -- variable annotations, while this constructor contains the annotation+  -- associated to an instruction after every type-checking phase, in the same+  -- manner as 'InstrWithNotes', which is useful during the interpreter phase.+  InstrWithVarAnns :: VarAnns -> Instr a b -> Instr a b+   -- | Execute given instruction on truncated stack.   --   -- This can wrap only instructions with at least one non-failing execution@@ -154,7 +301,7 @@   -- "yet ambiguous" type information in code.   -- We could make this not an instruction but rather a function   -- which modifies an instruction (this would also automatically prove-  -- soundness of used transformation), but it occured to be tricky+  -- soundness of used transformation), but it occurred to be tricky   -- (in particular for TestAssert and DipN and family), so let's leave   -- this for future work.   FrameInstr@@ -189,7 +336,10 @@     :: forall (n :: Peano) s.     (SingI n, KnownPeano n, RequireLongerOrSameLength s n, NFData (Sing n))     => Sing n -> Instr s (Drop n s)-  DUP  :: Instr (a ': s) (a ': a ': s)+  DUP :: Instr (a ': s) (a ': a ': s)+  DUPN+    :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, NFData (Sing n))+    => Sing n -> Instr inp out   SWAP :: Instr (a ': b ': s) (b ': a ': s)   DIG     :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a, NFData (Sing n))@@ -211,6 +361,60 @@   -- in case of special field annotations, so we carry annotations for instruction   -- separately from notes.   AnnPAIR :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': b ': s) ('TPair a b ': s)+  -- |+  -- >>> :t PAIRN (peanoSing @3) :: Instr '[ 'TInt, 'TUnit, 'TString ] _+  -- ...+  -- ...:: Instr+  -- ...    '[ 'TInt, 'TUnit, 'TString]+  -- ...    '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]+  --+  --+  -- >>> PAIRN (peanoSing @1) :: Instr '[ 'TInt, 'TInt ] _+  -- ...+  -- ... 'PAIR n' expects n ≥ 2+  -- ...+  --+  -- >>> PAIRN (peanoSing @3) :: Instr '[ 'TInt, 'TInt ] _+  -- ...+  -- ... Expected stack with length >= 3+  -- ... Current stack has size of only 2:+  -- ...+  PAIRN+    :: forall n inp. ConstraintPairN n inp+    => Sing n -> Instr inp (PairN n inp)+  -- |+  -- >>> :t UNPAIRN (peanoSing @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit 'TString) ] _+  -- ...+  -- ...:: Instr+  -- ...   '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]+  -- ...   '[ 'TInt, 'TUnit, 'TString]+  --+  -- >>> :t UNPAIRN (peanoSing @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat)) ] _+  -- ...+  -- ...:: Instr+  -- ...   '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat))]+  -- ...   '[ 'TInt, 'TUnit, 'TPair 'TString 'TNat]+  --+  -- >>> UNPAIRN (peanoSing @1) :: Instr '[ 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'UNPAIR n' expects n ≥ 2+  -- ...+  --+  -- >>> UNPAIRN (peanoSing @2) :: Instr '[ 'TInt, 'TUnit, 'TString ] _+  -- ...+  -- ...Expected a pair at the top of the stack, but found: 'TInt+  -- ...+  --+  -- >>> UNPAIRN (peanoSing @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'UNPAIR 3' expects a right-combed pair with at least 3 elements at the top of the stack,+  -- ...but the pair only contains 2 elements.+  -- ...+  UNPAIRN+    :: forall (n :: Peano) (pair :: T) (s :: [T]).+       ConstraintUnpairN n pair+    => Sing n+    -> Instr (pair : s) (UnpairN n pair ++ s)   LEFT :: forall b a s . KnownT b => Instr (a ': s) ('TOr a b ': s)   RIGHT :: forall a b s . KnownT a => Instr (b ': s) ('TOr a b ': s)   IF_LEFT@@ -235,9 +439,83 @@   GET     :: (GetOp c, KnownT (GetOpVal c))     => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s)+  -- | Get the node at index @ix@ of a right-combed pair.+  -- Nodes are 0-indexed, and are numbered in a breadth-first,+  -- left-to-right fashion.+  --+  -- For example, a pair with 3 elements @pair a b c@ will be+  -- represented as a tree with 5 nodes:+  --+  -- >    pair+  -- >    /   \+  -- >  a     pair+  -- >        /   \+  -- >      b       c+  --+  -- Where the nodes are numbered as follows:+  --+  -- >      0+  -- >    /   \+  -- >  1       2+  -- >        /   \+  -- >      3       4+  --+  -- >>> :t GETN (peanoSing @1) :: Instr '[ 'TPair 'TInt 'TUnit] _+  -- ...+  -- ...:: Instr '[ 'TPair 'TInt 'TUnit] '[ 'TInt]+  --+  -- >>> GETN (peanoSing @1) :: Instr '[ 'TUnit ] _+  -- ...+  -- ...Expected a pair at the top of the stack, but found: 'TUnit+  -- ...+  --+  -- >>> GETN (peanoSing @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'GET 3' expects a right-combed pair with at least 4 nodes at the top of the stack,+  -- ...but the pair only contains 3 nodes.+  -- ...+  --+  -- Note that @GET 0@ is just the identity function and works for all types (not just pairs).+  --+  -- >>> :t GETN (peanoSing @0) :: Instr '[ 'TInt ] _+  -- ...+  -- ...:: Instr '[ 'TInt] '[ 'TInt]+  GETN+    :: forall (ix :: Peano) (pair :: T) (s :: [T]).+       ConstraintGetN ix pair+    => Sing ix+    -> Instr (pair : s) (GetN ix pair ': s)   UPDATE     :: UpdOp c     => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s)+  -- | Update the node at index @ix@ of a right-combed pair.+  --+  -- >>> :t UPDATEN (peanoSing @1) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit] _+  -- ...+  -- ...:: Instr+  -- ...     '[ 'TString, 'TPair 'TInt 'TUnit] '[ 'TPair 'TString 'TUnit]+  --+  -- >>> UPDATEN (peanoSing @1) :: Instr '[ 'TUnit, 'TInt ] _+  -- ...+  -- ...Expected the 2nd element of the stack to be a pair, but found: 'TInt+  -- ...+  --+  -- >>> UPDATEN (peanoSing @3) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit ] _+  -- ...+  -- ...'UPDATE 3' expects the 2nd element of the stack to be a right-combed pair with at least 4 nodes,+  -- ...but the pair only contains 3 nodes.+  -- ...+  --+  -- Note that @UPDATE 0@ is equivalent to @DIP { DROP }@.+  --+  -- >>> :t UPDATEN (peanoSing @0) :: Instr '[ 'TInt, 'TString ] _+  -- ...+  -- ...:: Instr '[ 'TInt, 'TString] '[ 'TInt]+  UPDATEN+    :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]).+       ConstraintUpdateN ix pair+    => Sing ix+    -> Instr (val : pair : s) (UpdateN ix val pair ': s)   IF :: Instr s s'      -> Instr s s'      -> Instr ('TBool ': s) s'@@ -256,7 +534,10 @@   DIPN     :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s', (NFData (Sing n)))     => Sing n -> Instr s s' -> Instr inp out-  FAILWITH :: (KnownT a) => Instr (a ': s) t+  -- Since 008 it's prohibited to fail with non-packable values and with the+  -- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint.+  -- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information.+  FAILWITH :: (KnownT a, ConstantScope a) => Instr (a ': s) t   CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)   RENAME :: Instr (a ': s) (a ': s)   PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s)@@ -268,13 +549,13 @@     => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s)   ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s)   ADD-    :: (ArithOp Add n m, Typeable n, Typeable m)+    :: ArithOp Add n m     => Instr (n ': m ': s) (ArithRes Add n m ': s)   SUB-    :: (ArithOp Sub n m, Typeable n, Typeable m)+    :: ArithOp Sub n m     => Instr (n ': m ': s) (ArithRes Sub n m ': s)   MUL-    :: (ArithOp Mul n m, Typeable n, Typeable m)+    :: ArithOp Mul n m     => Instr (n ':  m ': s) (ArithRes Mul n m ': s)   EDIV     :: EDivOp n m@@ -288,19 +569,19 @@     :: UnaryArithOp Neg n     => Instr (n ': s) (UnaryArithRes Neg n ': s)   LSL-    :: (ArithOp Lsl n m, Typeable n, Typeable m)+    :: ArithOp Lsl n m     => Instr (n ': m ': s) (ArithRes Lsl n m ': s)   LSR-    :: (ArithOp Lsr n m, Typeable n, Typeable m)+    :: ArithOp Lsr n m     => Instr (n ':  m ': s) (ArithRes Lsr n m ': s)   OR-    :: (ArithOp Or n m, Typeable n, Typeable m)+    :: ArithOp Or n m     => Instr (n ': m ': s) (ArithRes Or n m ': s)   AND-    :: (ArithOp And n m, Typeable n, Typeable m)+    :: ArithOp And n m     => Instr (n ': m ': s) (ArithRes And n m ': s)   XOR-    :: (ArithOp Xor n m, Typeable n, Typeable m)+    :: ArithOp Xor n m     => Instr (n ': m ': s) (ArithRes Xor n m ': s)   NOT     :: UnaryArithOp Not n@@ -326,7 +607,9 @@   GE     :: UnaryArithOp Ge n     => Instr (n ': s) (UnaryArithRes Ge n ': s)-  INT :: Instr ('TNat ': s) ('TInt ': s)+  INT+    :: ToIntArithOp n+    => Instr (n ': s) ('TInt ': s)   SELF     :: forall (arg :: T) s .        (ParameterScope arg)@@ -356,6 +639,8 @@   NOW :: Instr s ('TTimestamp ': s)   AMOUNT :: Instr s ('TMutez ': s)   BALANCE :: Instr s ('TMutez ': s)+  VOTING_POWER :: Instr ('TKeyHash ': s) ('TNat ': s)+  TOTAL_VOTING_POWER :: Instr s ('TNat ': s)   CHECK_SIGNATURE     :: Instr ('TKey ': 'TSignature ': 'TBytes ': s)                    ('TBool ': s)@@ -365,11 +650,15 @@   SHA3 :: Instr ('TBytes ': s) ('TBytes ': s)   KECCAK :: Instr ('TBytes ': s) ('TBytes ': s)   HASH_KEY :: Instr ('TKey ': s) ('TKeyHash ': s)+  PAIRING_CHECK+    :: Instr ('TList ('TPair 'TBls12381G1 'TBls12381G2) ': s) ('TBool ': s)   SOURCE :: Instr s ('TAddress ': s)   SENDER :: Instr s ('TAddress ': s)   ADDRESS :: Instr ('TContract a ': s) ('TAddress ': s)   CHAIN_ID :: Instr s ('TChainId ': s)   LEVEL :: Instr s ('TNat ': s)+  SELF_ADDRESS :: Instr s ('TAddress ': s)+  NEVER :: Instr ('TNever ': s) t  deriving stock instance Show (Instr inp out) @@ -431,7 +720,7 @@   :: forall (gn :: GHC.Nat) st n.       (n ~ ToPeano gn, SingI n, KnownPeano n, RequireLongerThan st n)   => StackRef st-mkStackRef = StackRef $ sing @(ToPeano gn)+mkStackRef = StackRef $ peanoSing @gn  -- | A print format with references into the stack newtype PrintComment (st :: [T]) = PrintComment

@@ -52,17 +52,20 @@   mapOpFromList     :: (KnownT b)     => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)+  mapOpNotes :: Notes c -> Notes (MapOpInp c) instance MapOp ('TMap k v) where   type MapOpInp ('TMap k v) = 'TPair k v   type MapOpRes ('TMap k v) = 'TMap k   mapOpToList (VMap m) = map (\(k, v) -> VPair (k, v)) $ M.toAscList m   mapOpFromList (VMap m) l =     VMap $ M.fromList $ zip (map fst $ M.toAscList m) l+  mapOpNotes (NTMap _ nk nv) = NTPair noAnn noAnn noAnn noAnn noAnn nk nv instance MapOp ('TList e) where   type MapOpInp ('TList e) = e   type MapOpRes ('TList e) = 'TList   mapOpToList (VList l) = l   mapOpFromList (VList _) l' = VList l'+  mapOpNotes (NTList _ n) = n -- If you find it difficult to implement 'MapOp' for your datatype -- because of order of type arguments in it, consider wrapping it -- into a newtype.@@ -71,19 +74,23 @@   type IterOpEl c :: T   iterOpDetachOne ::     Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c)+  iterOpNotes :: Notes c -> Notes (IterOpEl c) instance IterOp ('TMap k v) where   type IterOpEl ('TMap k v) = 'TPair k v   iterOpDetachOne (VMap m) =     (VPair <$> M.lookupMin m, VMap $ M.deleteMin m)+  iterOpNotes (NTMap _ nk nv) = NTPair noAnn noAnn noAnn noAnn noAnn nk nv instance IterOp ('TList e) where   type IterOpEl ('TList e) = e   iterOpDetachOne (VList l) =     case l of       x : xs -> (Just x, VList xs)       [] -> (Nothing, VList [])+  iterOpNotes (NTList _ n) = n instance IterOp ('TSet e) where   type IterOpEl ('TSet e) = e   iterOpDetachOne (VSet s) = (S.lookupMin s, VSet $ S.deleteMin s)+  iterOpNotes (NTSet _ n) = n  class SizeOp (c :: T) where   evalSize :: Value' instr c -> Int@@ -197,7 +204,7 @@   type EDivOpRes 'TInt 'TInt = 'TInt   type EModOpRes 'TInt 'TInt = 'TNat   convergeEDiv n1 n2 =-    (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn a $ NTNat noAnn)+    (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a $ NTNat noAnn)       <$> converge n1 n2   evalEDivOp (VInt i) (VInt j) =     if j == 0@@ -207,7 +214,7 @@ instance EDivOp 'TInt 'TNat where   type EDivOpRes 'TInt 'TNat = 'TInt   type EModOpRes 'TInt 'TNat = 'TNat-  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn n1+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1     $ NTNat noAnn   evalEDivOp (VInt i) (VNat j) =     if j == 0@@ -217,7 +224,7 @@ instance EDivOp 'TNat 'TInt where   type EDivOpRes 'TNat 'TInt = 'TInt   type EModOpRes 'TNat 'TInt = 'TNat-  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn     (NTInt noAnn) n1   evalEDivOp (VNat i) (VInt j) =     if j == 0@@ -227,7 +234,7 @@ instance EDivOp 'TNat 'TNat where   type EDivOpRes 'TNat 'TNat = 'TNat   type EModOpRes 'TNat 'TNat = 'TNat-  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn a a)+  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn a a)     <$> converge n1 n2   evalEDivOp (VNat i) (VNat j) =     if j == 0@@ -237,7 +244,7 @@ instance EDivOp 'TMutez 'TMutez where   type EDivOpRes 'TMutez 'TMutez = 'TNat   type EModOpRes 'TMutez 'TMutez = 'TMutez-  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn (NTNat noAnn) a)+  convergeEDiv n1 n2 = (\a -> NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn (NTNat noAnn) a)     <$> converge n1 n2   evalEDivOp (VMutez i) (VMutez j) =     VOption $@@ -248,7 +255,7 @@ instance EDivOp 'TMutez 'TNat where   type EDivOpRes 'TMutez 'TNat = 'TMutez   type EModOpRes 'TMutez 'TNat = 'TMutez-  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn n1 n1+  convergeEDiv n1 _ = Right $ NTOption noAnn $ NTPair noAnn noAnn noAnn noAnn noAnn n1 n1   evalEDivOp (VMutez i) (VNat j) =     VOption $     i `divModMutezInt` j <&> \case

@@ -388,8 +388,12 @@   STMutez -> OpAbsent   STBool -> OpAbsent   STKeyHash -> OpAbsent+  STBls12381Fr -> OpAbsent+  STBls12381G1 -> OpAbsent+  STBls12381G2 -> OpAbsent   STTimestamp -> OpAbsent   STAddress -> OpAbsent+  STNever -> OpAbsent  -- | Check at runtime whether the given type contains 'TContract'. checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty@@ -429,8 +433,12 @@   STMutez -> ContractAbsent   STBool -> ContractAbsent   STKeyHash -> ContractAbsent+  STBls12381Fr -> ContractAbsent+  STBls12381G1 -> ContractAbsent+  STBls12381G2 -> ContractAbsent   STTimestamp -> ContractAbsent   STAddress -> ContractAbsent+  STNever -> ContractAbsent  -- | Check at runtime whether the given type contains 'TBigMap'. checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty@@ -472,8 +480,12 @@   STMutez -> BigMapAbsent   STBool -> BigMapAbsent   STKeyHash -> BigMapAbsent+  STBls12381Fr -> BigMapAbsent+  STBls12381G1 -> BigMapAbsent+  STBls12381G2 -> BigMapAbsent   STTimestamp -> BigMapAbsent   STAddress -> BigMapAbsent+  STNever -> BigMapAbsent  -- | Check at runtime whether the given type contains 'TBigMap'. checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty@@ -516,8 +528,12 @@   STMutez -> NestedBigMapsAbsent   STBool -> NestedBigMapsAbsent   STKeyHash -> NestedBigMapsAbsent+  STBls12381Fr -> NestedBigMapsAbsent+  STBls12381G1 -> NestedBigMapsAbsent+  STBls12381G2 -> NestedBigMapsAbsent   STTimestamp -> NestedBigMapsAbsent   STAddress -> NestedBigMapsAbsent+  STNever -> NestedBigMapsAbsent  -- | Check at runtime that the given type does not contain 'TOperation'. opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)

@@ -56,8 +56,12 @@   STMutez :: SingT  'TMutez   STBool :: SingT  'TBool   STKeyHash :: SingT  'TKeyHash+  STBls12381Fr :: SingT  'TBls12381Fr+  STBls12381G1 :: SingT  'TBls12381G1+  STBls12381G2 :: SingT  'TBls12381G2   STTimestamp :: SingT  'TTimestamp   STAddress :: SingT  'TAddress+  STNever :: SingT  'TNever  type instance Sing = SingT @@ -114,8 +118,12 @@   STMutez -> TMutez   STBool -> TBool   STKeyHash -> TKeyHash+  STBls12381Fr -> TBls12381Fr+  STBls12381G1 -> TBls12381G1+  STBls12381G2 -> TBls12381G2   STTimestamp -> TTimestamp   STAddress -> TAddress+  STNever -> TNever  -- | Version of 'toSing' which creates 'SomeSingT'. toSingT :: T -> SomeSingT@@ -156,8 +164,12 @@   TMutez -> SomeSingT STMutez   TBool -> SomeSingT STBool   TKeyHash -> SomeSingT STKeyHash+  TBls12381Fr -> SomeSingT STBls12381Fr+  TBls12381G1 -> SomeSingT STBls12381G1+  TBls12381G2 -> SomeSingT STBls12381G2   TTimestamp -> SomeSingT STTimestamp   TAddress -> SomeSingT STAddress+  TNever -> SomeSingT STNever  instance SingKind T where   type Demote T = T@@ -172,6 +184,8 @@   sing = STSignature instance SingI  'TChainId where   sing = STChainId+instance SingI  'TNever where+  sing = STNever instance (KnownT a) => SingI ( 'TOption (a :: T)) where   sing = STOption sing instance (KnownT a) => SingI ( 'TList (a :: T)) where@@ -212,6 +226,12 @@   sing = STBool instance SingI  'TKeyHash where   sing = STKeyHash+instance SingI  'TBls12381Fr where+  sing = STBls12381Fr+instance SingI  'TBls12381G1 where+  sing = STBls12381G1+instance SingI  'TBls12381G2 where+  sing = STBls12381G2 instance SingI  'TTimestamp where   sing = STTimestamp instance SingI  'TAddress where

@@ -37,8 +37,12 @@   | TMutez   | TBool   | TKeyHash+  | TBls12381Fr+  | TBls12381G1+  | TBls12381G2   | TTimestamp   | TAddress+  | TNever   deriving stock (Eq, Show, Generic)  instance NFData T@@ -58,16 +62,20 @@     convert TTimestamp = Un.TTimestamp     convert TAddress = Un.TAddress     convert TKey = Un.TKey+    convert TBls12381Fr = Un.TBls12381Fr+    convert TBls12381G1 = Un.TBls12381G1+    convert TBls12381G2 = Un.TBls12381G2     convert TUnit = Un.TUnit     convert TSignature = Un.TSignature     convert TChainId = Un.TChainId+    convert TNever = Un.TNever     convert (TOption a) = Un.TOption (toUType a)     convert (TList a) = Un.TList (toUType a)     convert (TSet a) = Un.TSet $ Un.Type (Un.unwrapT $ toUType a) Un.noAnn     convert (TOperation) = Un.TOperation     convert (TContract a) = Un.TContract (toUType a)     convert (TPair a b) =-      Un.TPair Un.noAnn Un.noAnn (toUType a) (toUType b)+      Un.TPair Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType a) (toUType b)     convert (TOr a b) =       Un.TOr Un.noAnn Un.noAnn (toUType a) (toUType b)     convert (TLambda a b) =

@@ -0,0 +1,59 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | A collection of type families and other type-level machinery+-- for working with Michelson types.+module Michelson.Typed.TypeLevel+  ( -- * Right-combed pairs+    IsPair+  , CombedPairLeafCount+  , CombedPairNodeCount+  , CombedPairLeafCountIsAtLeast+  , CombedPairNodeIndexIsValid+  )+  where++import Michelson.Typed.T (T(TPair))+import Util.Peano (Nat(S, Z), Peano, ToPeano)++----------------------------------------------------------------------------+-- Right-combed pairs+----------------------------------------------------------------------------++type family IsPair (pair :: T) :: Bool where+  IsPair ('TPair _ _) = 'True+  IsPair _ = 'False++-- | Returns the number of leaves in a right-combed pair.+--+-- > CombedPairLeafCount ('TPair 'TInt ('TPair 'TString 'TUnit))+-- > ~+-- > ToPeano 3+--+-- If the pair contains sub-trees to the left, they will not be accounted for.+-- E.g. the length of @pair w (pair x y) z@ is 3.+type family CombedPairLeafCount (t :: T) :: Peano where+  CombedPairLeafCount ('TPair _ ('TPair y z)) = 'S (CombedPairLeafCount ('TPair y z))+  CombedPairLeafCount ('TPair _ _) = ToPeano 2++-- | Returns the number of nodes in a right-combed pair.+type family CombedPairNodeCount (t :: T) :: Peano where+  CombedPairNodeCount ('TPair _ ('TPair y z)) = 'S ('S (CombedPairNodeCount ('TPair y z)))+  CombedPairNodeCount ('TPair _ _) = ToPeano 3++-- | Checks whether a pair contains at least @n@ elements.+type family CombedPairLeafCountIsAtLeast (n :: Peano) (t :: T) :: Bool where+  CombedPairLeafCountIsAtLeast ('S ('S 'Z)) ('TPair _ _) = 'True+  CombedPairLeafCountIsAtLeast ('S n) ('TPair _ y) = CombedPairLeafCountIsAtLeast n y+  CombedPairLeafCountIsAtLeast ('S _) _ = 'False++-- | For a given node index @i@, this type family checks whether+-- a pair has at least @i+1@ nodes.+--+-- Note that the index 0 is always valid, even if the input type is not a pair.+type family CombedPairNodeIndexIsValid (nodeIndex :: Peano) (pair :: T) :: Bool where+  CombedPairNodeIndexIsValid 'Z                   _                = 'True+  CombedPairNodeIndexIsValid ('S 'Z)              ('TPair _ _)     = 'True+  CombedPairNodeIndexIsValid ('S ('S nodeIndex')) ('TPair _ right) = CombedPairNodeIndexIsValid nodeIndex' right+  CombedPairNodeIndexIsValid _ _                                   = 'False

@@ -94,6 +94,7 @@     WithLoc loc i1 -> recursion1 (WithLoc loc) i1     InstrWithNotes notes i1 -> recursion1 (InstrWithNotes notes) i1     InstrWithVarNotes varNotes i1 -> recursion1 (InstrWithVarNotes varNotes) i1+    InstrWithVarAnns varAnns i1 -> recursion1 (InstrWithVarAnns varAnns) i1     FrameInstr p i1 -> recursion1 (FrameInstr p) i1     Nested i1 -> recursion1 Nested i1     DocGroup dg i1 -> recursion1 (DocGroup dg) i1@@ -152,6 +153,7 @@     DROP{} -> step i     DROPN{} -> step i     DUP{} -> step i+    DUPN{} -> step i     SWAP{} -> step i     DIG{} -> step i     DUG{} -> step i@@ -159,6 +161,8 @@     NONE{} -> step i     UNIT{} -> step i     AnnPAIR{} -> step i+    PAIRN{} -> step i+    UNPAIRN{} -> step i     LEFT{} -> step i     RIGHT{} -> step i     NIL{} -> step i@@ -169,7 +173,9 @@     EMPTY_BIG_MAP{} -> step i     MEM{} -> step i     GET{} -> step i+    GETN{} -> step i     UPDATE{} -> step i+    UPDATEN{} -> step i     EXEC{} -> step i     APPLY{} -> step i     FAILWITH{} -> step i@@ -209,6 +215,8 @@     NOW{} -> step i     AMOUNT{} -> step i     BALANCE{} -> step i+    VOTING_POWER{} -> step i+    TOTAL_VOTING_POWER{} -> step i     CHECK_SIGNATURE{} -> step i     SHA256{} -> step i     SHA512{} -> step i@@ -216,11 +224,14 @@     SHA3{} -> step i     KECCAK{} -> step i     HASH_KEY{} -> step i+    PAIRING_CHECK{} -> step i     SOURCE{} -> step i     SENDER{} -> step i     ADDRESS{} -> step i     CHAIN_ID{} -> step i     LEVEL{} -> step i+    SELF_ADDRESS{} -> step i+    NEVER{} -> step i   where     recursion1 ::       forall a b c d. (Instr a b -> Instr c d) -> Instr a b -> (Instr c d, x)@@ -294,6 +305,11 @@         RfNormal (InstrWithVarNotes vn i0)       RfAlwaysFails i0 ->         error $ "InstrWithVarNotes wraps always-failing instruction: " <> show i0+    InstrWithVarAnns vn i -> case go i of+      RfNormal i0 ->+        RfNormal (InstrWithVarAnns vn i0)+      RfAlwaysFails i0 ->+        error $ "InstrWithVarAnns wraps always-failing instruction: " <> show i0     FrameInstr s i -> case go i of       RfNormal i0 ->         RfNormal (FrameInstr s i0)@@ -323,6 +339,7 @@     i@DROP{} -> RfNormal i     i@DROPN{} -> RfNormal i     i@DUP{} -> RfNormal i+    i@DUPN{} -> RfNormal i     i@SWAP{} -> RfNormal i     i@DIG{} -> RfNormal i     i@DUG{} -> RfNormal i@@ -331,6 +348,8 @@     i@NONE{} -> RfNormal i     i@UNIT{} -> RfNormal i     i@AnnPAIR{} -> RfNormal i+    i@PAIRN{} -> RfNormal i+    i@UNPAIRN{} -> RfNormal i     i@LEFT{} -> RfNormal i     i@RIGHT{} -> RfNormal i     i@NIL{} -> RfNormal i@@ -341,7 +360,9 @@     i@EMPTY_BIG_MAP{} -> RfNormal i     i@MEM{} -> RfNormal i     i@GET{} -> RfNormal i+    i@GETN{} -> RfNormal i     i@UPDATE{} -> RfNormal i+    i@UPDATEN{} -> RfNormal i     i@EXEC{} -> RfNormal i     i@APPLY{} -> RfNormal i     FAILWITH -> RfAlwaysFails FAILWITH@@ -382,6 +403,8 @@     i@NOW -> RfNormal i     i@AMOUNT -> RfNormal i     i@BALANCE -> RfNormal i+    i@VOTING_POWER -> RfNormal i+    i@TOTAL_VOTING_POWER -> RfNormal i     i@CHECK_SIGNATURE -> RfNormal i     i@SHA256 -> RfNormal i     i@SHA512 -> RfNormal i@@ -389,11 +412,14 @@     i@SHA3 -> RfNormal i     i@KECCAK -> RfNormal i     i@HASH_KEY -> RfNormal i+    i@PAIRING_CHECK -> RfNormal i     i@SOURCE -> RfNormal i     i@SENDER -> RfNormal i     i@ADDRESS -> RfNormal i     i@CHAIN_ID -> RfNormal i     i@LEVEL -> RfNormal i+    i@SELF_ADDRESS -> RfNormal i+    NEVER -> RfAlwaysFails NEVER  -- | There are many ways to represent a sequence of more than 2 instructions. -- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@.@@ -457,6 +483,9 @@   VMutez{} -> step i   VBool{} -> step i   VKeyHash{} -> step i+  VBls12381Fr{} -> step i+  VBls12381G1{} -> step i+  VBls12381G2{} -> step i   VTimestamp{} -> step i   VAddress{} -> step i 

@@ -51,7 +51,7 @@ import Michelson.Typed.T (T(..)) import Tezos.Address (Address) import Tezos.Core (ChainId, Mutez, Timestamp)-import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature) import Util.TH import Util.Typeable @@ -193,16 +193,15 @@ -- | Constraint which ensures that type is comparable. type family IsComparable (t :: T) :: Bool where   IsComparable ('TPair a b) =  IsComparable a && IsComparable b-  IsComparable 'TKey = 'False-  IsComparable 'TUnit = 'False-  IsComparable 'TSignature = 'False-  IsComparable 'TChainId = 'False-  IsComparable ('TOption _) = 'False+  IsComparable ('TOption t) = IsComparable t+  IsComparable 'TBls12381Fr = 'False+  IsComparable 'TBls12381G1 = 'False+  IsComparable 'TBls12381G2 = 'False   IsComparable ('TList _) = 'False   IsComparable ('TSet _) = 'False   IsComparable 'TOperation = 'False   IsComparable ('TContract _) = 'False-  IsComparable ('TOr _ _) = 'False+  IsComparable ('TOr a b) = IsComparable a && IsComparable b   IsComparable ('TLambda _ _) = 'False   IsComparable ('TMap _ _) = 'False   IsComparable ('TBigMap _ _) = 'False@@ -213,6 +212,12 @@  instance (Comparable e1, Comparable e2) => Comparable ('TPair e1 e2) where   tcompare (VPair a) (VPair b) = compare a b+instance (Comparable e1, Comparable e2) => Comparable ('TOr e1 e2) where+  tcompare (VOr a) (VOr b) = compare a b+instance Comparable e => Comparable ('TOption e) where+  tcompare (VOption a) (VOption b) = compare a b+instance Comparable 'TUnit where+  tcompare VUnit VUnit = EQ instance Comparable 'TInt where   tcompare (VInt a) (VInt b) = compare a b instance Comparable 'TNat where@@ -231,6 +236,14 @@   tcompare (VTimestamp a) (VTimestamp b) = compare a b instance Comparable 'TAddress where   tcompare (VAddress a) (VAddress b) = compare a b+instance Comparable 'TNever where+  tcompare = \case+instance Comparable 'TChainId where+  tcompare (VChainId a) (VChainId b) = compare a b+instance Comparable 'TSignature where+  tcompare (VSignature a) (VSignature b) = compare a b+instance Comparable 'TKey where+  tcompare (VKey a) (VKey b) = compare a b  instance (Comparable e) => Ord (Value' instr e) where   compare = tcompare @e@@ -255,19 +268,22 @@     (CanBeCompared, CanBeCompared) -> CanBeCompared     (CannotBeCompared, _) -> CannotBeCompared     (_, CannotBeCompared) -> CannotBeCompared-  STKey -> CannotBeCompared-  STUnit -> CannotBeCompared-  STSignature -> CannotBeCompared-  STChainId -> CannotBeCompared-  STOption _ -> CannotBeCompared+  STOr a b -> case (checkComparability a, checkComparability b) of+    (CanBeCompared, CanBeCompared) -> CanBeCompared+    (CannotBeCompared, _) -> CannotBeCompared+    (_, CannotBeCompared) -> CannotBeCompared+  STOption t -> case checkComparability t of+    CanBeCompared -> CanBeCompared+    CannotBeCompared -> CannotBeCompared   STList _ -> CannotBeCompared   STSet _ -> CannotBeCompared   STOperation -> CannotBeCompared   STContract _ -> CannotBeCompared-  STOr _ _ -> CannotBeCompared   STLambda _ _ -> CannotBeCompared   STMap _ _ -> CannotBeCompared   STBigMap _ _ -> CannotBeCompared+  STNever -> CanBeCompared+  STUnit -> CanBeCompared   STInt -> CanBeCompared   STNat -> CanBeCompared   STString -> CanBeCompared@@ -275,8 +291,14 @@   STMutez -> CanBeCompared   STBool -> CanBeCompared   STKeyHash -> CanBeCompared+  STBls12381Fr -> CannotBeCompared+  STBls12381G1 -> CannotBeCompared+  STBls12381G2 -> CannotBeCompared   STTimestamp -> CanBeCompared   STAddress -> CanBeCompared+  STKey -> CanBeCompared+  STSignature -> CanBeCompared+  STChainId -> CanBeCompared  comparabilityPresence :: Sing t -> Maybe (Dict $ (Comparable t)) comparabilityPresence s = case checkComparability s of@@ -349,6 +371,9 @@   VKeyHash   :: KeyHash -> Value' instr 'TKeyHash   VTimestamp :: Timestamp -> Value' instr 'TTimestamp   VAddress   :: EpAddress -> Value' instr 'TAddress+  VBls12381Fr :: Bls12381Fr -> Value' instr 'TBls12381Fr+  VBls12381G1 :: Bls12381G1 -> Value' instr 'TBls12381G1+  VBls12381G2 :: Bls12381G2 -> Value' instr 'TBls12381G2  deriving stock instance Show (Value' instr t) deriving stock instance Eq (Value' instr t)@@ -437,6 +462,9 @@   VMutez{} -> Dict   VBool{} -> Dict   VKeyHash{} -> Dict+  VBls12381Fr{} -> Dict+  VBls12381G1{} -> Dict+  VBls12381G2{} -> Dict   VTimestamp{} -> Dict   VAddress{} -> Dict 

@@ -6,6 +6,7 @@  module Michelson.Untyped.Annotation   ( Annotation (..)+  , VarAnns (..)   , pattern Annotation   , pattern WithAnn @@ -37,7 +38,10 @@   , specialFieldAnn   , isValidAnnStart   , isValidAnnBodyChar+  , orAnn   , unifyAnn+  , unifyPairFieldAnn+  , convergeVarAnns   , ifAnnUnified   , disjoinVn   , convAnn@@ -49,7 +53,7 @@ import Data.Default (Default(..)) import qualified Data.Kind as Kind import qualified Data.Text as T-import Data.Typeable ((:~:)(..), eqT)+import Data.Typeable (eqT, (:~:)(..)) import Fmt (Buildable(build)) import Instances.TH.Lift () import Language.Haskell.TH.Lift (deriveLift)@@ -79,6 +83,12 @@ instance Default (Annotation tag) where   def = noAnn +data VarAnns+  = OneVarAnn VarAnn+  | TwoVarAnns VarAnn VarAnn+  deriving stock (Generic, Show)+  deriving anyclass (NFData)+ -------------------------------------------------------------------------------- -- Annotation Set --------------------------------------------------------------------------------@@ -236,9 +246,9 @@   | otherwise = do     suffix <- case T.uncons text of       Just (h, tl) | isValidAnnStart h -> Right tl-      Just (h, _) -> Left $ T.snoc "Invalid first character: " h+      Just (h, _) -> Left $ "Invalid first character: '" <> one h <> "'"       _ -> Right ""-    maybe (Right $ AnnotationUnsafe text) (Left . T.snoc "Invalid character: ") $+    maybe (Right $ AnnotationUnsafe text) (\c -> Left $ "Invalid character: '" <> one c <> "'") $       T.find (not . isValidAnnBodyChar) suffix  -- | List of all the special Variable Annotations, only allowed in `CAR` and `CDR`@@ -278,11 +288,50 @@ instance Monoid VarAnn where     mempty = noAnn +-- | Returns the first annotation if it's not empty, or the second one otherwise.+--+-- > "a" `orAnn` "b" == "a"+-- > "a" `orAnn` ""  == "a"+-- > ""  `orAnn` "b" == "b"+-- > ""  `orAnn` ""  == ""+orAnn :: Annotation t -> Annotation t -> Annotation t+orAnn a b = bool a b (a == def)++-- | Given two type or field annotations, attempt to converge them by joining+-- these annotations with the following rule:+-- 1. If either annotation is empty, an empty annotation is returned;+-- 2. If both annotations are equal, return this annotation;+-- 3. Otherwise, returns 'Nothing'.+--+-- This function is used primarily for type-checking and attempts to imitate the+-- reference implementation's observed behavior with annotations. unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag) unifyAnn (Annotation ann1) (Annotation ann2)-  | ann1 == "" || ann2 == "" = Just $ ann $ ann1 <> ann2+  | ann1 == "" || ann2 == "" = Just noAnn   | ann1 == ann2 = Just $ ann ann1   | otherwise  = Nothing++-- | Given two field annotations where one of them is used in CAR or CDR,+-- attempt to converge them by joining these annotations with the following rule:+-- 1. If either annotation is empty, return the non-empty one (or empty if both are empty);+-- 2. If both annotations are equal, return this annotation;+-- 3. Otherwise, returns 'Nothing'.+--+-- This function is used primarily for type-checking and attempts to imitate the+-- reference implementation's observed behavior with field annotations when CAR+-- and CDR are used with pairs.+unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn+unifyPairFieldAnn ann1 ann2+  | ann1 == "" || ann2 == "" = Just $ ann1 `orAnn` ann2+  | ann1 == ann2 = Just ann1+  | otherwise = Nothing++-- | Keeps an annotation if and only if the two of them are equal and returns an+-- empty annotation otherwise.+convergeVarAnns :: VarAnn -> VarAnn -> VarAnn+convergeVarAnns ann1 ann2+  | ann1 == ann2 = ann1+  | otherwise    = noAnn  ifAnnUnified :: Annotation tag -> Annotation tag -> Bool ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2

@@ -111,6 +111,7 @@   -- ^ 'DROP' is essentially as special case for 'DROPN', but we need   -- both because they are packed differently.   | DUP               VarAnn+  | DUPN              VarAnn Word   | SWAP   | DIG               Word   | DUG               Word@@ -120,6 +121,8 @@   | UNIT              TypeAnn VarAnn   | IF_NONE           [op] [op]   | PAIR              TypeAnn VarAnn FieldAnn FieldAnn+  | PAIRN             VarAnn Word+  | UNPAIRN           Word   | CAR               VarAnn FieldAnn   | CDR               VarAnn FieldAnn   | LEFT              TypeAnn VarAnn FieldAnn FieldAnn Type@@ -136,7 +139,9 @@   | ITER              [op]   | MEM               VarAnn   | GET               VarAnn+  | GETN              VarAnn Word   | UPDATE            VarAnn+  | UPDATEN           VarAnn Word   | IF                [op] [op]   | LOOP              [op]   | LOOP_LEFT         [op]@@ -182,6 +187,8 @@   | NOW               VarAnn   | AMOUNT            VarAnn   | BALANCE           VarAnn+  | VOTING_POWER      VarAnn+  | TOTAL_VOTING_POWER VarAnn   | CHECK_SIGNATURE   VarAnn   | SHA256            VarAnn   | SHA512            VarAnn@@ -189,11 +196,14 @@   | SHA3              VarAnn   | KECCAK            VarAnn   | HASH_KEY          VarAnn+  | PAIRING_CHECK     VarAnn   | SOURCE            VarAnn   | SENDER            VarAnn   | ADDRESS           VarAnn   | CHAIN_ID          VarAnn   | LEVEL             VarAnn+  | SELF_ADDRESS      VarAnn+  | NEVER   deriving stock (Eq, Functor, Data, Generic)  instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where@@ -207,6 +217,7 @@     DROP                    -> "DROP"     DROPN n                 -> "DROP" <+> text (show n)     DUP va                  -> "DUP" <+> renderAnnot va+    DUPN va n               -> "DUP" <+> renderAnnot va <+> text (show n)     SWAP                    -> "SWAP"     DIG n                   -> "DIG" <+> text (show n)     DUG n                   -> "DUG" <+> text (show n)@@ -230,6 +241,8 @@     UNIT ta va              -> "UNIT" <+> renderAnnots [ta] [] [va]     IF_NONE x y             -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)     PAIR ta va fa1 fa2      -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]+    PAIRN va n              -> "PAIR" <+> renderAnnots [] [] [va] <+> text (show n)+    UNPAIRN n               -> "UNPAIR" <+> text (show n)     CAR va fa               -> "CAR" <+> renderAnnots [] [fa] [va]     CDR va fa               -> "CDR" <+> renderAnnots [] [fa] [va]     LEFT ta va fa1 fa2 t    -> "LEFT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t@@ -246,7 +259,9 @@     ITER s                  -> "ITER" <+> nest 6 (renderOps s)     MEM va                  -> "MEM" <+> renderAnnot va     GET va                  -> "GET" <+> renderAnnot va+    GETN va n               -> "GET" <+> renderAnnot va <+> text (show n)     UPDATE va               -> "UPDATE" <+> renderAnnot va+    UPDATEN va n            -> "UPDATE" <+> renderAnnot va <+> text (show n)     IF x y                  -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y)     LOOP s                  -> "LOOP" <+> nest 6 (renderOps s)     LOOP_LEFT s             -> "LOOP_LEFT" <+> nest 11 (renderOps s)@@ -294,6 +309,8 @@     NOW va                  -> "NOW" <+> renderAnnot va     AMOUNT va               -> "AMOUNT" <+> renderAnnot va     BALANCE va              -> "BALANCE" <+> renderAnnot va+    VOTING_POWER va         -> "VOTING_POWER" <+> renderAnnot va+    TOTAL_VOTING_POWER va   -> "TOTAL_VOTING_POWER" <+> renderAnnot va     CHECK_SIGNATURE va      -> "CHECK_SIGNATURE" <+> renderAnnot va     SHA256 va               -> "SHA256" <+> renderAnnot va     SHA512 va               -> "SHA512" <+> renderAnnot va@@ -301,11 +318,14 @@     SHA3 va                 -> "SHA3" <+> renderAnnot va     KECCAK va               -> "KECCAK" <+> renderAnnot va     HASH_KEY va             -> "HASH_KEY" <+> renderAnnot va+    PAIRING_CHECK va        -> "PAIRING_CHECK" <+> renderAnnot va     SOURCE va               -> "SOURCE" <+> renderAnnot va     SENDER va               -> "SENDER" <+> renderAnnot va     ADDRESS va              -> "ADDRESS" <+> renderAnnot va     CHAIN_ID va             -> "CHAIN_ID" <+> renderAnnot va     LEVEL va                -> "LEVEL" <+> renderAnnot va+    SELF_ADDRESS va         -> "SELF_ADDRESS" <+> renderAnnot va+    NEVER                   -> "NEVER"     where       renderTy = renderDoc @Type needsParens       renderComp = renderDoc @Type needsParens

@@ -16,7 +16,7 @@ -- origination or transfer themselves, for instance, amount of mutez carried -- to the contract. ATM we don't have necessary primitives in Haskell to be -- able to handle those parameters here, probably waiting for [TM-89].--- Currently, we can assess overall transfer size only approximatelly, like+-- Currently, we can assess overall transfer size only approximately, like -- in 'smallTransferOpSize'. module Michelson.Untyped.OpSize   ( OpSize (..)@@ -69,6 +69,7 @@   DROPN n -> stackDepthOpSize n   DROP -> mempty   DUP va -> annsOpSize va+  DUPN va n -> annsOpSize va <> stackDepthOpSize n   SWAP -> mempty   DIG n -> stackDepthOpSize n   DUG n -> stackDepthOpSize n@@ -78,6 +79,8 @@   UNIT ta va -> annsOpSize ta va   IF_NONE l r -> ifOpSize l r   PAIR ta va fal far -> annsOpSize ta va fal far+  PAIRN va n -> annsOpSize va <> stackDepthOpSize n+  UNPAIRN n -> stackDepthOpSize n   CAR va fa -> annsOpSize va fa   CDR va fa -> annsOpSize va fa   LEFT ta va fal far t -> annsOpSize ta va fal far <> typeOpSize t@@ -94,7 +97,9 @@   ITER is -> subcodeOpSize is   MEM va -> annsOpSize va   GET va -> annsOpSize va+  GETN va n -> annsOpSize va <> stackDepthOpSize n   UPDATE va -> annsOpSize va+  UPDATEN va n -> annsOpSize va <> stackDepthOpSize n   IF l r -> ifOpSize l r   LOOP is -> expandedInstrsOpSize is   LOOP_LEFT is -> expandedInstrsOpSize is@@ -141,6 +146,8 @@   NOW va -> annsOpSize va   AMOUNT va -> annsOpSize va   BALANCE va -> annsOpSize va+  VOTING_POWER va -> annsOpSize va+  TOTAL_VOTING_POWER va -> annsOpSize va   CHECK_SIGNATURE va -> annsOpSize va   SHA256 va -> annsOpSize va   SHA512 va -> annsOpSize va@@ -148,11 +155,14 @@   SHA3 va -> annsOpSize va   KECCAK va -> annsOpSize va   HASH_KEY va -> annsOpSize va+  PAIRING_CHECK va -> annsOpSize va   SOURCE va -> annsOpSize va   SENDER va -> annsOpSize va   ADDRESS va -> annsOpSize va   CHAIN_ID va -> annsOpSize va   LEVEL va -> annsOpSize va+  SELF_ADDRESS va -> annsOpSize va+  NEVER -> mempty   where     subcodeOpSize is = expandedInstrOpSize (SeqEx is)     ifOpSize l r = expandedInstrOpSize (SeqEx l) <> expandedInstrOpSize (SeqEx r)@@ -215,7 +225,8 @@     TSet a -> innerOpSize a     TOperation -> mempty     TContract a -> typeOpSize a-    TPair al ar l r -> typeOpSize' [al] l <> typeOpSize' [ar] r+    -- Nested variable annotations don't use any extra operation size.+    TPair al ar _ _ l r -> typeOpSize' [al] l <> typeOpSize' [ar] r     TOr al ar l r -> typeOpSize' [al] l <> typeOpSize' [ar] r     TLambda i o -> typeOpSize i <> typeOpSize o     TMap k v -> innerOpSize k <> typeOpSize v@@ -227,8 +238,12 @@     TMutez -> mempty     TBool -> mempty     TKeyHash -> mempty+    TBls12381Fr -> mempty+    TBls12381G1 -> mempty+    TBls12381G2 -> mempty     TTimestamp -> mempty     TAddress -> mempty+    TNever -> mempty  innerOpSize :: Type -> OpSize innerOpSize (Type _ a) =

@@ -46,7 +46,7 @@   (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens,   needsParens, wrapInParens) import Michelson.Untyped.Annotation-  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, emptyAnnSet, fullAnnSet, noAnn, singleAnnSet)+  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn, singleAnnSet) import Util.Aeson  -- Annotated type@@ -116,10 +116,14 @@     TBytes            -> wrapInParens pn $ "bytes" :| [annDoc]     TAddress          -> wrapInParens pn $ "address" :| [annDoc]     TKey              -> wrapInParens pn $ "key"  :| [annDoc]+    TBls12381Fr       -> wrapInParens pn $ "bls12_381_fr"  :| [annDoc]+    TBls12381G1       -> wrapInParens pn $ "bls12_381_g1"  :| [annDoc]+    TBls12381G2       -> wrapInParens pn $ "bls12_381_g2"  :| [annDoc]     TUnit             -> wrapInParens pn $ "unit" :| [annDoc]     TSignature        -> wrapInParens pn $ "signature" :| [annDoc]     TChainId          -> wrapInParens pn $ "chain_id" :| [annDoc]     TOperation        -> wrapInParens pn $ "operation" :| [annDoc]+    TNever            -> wrapInParens pn $ "never" :| [annDoc]      TOption (Type t1 ta1) ->       addParens pn $@@ -137,12 +141,12 @@       addParens pn $       "contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1) -    TPair fa1 fa2 (Type t1 ta1) (Type t2 ta2) ->+    TPair fa1 fa2 va1 va2 (Type t1 ta1) (Type t2 ta2) ->       addParens pn $         "pair" <+> annDoc <+>           renderBranches-            (recRenderer t1 $ fullAnnSet [ta1] [fa1] [])-            (recRenderer t2 $ fullAnnSet [ta2] [fa2] [])+            (recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1])+            (recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2])      TOr fa1 fa2 (Type t1 ta1) (Type t2 ta2) ->       addParens pn $@@ -189,7 +193,7 @@   | TSet Type   | TOperation   | TContract Type-  | TPair FieldAnn FieldAnn Type Type+  | TPair FieldAnn FieldAnn VarAnn VarAnn Type Type   | TOr FieldAnn FieldAnn Type Type   | TLambda Type Type   | TMap Type Type@@ -201,8 +205,12 @@   | TMutez   | TBool   | TKeyHash+  | TBls12381Fr+  | TBls12381G1+  | TBls12381G2   | TTimestamp   | TAddress+  | TNever   deriving stock (Eq, Show, Data, Generic)  instance Buildable T where@@ -214,7 +222,7 @@ toption t = TOption t  tpair :: Type -> Type -> T-tpair l r = TPair noAnn noAnn l r+tpair l r = TPair noAnn noAnn noAnn noAnn l r  tor :: Type -> Type -> T tor l r = TOr noAnn noAnn l r

@@ -83,7 +83,7 @@  buildPrim :: MichelinePrimitive -> Bi.Builder buildPrim (MichelinePrimitive p) = case Seq.elemIndexL p michelsonPrimitive of-  Nothing -> error "unknown Michelson/Micheline primitive"+  Nothing -> error $ "unknown Michelson/Micheline primitive: " <> p   Just ix -> buildWord8 (fromIntegral ix)  buildAnnotationSeq :: Seq Annotation -> Bi.Builder

@@ -29,8 +29,7 @@ import Fmt (Buildable(..), pretty, (+|), (|+))  import Michelson.Untyped.Annotation-  (FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag, ann, annPrefix)-import qualified Michelson.Untyped.Annotation as MUA (Annotation)+  (FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag, annPrefix, mkAnnotation) import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode)) import Tezos.Crypto (encodeBase58Check) import Util.ByteString (HexJSONByteString(..))@@ -41,23 +40,41 @@  michelsonPrimitive :: Seq Text michelsonPrimitive = Seq.fromList [+  -- NOTE: The order of this list *matters*!+  --+  -- The position of each item in the list determines which binary code it gets packed to.+  -- E.g.+  --   * "parameter" is at index 0 on the list, so it gets packed to `0x0300`+  --   * "storage" is at index 1, so it gets packed to `0x0301`+  --+  -- You can ask `tezos-client` which code corresponds to a given instruction/type/constructor.+  --+  -- > tezos-client convert data 'storage' from michelson to binary+  -- > 0x0301+  --+  -- Whenever new instructions/types/constructors are added to the protocol,+  -- we can regenerate this list using this script:+  --+  -- > ./scripts/get-micheline-exprs.sh+  --   "parameter", "storage", "code", "False", "Elt", "Left", "None", "Pair",   "Right", "Some", "True", "Unit", "PACK", "UNPACK", "BLAKE2B", "SHA256",   "SHA512", "ABS", "ADD", "AMOUNT", "AND", "BALANCE", "CAR", "CDR",-  "CHECK_SIGNATURE", "COMPARE", "CONCAT", "CONS", "CREATE_ACCOUNT",-  "CREATE_CONTRACT", "IMPLICIT_ACCOUNT", "DIP", "DROP", "DUP", "EDIV",-  "EMPTY_MAP", "EMPTY_SET", "EQ", "EXEC", "FAILWITH", "GE", "GET", "GT",-  "HASH_KEY", "IF", "IF_CONS", "IF_LEFT", "IF_NONE", "INT", "LAMBDA",-  "LE", "LEFT", "LOOP", "LSL", "LSR", "LT", "MAP", "MEM", "MUL", "NEG",-  "NEQ", "NIL", "NONE", "NOT", "NOW", "OR", "PAIR", "PUSH", "RIGHT",-  "SIZE", "SOME", "SOURCE", "SENDER", "SELF", "STEPS_TO_QUOTA", "SUB",-  "SWAP", "TRANSFER_TOKENS", "SET_DELEGATE", "UNIT", "UPDATE", "XOR",-  "ITER", "LOOP_LEFT", "ADDRESS", "CONTRACT", "ISNAT", "CAST", "RENAME",-  "bool", "contract", "int", "key", "key_hash", "lambda", "list", "map",-  "big_map", "nat", "option", "or", "pair", "set", "signature", "string",-  "bytes", "mutez", "timestamp", "unit", "operation", "address", "SLICE",-  "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID", "SHA3",-  "KECCAK", "LEVEL"+  "CHECK_SIGNATURE", "COMPARE", "CONCAT", "CONS", "CREATE_ACCOUNT", "CREATE_CONTRACT", "IMPLICIT_ACCOUNT", "DIP",+  "DROP", "DUP", "EDIV", "EMPTY_MAP", "EMPTY_SET", "EQ", "EXEC", "FAILWITH",+  "GE", "GET", "GT", "HASH_KEY", "IF", "IF_CONS", "IF_LEFT", "IF_NONE",+  "INT", "LAMBDA", "LE", "LEFT", "LOOP", "LSL", "LSR", "LT",+  "MAP", "MEM", "MUL", "NEG", "NEQ", "NIL", "NONE", "NOT",+  "NOW", "OR", "PAIR", "PUSH", "RIGHT", "SIZE", "SOME", "SOURCE",+  "SENDER", "SELF", "STEPS_TO_QUOTA", "SUB", "SWAP", "TRANSFER_TOKENS", "SET_DELEGATE", "UNIT",+  "UPDATE", "XOR", "ITER", "LOOP_LEFT", "ADDRESS", "CONTRACT", "ISNAT", "CAST",+  "RENAME", "bool", "contract", "int", "key", "key_hash", "lambda", "list",+  "map", "big_map", "nat", "option", "or", "pair", "set", "signature",+  "string", "bytes", "mutez", "timestamp", "unit", "operation", "address", "SLICE",+  "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID", "LEVEL", "SELF_ADDRESS",+  "never", "NEVER", "UNPAIR", "VOTING_POWER", "TOTAL_VOTING_POWER", "KECCAK", "SHA3", "PAIRING_CHECK",+  "bls12_381_g1", "bls12_381_g2", "bls12_381_fr", "sapling_state", "sapling_transaction", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket",+  "TICKET", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE"   ]  -- | Type for Micheline Expression@@ -117,22 +134,21 @@     , if mpaAnnots == mempty then Nothing else Just ("annots" .= mpaAnnots)     ] -annotFromText :: MonadFail m => Text -> m Annotation-annotFromText txt = case result of-    Just a -> pure a-    Nothing -> fail "Unknown annotation type"-  where-    result = (AnnotationType <$> stripPrefix @TypeTag txt)-         <|> (AnnotationVariable <$> stripPrefix @VarTag txt)-         <|> (AnnotationField <$> stripPrefix @FieldTag txt)+annotFromText :: forall m. MonadFail m => Text -> m Annotation+annotFromText txt = do+  (n, t) <-+    maybe (fail $ "Annotation '" <> toString txt <> "' is missing an annotation prefix.") pure $+      T.uncons txt+  if | toText [n] == annPrefix @TypeTag  -> handleErr $ AnnotationType <$> mkAnnotation t+     | toText [n] == annPrefix @VarTag   -> handleErr $ AnnotationVariable <$> mkAnnotation t+     | toText [n] == annPrefix @FieldTag -> handleErr $ AnnotationField <$> mkAnnotation t+     | otherwise                         -> fail $ "Unknown annotation type: " <> toString txt -stripPrefix :: forall tag . KnownAnnTag tag => Text -> Maybe (MUA.Annotation tag)-stripPrefix txt = do-  (n, t) <- T.uncons txt-  guard (toText [n] == prefix)-  Just $ ann t   where-    prefix = annPrefix @tag+    handleErr :: Either Text a -> m a+    handleErr = \case+      Left err -> fail $ "Failed to parse annotation '" <> toString txt <> "': " <> toString err+      Right a -> pure a  annotToText :: Annotation -> Text annotToText = \case

@@ -10,6 +10,7 @@   , TezosBigNum   , TezosInt64   , TezosMutez (..)+  , TezosNat   ) where  import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON)@@ -67,3 +68,15 @@   parseJSON v = do     i <- parseAsString @Int64 v     either (fail . toString) (pure . TezosMutez) $ mkMutez' i++type TezosNat = StringEncode Natural++instance Buildable TezosNat where+  build = show++instance ToJSON TezosNat where+  toJSON (StringEncode x) = Aeson.String $ show x+  toEncoding (StringEncode x) = AE.integerText $ fromIntegral x++instance FromJSON TezosNat where+  parseJSON = parseStringEncodedIntegral

@@ -190,10 +190,11 @@ oneMutez = Mutez 1  -- |--- >>> prettyTez (toMutez 420)--- "0.00042 ꜩ"--- >>> prettyTez (toMutez 42000000)--- "42 ꜩ"+-- >>> putTextLn $ prettyTez (toMutez 420)+-- 0.00042 ꜩ+--+-- >>> putTextLn $ prettyTez (toMutez 42000000)+-- 42 ꜩ prettyTez :: Mutez -> Text prettyTez ((/ 1000000) . fromIntegral . unMutez -> s) =   case floatingOrInteger s of@@ -308,7 +309,7 @@ -- signed data "in order to add extra replay protection between the main -- chain and the test chain". newtype ChainId = ChainIdUnsafe { unChainId :: ByteString }-  deriving stock (Show, Eq, Generic)+  deriving stock (Show, Eq, Ord, Generic)  instance NFData ChainId 

@@ -39,6 +39,9 @@   , Signature (..)   , KeyHashTag (..)   , KeyHash (..)+  , BLS12381.Bls12381Fr+  , BLS12381.Bls12381G1+  , BLS12381.Bls12381G2    -- * Public/secret key functions   , detSecretKey@@ -64,6 +67,7 @@   , formatKeyHash   , mformatKeyHash   , parseKeyHash+  , parseKeyHashUnsafe   , parseKeyHashRaw   , keyHashLengthBytes   , formatSecretKey@@ -88,9 +92,10 @@   ) where  import Crypto.Random (MonadRandom)-import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encoding as Aeson+import qualified Data.Aeson.Types as AesonTypes import qualified Data.Binary.Get as Get import qualified Data.ByteArray as BA import qualified Data.ByteString as BS@@ -99,6 +104,7 @@ import Fmt (Buildable, build, hexF, pretty)  import Michelson.Text+import qualified Tezos.Crypto.BLS12381 as BLS12381 import qualified Tezos.Crypto.Ed25519 as Ed25519 import Tezos.Crypto.Hash import qualified Tezos.Crypto.P256 as P256@@ -120,7 +126,7 @@   -- ^ Public key that uses the secp256k1 cryptographic curve.   | PublicKeyP256 P256.PublicKey   -- ^ Public key that uses the NIST P-256 cryptographic curve.-  deriving stock (Show, Eq, Generic)+  deriving stock (Show, Eq, Ord, Generic)  instance NFData PublicKey @@ -207,6 +213,9 @@     (SignatureP256 s1, SignatureP256 s2) -> s1 == s2     (SignatureP256 {}, _) -> False +instance Ord Signature where+  compare = compare `on` (signatureToBytes :: Signature -> ByteString)+ ---------------------------------------------------------------------------- -- Signature ----------------------------------------------------------------------------@@ -402,11 +411,19 @@   toJSON = Aeson.String . formatKeyHash   toEncoding = Aeson.text . formatKeyHash +instance ToJSONKey KeyHash where+  toJSONKey = AesonTypes.toJSONKeyText formatKeyHash+ instance FromJSON KeyHash where   parseJSON =     Aeson.withText "KeyHash" $     either (fail . pretty) pure . parseKeyHash +instance FromJSONKey KeyHash where+  fromJSONKey =+    AesonTypes.FromJSONKeyTextParser $+    either (fail . pretty) pure . parseKeyHash+ ---------------------------------------------------------------------------- -- KeyHash ----------------------------------------------------------------------------@@ -467,6 +484,9 @@     parse tag = mkKeyHash tag =<< parseImpl (keyHashTagBytes tag) pure txt    in firstRight $ map parse $ minBound :| [succ minBound ..]++parseKeyHashUnsafe :: HasCallStack => Text -> KeyHash+parseKeyHashUnsafe = either (error . pretty) id . parseKeyHash  parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash parseKeyHashRaw ba =

@@ -0,0 +1,449 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Support for BLS12-381 elliptic curve.+--+-- Some general hints on the implementation can be found in this python+-- re-implementation used by Tezos for testing:+-- <https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3>.+-- And it uses this library inside: <https://github.com/ethereum/py_ecc/tree/master/py_ecc/optimized_bls12_381>.+module Tezos.Crypto.BLS12381+  ( Bls12381Fr+  , Bls12381G1+  , Bls12381G2+  , CurveObject (..)+  , fromMichelsonBytesUnsafe+  , MultiplyPoint (..)+  , DeserializationError (..)+  , checkPairing++    -- * Playground+  , readFromHexUnsafe+  , generateFrom+  , g1One+  , g2One+  ) where++import Prelude hiding (negate, one)+import qualified Prelude++import Control.Exception (assert)+import Control.Lens (each, toListOf)+import Control.Monad.Random (MonadRandom, evalRand, getRandom, mkStdGen)+import Data.Bits (bit, complement, setBit, testBit, (.&.))+import qualified Data.ByteString as BS+import qualified Data.Curve as C+import qualified Data.Curve.Weierstrass as CW+import qualified Data.Curve.Weierstrass.BLS12381 as CW.BLS+import qualified Data.Field.Galois as GF+import qualified Data.Pairing.BLS12381 as BLS+import Fmt (Buildable(..), pretty, (+|), (|+))+import Named (arg, type (:!), (!))+import Text.Hex (decodeHex, encodeHex)+import Util.Instances ()+import Util.Named ()+import Util.Num++-- | Methods common for all BLS12-381 primitives.+class CurveObject a where+  -- | Representation of @0@, aka additive identity.+  zero :: a++  -- | Negate a value.+  negate :: a -> a++  -- | Add up two values.+  add :: a -> a -> a++  -- | Generate a random value.+  generate :: MonadRandom m => m a++  -- | Read a value from Michelson's bytes form.+  --+  -- Michelson tends to represent all BLS12-381 types in bytes form,+  -- some special types also allow other forms.+  fromMichelsonBytes :: ByteString -> Either DeserializationError a++  -- | Produce Michelson's bytes representation.+  toMichelsonBytes :: a -> ByteString++-- | Generate a random value from given seed.+generateFrom :: (CurveObject a) => Int -> a+generateFrom = evalRand generate . mkStdGen++-- | Read a value from Michelson's bytes form assuming that it is correct.+fromMichelsonBytesUnsafe :: (CurveObject a, HasCallStack) => ByteString -> a+fromMichelsonBytesUnsafe = either (error . pretty) id . fromMichelsonBytes++-- | Reads an object from hex string.+--+-- To be used only in playground and tests.+readFromHexUnsafe :: (CurveObject a, HasCallStack) => String -> a+readFromHexUnsafe hex =+  let bs = decodeHex (toText hex) ?: error "bad hex"+  in fromMichelsonBytesUnsafe bs++-- | Multiplication operations on BLS12-381 objects.+class MultiplyPoint scalar point where+  -- | Multiply point value by scalar value.+  multiply :: scalar -> point -> point++-- | G1 point on the curve.+newtype Bls12381G1 = Bls12381G1 { unBls12381G1 :: BLS.G1' }+  deriving stock (Show, Eq)+  deriving newtype (NFData)++instance CurveObject Bls12381G1 where+  zero = Bls12381G1 C.id+  negate (Bls12381G1 v) = Bls12381G1 (C.inv v)+  add (Bls12381G1 a) (Bls12381G1 b) = Bls12381G1 (C.add a b)+  generate = Bls12381G1 <$> C.rnd+  fromMichelsonBytes =+    let bsToCoord = toPrime . fromBigEndian+    in fmap Bls12381G1 . parseJA2WAPoint g1CoordLen bsToCoord+  toMichelsonBytes =+    let coordToBs = toBigEndian g1CoordLen . fromPrime+    in convertWA2JAPoint g1CoordLen coordToBs . unBls12381G1++instance MultiplyPoint Integer Bls12381G1 where+  multiply s (Bls12381G1 p) = Bls12381G1 (C.mul' p s)++-- | G2 point on the curve.+newtype Bls12381G2 = Bls12381G2 { unBls12381G2 :: BLS.G2' }+  deriving stock (Show, Eq)+  deriving newtype (NFData)++instance CurveObject Bls12381G2 where+  zero = Bls12381G2 C.id+  negate (Bls12381G2 v) = Bls12381G2 (C.inv v)+  add (Bls12381G2 a) (Bls12381G2 b) = Bls12381G2 (C.add a b)+  generate = Bls12381G2 <$> C.rnd+  fromMichelsonBytes =+    let fromBsPair = map fromBigEndian . toListOf each . BS.splitAt (g2CoordLen `div` 2)+        bsToCoord = GF.toE . reverse . map toPrime . fromBsPair+    in fmap Bls12381G2 . parseJA2WAPoint g2CoordLen bsToCoord+  toMichelsonBytes =+    let toBsPair = foldMap (toBigEndian $ g2CoordLen `div` 2)+        coordToBs = toBsPair . map fromPrime . reverse . GF.fromE+    in convertWA2JAPoint g1CoordLen coordToBs . unBls12381G2++instance MultiplyPoint Integer Bls12381G2 where+  multiply s (Bls12381G2 p) = Bls12381G2 (C.mul' p s)++-- | An element of an algebraic number field (scalar), used for multiplying+-- 'Bls12381G1' and 'Bls12381G2'.+newtype Bls12381Fr = Bls12381Fr { unBls12381Fr :: BLS.Fr }+  deriving stock (Show, Eq, Ord)+  deriving newtype (Num, Enum, Bounded, Real, Integral, Fractional, NFData)++instance CurveObject Bls12381Fr where+  zero = Bls12381Fr 0+  negate = Prelude.negate+  add = (+)+  generate = Bls12381Fr <$> getRandom+  fromMichelsonBytes bs =+    if length bs > frLen+    then Left $ TooLargeLength ! #limit frLen ! #given (length bs)+    else+      let num = fromLittleEndian bs+      in fromIntegralChecked num+           & first (\_ -> ValueOutsideOfField $ toInteger num)+  toMichelsonBytes = toLittleEndian frLen . fromPrime . unBls12381Fr++instance MultiplyPoint Bls12381Fr Bls12381G1 where+  multiply (Bls12381Fr s) (Bls12381G1 p) = Bls12381G1 (C.mul p s)++instance MultiplyPoint Bls12381Fr Bls12381G2 where+  multiply (Bls12381Fr s) (Bls12381G2 p) = Bls12381G2 (C.mul p s)++-- | Checks that product of pairings of points in the list is equal to 1 in+-- Fq12 field.+checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool+checkPairing pairs =+  -- Some hints for implementation of this function:+  -- https://gitlab.com/metastatedev/tezos/-/commit/bb2cda17d48a52ce854e027f0222a0463e0e66f0#af97cb649204420968454a94e7bfaa6a6e27195a_1285_1330+  -- https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3_0_172++  -- Monoid instance on GT' has the desired multiplicative semantics+  foldMap pairing pairs == mempty+  where+    pairing :: (Bls12381G1, Bls12381G2) -> BLS.GT'+    pairing (Bls12381G1 g1, Bls12381G2 g2) =+      BLS.finalExponentiationBLS12 BLS.parameterHex+        (BLS.millerAlgorithmBLS12 BLS.parameterBin g1 g2)++----------------------------------------------------------------------------+-- Serialization helpers+----------------------------------------------------------------------------++-- | All kinds of errors that can occur when reading a Michelson value.+data DeserializationError+  = CompressedFormIsNotSupported+  | UnexpectedLength ("expected" :! Int) ("given" :! Int)+  | TooLargeLength ("limit" :! Int) ("given" :! Int)+  | ValueOutsideOfField Integer+  | PointNotOnCurve ByteString+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance Buildable DeserializationError where+  build = \case+    CompressedFormIsNotSupported ->+      "Compressed form of BLS12-381 point is not supported by Tezos"+    UnexpectedLength (arg #expected -> expected) (arg #given -> given) ->+      "Unexpected length of BLS12-381 primitive: \+      \expected " +| expected |+ ", but given " +| given |+ ""+    TooLargeLength (arg #limit -> limit) (arg #given -> given) ->+      "Too large length of BLS12-381 primitive: \+      \limit is " +| limit |+ ", but given " +| given |+ ""+    ValueOutsideOfField v ->+      "Value is too large for the given field of values: " +| v |+ ""+    PointNotOnCurve bs ->+      "Point is not on curve: 0x" +| encodeHex bs |+ ""++{- Note on serialization:++In BLS12-381, "381" stands for the number of bits necessary to represent a+coordinate of a point on a curve, i.e. we have to use 48 bytes, getting 3 extra+bits. In the BLS12-381 library used by Tezos, those bits are exploited to carry+some meta information.++More info can be found here:+<https://github.com/zkcrypto/pairing/blob/307aa1f29dccaed09abe774d2027cad57fc5d0b4/src/bls12_381/README.md#serialization>.++So Fr is just a scalar (but a pretty big one), represented in little-endian+as said in the Michelson docs.++G1 and G2 represent a point on curve and have the following form:++      X coordinate         Y coordinate+ |!___________________|____________________|+   \  (big-endian)         (big-endian)+    \+     `- bits with meta info++Generally, various coordinate systems may be used to represent a point on curve,+and the library picked by Tezos uses Jacobian coordinates, probably assuming+that the third @Z@ coordinate is always @1@.+Note that we use 'Data.Pairing.BLS12381' which by default picks Weierstrass+coordinates (it has two, not three coordinates, and an "infinity point" which+is kept as a special case), but it also provides methods for converting between+different coordinate systems.++Coordinates take a different amount of space in G1 and G2:+* In G1 both X and Y are from a so-called "Fr" field, where numbers take+  48 bytes (without the leading 3 bits).+* In G2 both coordinates are from "Fr2" field which is a two-dimensional field+  over "Fr", i.e. X and Y themselves contain two 48-byte coordinates each.++Note that this is correct for the "uncompressed" form, and there is a different+"compressed" form that, fortunately, seems to be not supported by Michelson.+They initially planned to have @COMPRESS@ and @UNCOMPRESS@ instructions, perhaps+for manual conversions, but those instructions didn't appear in Edonet+eventually.++-}++-- | A helper datatype for representing points in raw bytes form.+data RawPoint+  = Infinity+    -- ^ Point at infinity.+  | RawPoint ByteString+    -- ^ Bytes representing the payload.++-- | Given the Michelson representation of a point, interpret flags+-- and return the bare payload.+--+-- This assumes that a proper number of bytes is provided.+parsePointFlags+  :: HasCallStack+  => ByteString -> Either DeserializationError RawPoint+parsePointFlags bsFull =+  case BS.uncons bsFull of+    Nothing -> error "Empty byte sequence"+    Just (b, bs)+      | b `testBit` compressionBit ->+          Left CompressedFormIsNotSupported+      | b `testBit` infinityBit ->+          return Infinity+      | otherwise -> do+          let+            b' = b .&. complement+              (sum $ map bit [compressionBit, infinityBit, flag3Bit])+          return $ RawPoint (BS.cons b' bs)++-- | Fill a point in raw bytes form with the necessary flags.+fillPointFlags :: HasCallStack => Int -> RawPoint -> ByteString+fillPointFlags 0 = error "Coordinates are unexpectedly empty"+fillPointFlags len = \case+  Infinity -> BS.cons (0 `setBit` infinityBit) (BS.replicate (len - 1) 0)+  RawPoint bs -> bs++-- | Get a bytestring containing coordinates of a point and split it,+-- checking that each coordinate occupies the given number of bytes.+splitUncompressedPoint+  :: Int -> ByteString -> Either DeserializationError (ByteString, ByteString)+splitUncompressedPoint coordLen bs+  | length bs /= coordLen * 2 =+      Left $ UnexpectedLength ! #expected (coordLen * 2) ! #given (length bs)+  | otherwise =+      Right $ BS.splitAt coordLen bs++-- | Parse a point in Weierstrass form and Affine coordinates,+-- assuming that in the provided bytestring the point is given in Jacobian+-- coordinates (the library used by Tezos operates in Jacobian coordinates).+parseJA2WAPoint+  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr+     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr+     )+  => Int+  -> (ByteString -> fq)+  -> ByteString+  -> Either DeserializationError (CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr)+parseJA2WAPoint coordLen toCoord full = do+  (xRawWithFlags, yRaw) <- splitUncompressedPoint coordLen full+  xRawPoint <- parsePointFlags xRawWithFlags+  case xRawPoint of+    Infinity -> return CW.O+    RawPoint xRaw ->+      let point = C.toA $ CW.J (toCoord xRaw) (toCoord yRaw) 1+      in if C.def point+         then return point+         else Left $ PointNotOnCurve full++-- | Turn a Weierstrass Affine point into Jacobian coordinates and represent+-- those as bytes.+convertWA2JAPoint+  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr+     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr+     )+  => Int+  -> (fq -> ByteString)+  -> CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr+  -> ByteString+convertWA2JAPoint coordLen toRawCoord point =+  let+    rawPoint = case point of+      CW.O -> Infinity+      p@CW.A{} -> RawPoint $+        let CW.J x y z = C.fromA p+           -- Conversion from Affine coordinates used to produce an already+           -- normalized value.+           -- In case this turns out to be incorrect, probably @x / z@ and @y / z@+           -- are just what we want.+        in assert (z == 1) $+            toRawCoord x <> toRawCoord y+  in fillPointFlags (coordLen * 2) rawPoint++-- | Interpret a byte sequence as a number in big-endian.+fromBigEndian :: ByteString -> Natural+fromBigEndian bs =+  foldl' (\acc byte -> acc * 0x100 + fromIntegral @Word8 @Natural byte) 0 $+  BS.unpack bs++-- | Interpret a byte sequence as a number in little-endian.+fromLittleEndian :: ByteString -> Natural+fromLittleEndian bs =+  sum . zipWith (*) (iterate (* 0x100) 1) . map (fromIntegral @Word8 @Natural) $+  BS.unpack bs++-- | Represent a number in a big-endian byte sequence, padding the output+-- to the expected length.+--+-- We assert that the length is sufficient for representing the given number.+toBigEndian :: Int -> Natural -> ByteString+toBigEndian len num =+  BS.pack $+  let+    (remainder, bytes) = mapAccumR+      (\x _ -> second (fromIntegral @Natural @Word8) $ x `divMod` 0x100)+      num [1 .. len]+  in assert (remainder == 0) bytes++-- | Represent a number in a little-endian byte sequence, padding the output+-- to the expected length.+--+-- We assert that the length is sufficient for representing the given number.+toLittleEndian :: Int -> Natural -> ByteString+toLittleEndian len num =+  BS.pack $+  let+    (remainder, bytes) = mapAccumL+      (\x _ -> second (fromIntegral @Natural @Word8) $ x `divMod` 0x100)+      num [1 .. len]+  in assert (remainder == 0) bytes++-- | Turn a prime field element into a natural.+fromPrime :: KnownNat p => GF.Prime p -> Natural+fromPrime p =+  -- This should be safe, since 'Prime's exist in modular arithmetics,+  -- so its conversion to an integer should produce non-negative elements.+  -- In fact, 'GF.Prime' is a newtype wrapper over 'Natural', but+  -- its constructor is not exported :/+  assert (p >= 0) $+    fromIntegral p++-- | The inverse to 'fromPrime'.+toPrime :: KnownNat p => Natural -> GF.Prime p+toPrime = fromIntegral++-- Primitives' lengths+----------------------------------------------------------------------------++-- | Length of a single coordinate of a point in raw bytes form.+g1CoordLen, g2CoordLen :: Int+g1CoordLen = 48+g2CoordLen = 96  -- each coordinate is an element of two-dimensional field Fr2++-- | Length of 'Fr' in raw bytes form.+frLen :: Int+frLen = 32++-- Meta bits+----------------------------------------------------------------------------++-- | This bit designates whether the point is represented in compressed form+-- (only X coordinate), or uncompressed form (both X and Y coordinates).+compressionBit :: Int+compressionBit = 7++-- | This bit designates whether the given point is at infinity.+--+-- If so, all other bytes should be zeros.+infinityBit :: Int+infinityBit = 6++-- | This bit is set iff "this point is in compressed form /and/ it is not the+-- point at infinity /and/ its y-coordinate is the lexicographically largest of+-- the two associated with the encoded x-coordinate".+--+-- Fortunatelly, this flag seems to be not relevant for us at the moment.+flag3Bit :: Int+flag3Bit = 5++----------------------------------------------------------------------------+-- Other constants+----------------------------------------------------------------------------++-- | @1@ represented in G1 - as the libraries used by Tezos see it.+--+-- Taken from here: <https://github.com/ethereum/py_ecc/blob/3f644b4c07c8270b8fbe989eb799766aca66face/py_ecc/optimized_bls12_381/optimized_curve.py#L34>.+g1One :: Bls12381G1+g1One = Bls12381G1 $ CW.toA $ CW.J+  3685416753713387016781088315183077757961620795782546409894578378688607592378376318836054947676345821548104185464507+  1339506544944476473020471379941921221584933875938349620426543736416511423956333506472724655353366534992391756441569+  1++-- | @1@ represented in G2.+g2One :: Bls12381G2+g2One = Bls12381G2 $ CW.toA $ CW.J+  (GF.toE+    [ 352701069587466618187139116011060144890029952792775240219908644239793785735715026873347600343865175952761926303160+    , 3059144344244213709971259814753781636986470325476647558659373206291635324768958432433509563104347017837885763365758+    ])+  (GF.toE+    [ 1985150602287291935568054521177171638300868978215655730859378665066344726373823718423869104263333984641494340347905+    , 927553665492332455747201965776037880757740193453592970025027978793976877002675564980949289727957565575433344219582+    ])+  (GF.toE [1, 0])

@@ -55,6 +55,9 @@  instance NFData PublicKey +instance Ord PublicKey where+  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)+ -- | ED25519 secret cryptographic key. newtype SecretKey = SecretKey   { unSecretKey :: Ed25519.SecretKey

@@ -63,6 +63,9 @@   rnf (PublicKey (ECDSA.PublicKey cu q))     = rnfCurve cu `seq` rnf q +instance Ord PublicKey where+  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)+ -- | P256 secret cryptographic key. newtype SecretKey = SecretKey   { unSecretKey :: ECDSA.KeyPair

@@ -63,6 +63,9 @@   rnf (PublicKey (ECDSA.PublicKey cu q))     = rnfCurve cu `seq` rnf q +instance Ord PublicKey where+  compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)+ -- | Secp256k1 secret cryptographic key. newtype SecretKey = SecretKey   { unSecretKey :: ECDSA.KeyPair

@@ -77,6 +77,9 @@ instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where   build (ArgF a) = build (symbolVal (Proxy @name)) <> ": " <> build a +instance (NFData (f a)) => NFData (NamedF f a name) where+  rnf (ArgF a) = rnf a+ deriving stock instance   (Typeable f, Typeable a, KnownSymbol name, Data (f a)) =>   Data (NamedF f a name)

@@ -27,9 +27,15 @@   , FromPeano   , KnownPeano (..)   , SingNat (SZ, SS)+  , Decrement+  , type (>)   , peanoVal'   , peanoValSing+  , peanoSing +  -- * Peano Arithmetic+  , type (>=)+   -- * Lists   , Length   , At@@ -55,7 +61,7 @@ import Data.Vinyl.TypeLevel (Nat(..), RLength) import GHC.TypeLits (ErrorMessage(..), TypeError) import GHC.TypeNats (type (+), type (-))-import qualified GHC.TypeNats as GHC (Nat)+import qualified GHC.TypeNats as GHC import Unsafe.Coerce (unsafeCoerce)  import Util.Type@@ -93,6 +99,13 @@ peanoValSing :: forall n. KnownPeano n => Sing n -> Natural peanoValSing _ = peanoVal' @n +-- | Get the peano singleton for a given type-level nat literal.+--+-- >>> peanoSing @2+-- SS (SS SZ)+peanoSing :: forall (n :: GHC.Nat). SingI (ToPeano n) => SingNat (ToPeano n)+peanoSing = sing @(ToPeano n)+ instance KnownPeano a => MockableConstraint (KnownPeano a) where   provideConstraintUnsafe = Dict @@ -114,6 +127,24 @@   sing = SS (sing @n)  ----------------------------------------------------------------------------+-- Peano Arithmetic+----------------------------------------------------------------------------++type family Decrement (a :: Peano) :: Peano where+  Decrement 'Z = TypeError ('Text "Expected n > 0")+  Decrement ('S n) = n++type family (>) (x :: Peano) (y :: Peano) :: Bool where+  'Z   > _    = 'False+  'S _ > 'Z   = 'True+  'S x > 'S y = x > y++type family (>=) (x :: Peano) (y :: Peano) :: Bool where+  _      >= 'Z     = 'True+  'Z     >= _      = 'False+  ('S x) >= ('S y) = x >= y++---------------------------------------------------------------------------- -- Lists ---------------------------------------------------------------------------- @@ -125,7 +156,7 @@   At ('S n) (_ ': xs) = At n xs   At a '[] =     TypeError-      ('Text "You try to access to non-existing element of the stack, n = " ':<>:+      ('Text "You tried to access a non-existing element of the stack, n = " ':<>:          'ShowType (FromPeano a))  type family Drop (n :: Peano) (s :: [k]) :: [k] where

@@ -79,7 +79,7 @@ -- | Fail with given error if the condition holds. type FailWhen cond msg = FailUnless (Not cond) msg --- | A natural conclusion from the fact that error have not occured.+-- | A natural conclusion from the fact that an error has not occurred. failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True) failUnlessEvi = Sub provideConstraintUnsafe 

@@ -17,14 +17,10 @@   , ErrorMessage (..)    , TypeErrorUnless-  , inTypeErrorUnless   ) where -import Data.Constraint ((\\)) import GHC.TypeLits -import Util.Type- symbolValT :: forall s. KnownSymbol s => Proxy s -> Text symbolValT = toText . symbolVal @@ -33,18 +29,57 @@  -- | Conditional type error. ----- Note that @TypeErrorUnless cond err@ is the same as--- @If cond () (TypeError err)@, but does not produce type-level error when--- one of its arguments cannot be deduced.-type family TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) :: Constraint where-  TypeErrorUnless 'True _ = ()-  TypeErrorUnless 'False err = TypeError err+-- There is a very subtle difference between 'TypeErrorUnless' and the following type family:+--+-- > type family TypeErrorUnlessAlternative (cond :: Bool) (err :: ErrorMessage) :: Constraint where+-- >   TypeErrorUnlessAlternative cond err =+-- >     ( If cond+-- >         (() :: Constraint)+-- >         (TypeError err)+-- >     , cond ~ 'True+-- >     )+--+-- If @cond@ cannot be fully reduced (e.g. it's a stuck type family), then:+--+-- * @TypeErrorUnless@ will state that the constraint cannot be deduced.+-- * @TypeErrorUnlessAlternative@ will fail with the given error message @err@.+--+-- For example:+--+-- > -- Partial function+-- > type family IsZero (n :: Peano) :: Bool where+-- >   IsZero ('S _) = 'False+-- >+-- > f1 :: TypeErrorUnless (IsZero n) ('Text "Expected zero") => ()+-- > f1 = ()+-- >+-- > f2 :: TypeErrorUnlessAlternative (IsZero n) ('Text "Expected zero") => ()+-- > f2 = ()+-- >+-- >+-- > f1res = f1 @'Z+-- > -- • Couldn't match type ‘IsZero 'Z’ with ‘'True’+-- >+-- > f2res = f2 @'Z+-- > -- • Expected zero+--+-- As you can see, the error message in @f2res@ is misleading (because the type argument+-- actually _is_ zero), so it's preferable to fail with the standard GHC error message.+type TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) =+  ( TypeErrorUnlessHelper cond err+  -- Note: the '~' constraint below might seem redundant, but, without it,+  -- GHC would warn that the following pattern match is not exhaustive (even though it is):+  --+  -- > f :: TypeErrorUnless (n >= ToPeano 2) "some err msg" => Sing n -> ()+  -- > f = \case+  -- >   SS (SS SZ) -> ()+  -- >   SS (SS _) -> ()+  --+  -- GHC needs to "see" the type equality '~' in order to actually "learn" something from a+  -- type family's result.+  , cond ~ 'True+  ) --- | Reify the fact that condition under 'TypeErrorUnless' constraint can be--- assumed to always hold.-inTypeErrorUnless-  :: forall cond err a.-      TypeErrorUnless cond err-  => (cond ~ 'True => a)-  -> a-inTypeErrorUnless a = a \\ provideConstraintUnsafe @(cond ~ 'True)+type family TypeErrorUnlessHelper (cond :: Bool) (err :: ErrorMessage) :: Constraint where+  TypeErrorUnlessHelper 'True _ = ()+  TypeErrorUnlessHelper 'False err = TypeError err