packages feed

morley 1.1.0 → 1.2.0

raw patch · 95 files changed

+2764/−2449 lines, 95 filesdep +aeson-casingdep −aeson-options

Dependencies added: aeson-casing

Dependencies removed: aeson-options

Files

CHANGES.md view
@@ -2,8 +2,27 @@ ========== <!-- Append new entries here --> +1.2.0+=====+* [!343](https://gitlab.com/morley-framework/morley/-/merge_requests/343)+  + Make pairs comparable and available to use as map keys and in sets.+  + CT type has been integrated into T.+  + A `WellTyped` type class has been added to ensure that a type+    represented by  T is valid as per Michelson's rules.+* [!358](https://gitlab.com/morley-framework/morley/-/merge_requests/358)+  Remove deprecated `STEPS_TO_QUOTA` instruction.+* [!368](https://gitlab.com/morley-framework/morley/-/merge_requests/368)+  + Update JSON encoding of types.+  + Rename fields of the untyped `Contract'`.+* [!286](https://gitlab.com/morley-framework/morley/-/merge_requests/286)+  Morley supports field annotations for parameter root now.+* [!344](https://gitlab.com/morley-framework/morley/-/merge_requests/344)+  Fixed a bug in `Michelson.Analyzer` and added `linearizeLeftDeep`.+ 1.1.0 =====+* [!337](https://gitlab.com/morley-framework/morley/-/merge_requests/337)+  Added an extension for Michelson comment to typed and untyped contract representation. * [!306](https://gitlab.com/morley-framework/morley/-/merge_requests/306)   Added PAIR/UNPAIR rule to optimizer. * [!314](https://gitlab.com/morley-framework/morley/-/merge_requests/314)
app/Main.hs view
@@ -4,7 +4,7 @@  import Data.Version (showVersion) import Fmt (pretty)-import Named ((:!), (:?), arg, argF, (!))+import Named (arg, argF, (!)) import Options.Applicative   (command, execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long,   progDesc, short, subparser, switch)
bench/Main.hs view
@@ -38,7 +38,7 @@   let     basicBench = bench basicFp       (nf-        (interpret (T.fcCode basicC) T.epcPrimitive T.VUnit (T.VList [T.VC (T.CvInt 0)]))+        (interpret (T.fcCode basicC) T.epcPrimitive T.VUnit (T.VList [T.VInt 0]))         dummyContractEnv       )
morley.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c1daa2d2e51ff7183ee4cf60a81aeda135b69cb2410f30184efbebe64c69710c+-- hash: 987d0620d3775b492e6130748d155b4aa4f41a8fc5e517837f3d0de73f0b85ed  name:           morley-version:        1.1.0+version:        1.2.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@@ -80,7 +80,6 @@       Michelson.Typed.Annotation       Michelson.Typed.Arith       Michelson.Typed.Convert-      Michelson.Typed.CValue       Michelson.Typed.Doc       Michelson.Typed.EntryPoints       Michelson.Typed.Extract@@ -118,6 +117,7 @@       Tezos.Crypto.P256       Tezos.Crypto.Secp256k1       Tezos.Crypto.Util+      Util.Aeson       Util.Alternative       Util.ByteString       Util.CLI@@ -148,13 +148,13 @@       Paths_morley   hs-source-dirs:       src-  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude   build-depends:       HUnit     , QuickCheck     , aeson-    , aeson-options+    , aeson-casing     , aeson-pretty     , base-noprelude >=4.7 && <5     , base16-bytestring@@ -213,7 +213,7 @@       Paths_morley   hs-source-dirs:       app-  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude   build-depends:       base-noprelude >=4.7 && <5@@ -230,7 +230,6 @@   main-is: Main.hs   other-modules:       Test.Analyzer-      Test.CValConversion       Test.EntryPoints       Test.Ext       Test.Integrational@@ -239,6 +238,7 @@       Test.Interpreter.Auction       Test.Interpreter.Balance       Test.Interpreter.CallSelf+      Test.Interpreter.ComparableSet       Test.Interpreter.Compare       Test.Interpreter.ComparePairs       Test.Interpreter.Conditionals@@ -273,7 +273,7 @@       Paths_morley   hs-source-dirs:       test-  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns DerivingStrategies+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns DerivingStrategies   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -with-rtsopts=-N   build-tool-depends:       tasty-discover:tasty-discover@@ -315,7 +315,7 @@       Paths_morley   hs-source-dirs:       bench-  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude   build-depends:       base-noprelude >=4.7 && <5
src/Michelson/Analyzer.hs view
@@ -89,7 +89,7 @@ -- because it's easier to analyze. It means that we can't analyze -- ill-typed contracts, but hopefully it's not a serious limitation. analyze :: Instr inp out -> AnalyzerRes-analyze = dfsFoldInstr def{ dsGoToValues = True } step+analyze = dfsFoldInstr def{ dsGoToValues = True } step . linearizeLeftDeep   where     step :: forall i o. Instr i o -> AnalyzerRes     step i = analyzeConstants i <> analyzeErrorTags i
src/Michelson/ErrorPos.hs view
@@ -8,11 +8,13 @@   , LetName (..)   ) where -import qualified Data.Aeson as Aeson+import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import Data.Default (Default(..)) import qualified Data.Text as T +import Util.Aeson+ newtype Pos = Pos Word   deriving stock (Eq, Ord, Show, Generic, Data) @@ -53,11 +55,7 @@ instance Default InstrCallStack where   def = InstrCallStack def def -instance Aeson.ToJSON  Pos-instance Aeson.FromJSON Pos-instance Aeson.ToJSON SrcPos-instance Aeson.FromJSON SrcPos-instance Aeson.ToJSON LetName-instance Aeson.FromJSON LetName-instance Aeson.ToJSON InstrCallStack-instance Aeson.FromJSON InstrCallStack+deriveJSON morleyAesonOptions ''Pos+deriveJSON morleyAesonOptions ''SrcPos+deriveJSON morleyAesonOptions ''LetName+deriveJSON morleyAesonOptions ''InstrCallStack
src/Michelson/FailPattern.hs view
@@ -9,8 +9,6 @@   , ConstantScope'   ) where -import Data.Singletons (sing)- import Michelson.Text (MText) import Michelson.Typed @@ -41,15 +39,13 @@ -- | Check whether given instruction ends with a typical 'FAILWITH' -- usage. It does not recursively check instructions that can be -- passed to other instructions.+--+-- The instruction MUST be linearized to the left (see 'linearizeLeft'). isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith-isTypicalFailWith = isTypicalFailWith' . linearizeLeft+isTypicalFailWith = \case+  Seq i1 FAILWITH -> isTypicalPreFailWith i1+  _ -> Nothing   where-    isTypicalFailWith' :: Instr inp out -> Maybe TypicalFailWith-    isTypicalFailWith' =-      \case-        Seq i1 FAILWITH -> isTypicalPreFailWith i1-        _ -> Nothing-     isTypicalPreFailWith ::       Instr inp (a ': out) -> Maybe TypicalFailWith     isTypicalPreFailWith =@@ -66,7 +62,7 @@   forall t. ConstantScope t => Value t -> Maybe TypicalFailWith isTypicalErrorConstant v   | Just str <- isStringValue v = Just (FailWithString str)-  | VPair (VC (CvString str), secondItem) <- v =+  | VPair (VString str, secondItem) <- v =       -- We need to pattern match to deduce `singI` for second item of the pair.       case sing @t of         STPair {} -> Just (FailWithConstantPair str (SomeConstrainedValue secondItem))
src/Michelson/Interpret.hs view
@@ -36,24 +36,22 @@ import Data.Default (Default(..)) import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Singletons (SingI(..))-import Data.Typeable ((:~:)(..))+import Data.Singletons (Sing) import Data.Vinyl (Rec(..), (<+>)) import Fmt (Buildable(build), Builder, genericF, pretty)  import Michelson.Interpret.Pack (packValue') import Michelson.Interpret.Unpack (UnpackError, unpackValue') import Michelson.TypeCheck-  (SomeContract(..), TCError, TcOriginatedContracts, matchTypes, runTypeCheck,-  typeCheckContract, typeCheckValue)+  (SomeContract(..), TCError, TcOriginatedContracts, matchTypes, runTypeCheck, typeCheckContract,+  typeCheckValue) import Michelson.Typed import qualified Michelson.Typed as T-import Michelson.Typed.Convert (convertContractCode, untypeValue) import qualified Michelson.Untyped as U import Tezos.Address (Address(..)) import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512)-import Util.Peano (LongerThan, Peano, Sing(SS, SZ))+import Util.Peano (LongerThan, Peano, SingNat(SS, SZ)) import Util.TH import Util.Type import Util.Typeable@@ -85,7 +83,9 @@ -- value that was on top of the stack when `FAILWITH` was called. data MichelsonFailed where   MichelsonFailedWith :: (Typeable t, SingI t) => T.Value t -> MichelsonFailed-  MichelsonArithError :: (Typeable n, Typeable m) => ArithError (CValue n) (CValue m) -> MichelsonFailed+  MichelsonArithError+    :: (Typeable n, Typeable m, Typeable instr)+    => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed   MichelsonGasExhaustion :: MichelsonFailed   MichelsonFailedTestAssert :: Text -> MichelsonFailed   MichelsonAmbigousEpRef :: EpName -> EpAddress -> MichelsonFailed@@ -118,7 +118,7 @@         "Ambigous entrypoint reference. `CONTRACT %" <> build instrEp <> "` \         \called over address " <> build epAddr     where-      formatValue :: forall t . SingI t => Value' Instr t -> Builder+      formatValue :: forall t . SingI t => Value t -> Builder       formatValue v =         case T.checkOpPresence (sing @t) of           OpPresent -> "<value with operations>"@@ -185,12 +185,15 @@   -- Do creates dummy scope to somehow overcome this:   -- GHC internal error: ‘st’ is not in scope during type checking, but it passed the renamer.   do-    paramV-        <- first IllTypedParam $ runTypeCheck para (ceContracts env) $ usingReaderT def $-             typeCheckValue @cp paramU-    initStV-        <- first IllTypedStorage $ runTypeCheck para (ceContracts env) $ usingReaderT def $-             typeCheckValue @st initStU+    let+      runTC :: forall t. SingI t => U.Value -> Either TCError (Value t)+      runTC =+        runTypeCheck contractParameter (ceContracts env) .+        usingReaderT def .+        typeCheckValue @t++    paramV <- first IllTypedParam $ runTC @cp paramU+    initStV <- first IllTypedStorage $ runTC @st initStU     handleContractReturn $       interpret instr epcCallRootUnsafe paramV initStV env @@ -376,7 +379,7 @@ runInstrImpl _ CONS (a :& VList l :& r) = pure $ VList (a : l) :& r runInstrImpl runner (IF_CONS _ bNil) (VList [] :& r) = runner bNil r runInstrImpl runner (IF_CONS bCons _) (VList (lh : lr) :& r) = runner bCons (lh :& VList lr :& r)-runInstrImpl _ SIZE (a :& r) = pure $ VC (CvNat $ (fromInteger . toInteger) $ evalSize a) :& r+runInstrImpl _ SIZE (a :& r) = pure $ (VNat $ (fromInteger . toInteger) $ evalSize a) :& r runInstrImpl _ EMPTY_SET r = pure $ VSet Set.empty :& r runInstrImpl _ EMPTY_MAP r = pure $ VMap Map.empty :& r runInstrImpl _ EMPTY_BIG_MAP r = pure $ VBigMap Map.empty :& r@@ -398,13 +401,13 @@           res <- runner code (x :& r)           runner (ITER code) (xs :& res)         (Nothing, _) -> pure r-runInstrImpl _ MEM (VC a :& b :& r) = pure $ VC (CvBool (evalMem a b)) :& r-runInstrImpl _ GET (VC a :& b :& r) = pure $ VOption (evalGet a b) :& r-runInstrImpl _ UPDATE (VC a :& b :& c :& r) = pure $ evalUpd a b c :& r-runInstrImpl runner (IF bTrue _) (VC (CvBool True) :& r) = runner bTrue r-runInstrImpl runner (IF _ bFalse) (VC (CvBool False) :& r) = runner bFalse r-runInstrImpl _ (LOOP _) (VC (CvBool False) :& r) = pure $ r-runInstrImpl runner (LOOP ops) (VC (CvBool True) :& r) = do+runInstrImpl _ MEM (a :& b :& r) = pure $ (VBool (evalMem a b)) :& r+runInstrImpl _ GET (a :& b :& r) = pure $ VOption (evalGet a b) :& r+runInstrImpl _ UPDATE (a :& b :& c :& r) = pure $ evalUpd a b c :& r+runInstrImpl runner (IF bTrue _) (VBool True :& r) = runner bTrue r+runInstrImpl runner (IF _ bFalse) (VBool False :& r) = runner bFalse r+runInstrImpl _ (LOOP _) (VBool False :& r) = pure $ r+runInstrImpl runner (LOOP ops) (VBool True :& r) = do   res <- runner ops r   runner (LOOP ops) res runInstrImpl _ (LOOP_LEFT _) (VOr (Right a) :&r) = pure $ a :& r@@ -431,44 +434,44 @@ runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith a runInstrImpl _ CAST (a :& r) = pure $ a :& r runInstrImpl _ RENAME (a :& r) = pure $ a :& r-runInstrImpl _ PACK (a :& r) = pure $ (VC $ CvBytes $ packValue' a) :& r-runInstrImpl _ UNPACK (VC (CvBytes a) :& r) =+runInstrImpl _ PACK (a :& r) = pure $ (VBytes $ packValue' a) :& r+runInstrImpl _ UNPACK (VBytes a :& r) =   pure $ (VOption . rightToMaybe $ runUnpack a) :& r runInstrImpl _ CONCAT (a :& b :& r) = pure $ evalConcat a b :& r runInstrImpl _ CONCAT' (VList a :& r) = pure $ evalConcat' a :& r-runInstrImpl _ SLICE (VC (CvNat o) :& VC (CvNat l) :& s :& r) =+runInstrImpl _ SLICE (VNat o :& VNat l :& s :& r) =   pure $ VOption (evalSlice o l s) :& r-runInstrImpl _ ISNAT (VC (CvInt i) :& r) =+runInstrImpl _ ISNAT (VInt i :& r) =   if i < 0   then pure $ VOption Nothing :& r-  else pure $ VOption (Just $ VC (CvNat $ fromInteger i)) :& r-runInstrImpl _ ADD (VC l :& VC r :& rest) =+  else pure $ VOption (Just (VNat $ fromInteger i)) :& r+runInstrImpl _ ADD (l :& r :& rest) =   (:& rest) <$> runArithOp (Proxy @Add) l r-runInstrImpl _ SUB (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r-runInstrImpl _ MUL (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r-runInstrImpl _ EDIV (VC l :& VC r :& rest) = pure $ evalEDivOp l r :& rest-runInstrImpl _ ABS (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Abs) a) :& rest-runInstrImpl _ NEG (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Neg) a) :& rest-runInstrImpl _ LSL (VC x :& VC s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s-runInstrImpl _ LSR (VC x :& VC s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s-runInstrImpl _ OR (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r-runInstrImpl _ AND (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r-runInstrImpl _ XOR (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r-runInstrImpl _ NOT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Not) a) :& rest-runInstrImpl _ COMPARE (l :& r :& rest) = pure $ T.VC (T.CvInt (compareOp l r)) :& rest-runInstrImpl _ EQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Eq') a) :& rest-runInstrImpl _ NEQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Neq) a) :& rest-runInstrImpl _ LT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Lt) a) :& rest-runInstrImpl _ GT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Gt) a) :& rest-runInstrImpl _ LE (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Le) a) :& rest-runInstrImpl _ GE (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Ge) a) :& rest-runInstrImpl _ INT (VC (CvNat n) :& r) = pure $ VC (CvInt $ toInteger n) :& r+runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r+runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r+runInstrImpl _ EDIV (l :& r :& rest) = pure $ evalEDivOp l r :& rest+runInstrImpl _ ABS (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Abs) a) :& rest+runInstrImpl _ NEG (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Neg) a) :& rest+runInstrImpl _ LSL (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s+runInstrImpl _ LSR (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s+runInstrImpl _ OR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r+runInstrImpl _ AND (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r+runInstrImpl _ XOR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r+runInstrImpl _ NOT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Not) a) :& rest+runInstrImpl _ COMPARE (l :& r :& rest) = pure $ (T.VInt (compareOp l r)) :& rest+runInstrImpl _ EQ (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Eq') a) :& rest+runInstrImpl _ NEQ (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Neq) a) :& rest+runInstrImpl _ LT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Lt) a) :& rest+runInstrImpl _ GT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Gt) a) :& rest+runInstrImpl _ LE (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Le) a) :& rest+runInstrImpl _ GE (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Ge) a) :& rest+runInstrImpl _ INT (VNat n :& r) = pure $ (VInt $ toInteger n) :& r runInstrImpl _ (SELF sepc :: Instr inp out) r = do   ContractEnv{..} <- ask   case Proxy @out of     (_ :: Proxy ('TContract cp ': s)) -> do       pure $ VContract ceSelf sepc :& r-runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (VC (CvAddress epAddr) :& r) = do+runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (VAddress epAddr :& r) = do   ContractEnv{..} <- ask   let T.EpAddress addr addrEpName = epAddr   epName <- case (instrEpName, addrEpName) of@@ -484,9 +487,10 @@       case Map.lookup ca ceContracts of         -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has         -- valid parameter type. Should be not necessary after [#36].-        Just tc@(AsUTypeExt tcSing (ParamNotesUnsafe -> tcNotes)) ->-          case (T.checkOpPresence tcSing, T.checkNestedBigMapsPresence tcSing) of-            (OpAbsent, NestedBigMapsAbsent) -> castContract addr epName tcNotes :& r+        Just tc@(U.ParameterType (AsUTypeExt (_ :: Sing tc) tcNotes) rootAnn) ->+          let paramNotes = ParamNotesUnsafe tcNotes rootAnn in+          case T.checkScope @(T.ParameterScope tc) of+            Right Dict -> castContract addr epName paramNotes :& r             _ -> error $ "Illegal type in parameter of env contract: " <> pretty tc             -- TODO [#36]: we can do this safely once 'TcOriginatedContracts' stores             -- typed stuff.@@ -501,50 +505,47 @@     Right (Refl, _) <- pure $ matchTypes nt na     return $ VContract addr (T.SomeEpc epc) -runInstrImpl _ TRANSFER_TOKENS (p :& VC (CvMutez mutez) :& contract :& r) =+runInstrImpl _ TRANSFER_TOKENS (p :& VMutez mutez :& contract :& r) =   pure $ VOp (OpTransferTokens $ TransferTokens p mutez contract) :& r runInstrImpl _ SET_DELEGATE (VOption mbKeyHash :& r) =   case mbKeyHash of-    Just (VC (CvKeyHash k)) -> pure $ VOp (OpSetDelegate $ SetDelegate $ Just k) :& r+    Just (VKeyHash k) -> pure $ VOp (OpSetDelegate $ SetDelegate $ Just k) :& r     Nothing -> pure $ VOp (OpSetDelegate $ SetDelegate $ Nothing) :& r runInstrImpl _ (CREATE_CONTRACT fullContract)-  (VOption mbKeyHash :& (VC (CvMutez m)) :& g :& r) = do+  (VOption mbKeyHash :& VMutez m :& g :& r) = do   originator <- ceSelf <$> ask   let ops = fcCode fullContract   let resAddr = U.mkContractAddress $ createOrigOp originator mbKeyHash m ops g   let resEpAddr = EpAddress resAddr def   let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops   pure $ VOp (OpCreateContract resOp)-      :& (VC (CvAddress resEpAddr))+      :& (VAddress resEpAddr)       :& r-runInstrImpl _ IMPLICIT_ACCOUNT (VC (CvKeyHash k) :& r) =+runInstrImpl _ IMPLICIT_ACCOUNT (VKeyHash k :& r) =   pure $ VContract (KeyAddress k) sepcPrimitive :& r runInstrImpl _ NOW r = do   ContractEnv{..} <- ask-  pure $ VC (CvTimestamp ceNow) :& r+  pure $ (VTimestamp ceNow) :& r runInstrImpl _ AMOUNT r = do   ContractEnv{..} <- ask-  pure $ VC (CvMutez ceAmount) :& r+  pure $ (VMutez ceAmount) :& r runInstrImpl _ BALANCE r = do   ContractEnv{..} <- ask-  pure $ VC (CvMutez ceBalance) :& r+  pure $ (VMutez ceBalance) :& r runInstrImpl _ CHECK_SIGNATURE (VKey k :& VSignature v :&-  VC (CvBytes b) :& r) = pure $ VC (CvBool $ checkSignature k v b) :& r-runInstrImpl _ SHA256 (VC (CvBytes b) :& r) = pure $ VC (CvBytes $ sha256 b) :& r-runInstrImpl _ SHA512 (VC (CvBytes b) :& r) = pure $ VC (CvBytes $ sha512 b) :& r-runInstrImpl _ BLAKE2B (VC (CvBytes b) :& r) = pure $ VC (CvBytes $ blake2b b) :& r-runInstrImpl _ HASH_KEY (VKey k :& r) = pure $ VC (CvKeyHash $ hashKey k) :& r-runInstrImpl _ STEPS_TO_QUOTA r = do-  RemainingSteps x <- gets isRemainingSteps-  pure $ VC (CvNat $ (fromInteger . toInteger) x) :& r+  VBytes b :& r) = pure $ (VBool $ checkSignature k v b) :& r+runInstrImpl _ SHA256 (VBytes b :& r) = pure $ (VBytes $ sha256 b) :& r+runInstrImpl _ SHA512 (VBytes b :& r) = pure $ (VBytes $ sha512 b) :& r+runInstrImpl _ BLAKE2B (VBytes b :& r) = pure $ (VBytes $ blake2b b) :& r+runInstrImpl _ HASH_KEY (VKey k :& r) = pure $ (VKeyHash $ hashKey k) :& r runInstrImpl _ SOURCE r = do   ContractEnv{..} <- ask-  pure $ VC (CvAddress $ EpAddress ceSource def) :& r+  pure $ (VAddress $ EpAddress ceSource def) :& r runInstrImpl _ SENDER r = do   ContractEnv{..} <- ask-  pure $ VC (CvAddress $ EpAddress ceSender def) :& r+  pure $ (VAddress $ EpAddress ceSender def) :& r runInstrImpl _ ADDRESS (VContract a sepc :& r) =-  pure $ VC (CvAddress $ EpAddress a (sepcName sepc)) :& r+  pure $ (VAddress $ EpAddress a (sepcName sepc)) :& r runInstrImpl _ CHAIN_ID r = do   ContractEnv{..} <- ask   pure $ VChainId ceChainId :& r@@ -553,12 +554,12 @@ runArithOp   :: (ArithOp aop n m, Typeable n, Typeable m, EvalM monad)   => proxy aop-  -> CValue n-  -> CValue m-  -> monad (T.Value' instr ('Tc (ArithRes aop n m)))+  -> Value n+  -> Value m+  -> monad (Value (ArithRes aop n m)) runArithOp op l r = case evalOp op l r of   Left  err -> throwError (MichelsonArithError err)-  Right res -> pure (T.VC res)+  Right res -> pure res  -- | Unpacks given raw data into a typed value. runUnpack@@ -574,7 +575,7 @@ createOrigOp   :: (SingI param, StorageScope store)   => Address-  -> Maybe (T.Value ('Tc 'U.CKeyHash))+  -> Maybe (T.Value 'T.TKeyHash)   -> Mutez   -> ContractCode param store   -> Value' Instr store@@ -588,8 +589,8 @@     , ooContract = convertContractCode contract     } -unwrapMbKeyHash :: Maybe (T.Value ('Tc 'U.CKeyHash)) -> Maybe KeyHash-unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(T.VC (CvKeyHash keyHash)) -> keyHash+unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash+unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash  interpretExt :: EvalM m => SomeItStack -> m () interpretExt (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do@@ -605,6 +606,7 @@     throwError $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed"  interpretExt (SomeItStack T.DOC_ITEM{} _) = pass+interpretExt (SomeItStack T.COMMENT_ITEM{} _) = pass  -- | Access given stack reference (in CPS style). withStackElem
src/Michelson/Interpret/Pack.hs view
@@ -21,12 +21,12 @@ import qualified Data.ByteArray as ByteArray import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map-import Data.Singletons (SingI(..), demote)+import Data.Singletons (Sing, demote)  import Michelson.Text import Michelson.Typed import Michelson.Untyped.Annotation-  (Annotation(..), FieldAnn, TypeAnn, VarAnn, fullAnnSet, isNoAnnSet, noAnn)+  (Annotation(..), FieldAnn, TypeAnn, VarAnn, convAnn, fullAnnSet, isNoAnnSet, noAnn) import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core (ChainId(..), Mutez(..), timestampToSeconds) import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), signatureToBytes)@@ -62,7 +62,6 @@ -- byte representation. encodeValue :: forall t. (SingI t, HasNoOp t) => Value t -> LByteString encodeValue val = case (val, sing @t) of-  (VC cval, _) -> encodeCValue cval   (VKey s, _) -> encodeBytes . LBS.fromStrict $ case s of     PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk     PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk@@ -75,7 +74,8 @@   (VOption (Just x), STOption _) -> "\x05\x09" <> encodeValue x   (VOption Nothing, _) -> "\x03\x06"   (VList xs, STList _) -> encodeList encodeValue xs-  (VSet xs, _) -> encodeList encodeCValue (toList xs)+  (VSet xs, (STSet (st :: Sing st))) -> case checkOpPresence st of+    OpAbsent -> encodeList encodeValue (toList xs)   (VContract addr sepc, _) -> encodeEpAddress $ EpAddress addr (sepcName sepc)   (VPair (v1, v2), STPair l _) ->     case checkOpPresence l of@@ -87,21 +87,20 @@     case checkOpPresence l of       OpAbsent-> "\x05\x08" <> encodeValue v   (VLam lam, _) -> encodeInstrs $ rfAnyInstr lam-  (VMap m, STMap _ _) -> encodeMap m-  (VBigMap m, STBigMap _ _) -> encodeMap m--encodeCValue :: CValue t -> LByteString-encodeCValue = \case-  CvInt x        -> encodeNumeric x-  CvNat x        -> encodeNumeric x-  CvString text  -> encodeString text-  CvBytes bytes  -> encodeBytes (LBS.fromStrict bytes)-  CvMutez x      -> encodeNumeric (unMutez x)-  CvBool True    -> "\x03\x0a"-  CvBool False   -> "\x03\x03"-  CvKeyHash kh   -> encodeBytes $ encodeKeyHashRaw kh-  CvTimestamp x  -> encodeNumeric (timestampToSeconds @Integer x)-  CvAddress addr -> encodeEpAddress addr+  (VMap m, STMap sk _) -> case checkOpPresence sk of+    OpAbsent -> encodeMap m+  (VBigMap m, STBigMap sk _) -> case checkOpPresence sk of+    OpAbsent -> encodeMap m+  (VInt x, STInt) -> encodeNumeric x+  (VNat x, STNat) -> encodeNumeric x+  (VString text, STString) -> encodeString text+  (VBytes bytes, STBytes) -> encodeBytes (LBS.fromStrict bytes)+  (VMutez x, STMutez) -> encodeNumeric (unMutez x)+  (VBool True, STBool) -> "\x03\x0a"+  (VBool False, STBool) -> "\x03\x03"+  (VKeyHash kh, STKeyHash) -> encodeBytes $ encodeKeyHashRaw kh+  (VTimestamp x, STTimestamp) -> encodeNumeric (timestampToSeconds @Integer x)+  (VAddress addr, STAddress) -> encodeEpAddress addr  encodeLength :: Int -> LByteString encodeLength = Bi.runPut . Bi.putWord32be . fromIntegral@@ -127,9 +126,9 @@ encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn  -- | Encode some map.-encodeMap :: (SingI v, HasNoOp v) => Map (CValue k) (Value v) -> LByteString+encodeMap :: (SingI v, HasNoOp v, SingI k, HasNoOp k) => Map (Value k) (Value v) -> LByteString encodeMap m =-  encodeList (\(k, v) -> "\x07\x04" <> encodeCValue k <> encodeValue v) (Map.toList m)+  encodeList (\(k, v) -> "\x07\x04" <> encodeValue k <> encodeValue v) (Map.toList m)  encodeKeyHashRaw :: KeyHash -> LByteString encodeKeyHashRaw kh = (<> LBS.fromStrict (khBytes kh)) $@@ -247,11 +246,11 @@   SIZE ->     "\x03\x45"   EMPTY_SET | _ :: Proxy ('TSet t ': s) <- Proxy @out ->-    "\x05\x24" <> encodeT' @('Tc t)+    "\x05\x24" <> encodeT' @t   EMPTY_MAP | _ :: Proxy ('TMap k v ': s) <- Proxy @out ->-    "\x07\x23" <> encodeT' @('Tc k) <> encodeT' @v+    "\x07\x23" <> encodeT' @k <> encodeT' @v   EMPTY_BIG_MAP | _ :: Proxy ('TBigMap k v ': s) <- Proxy @out ->-    "\x07\x72" <> encodeT' @('Tc k) <> encodeT' @v+    "\x07\x72" <> encodeT' @k <> encodeT' @v   MAP a ->     "\x05\x38" <> encodeInstrs a   ITER a ->@@ -351,7 +350,7 @@   CREATE_CONTRACT (FullContract instr np ng)     | _ :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ] <- instr ->     let contents =-          [ "\x05\x00" <> encodeNotedT' @p (unParamNotes np)+          [ "\x05\x00" <> encodeParamNotes' @p np           , "\x05\x01" <> encodeNotedT' @g ng           , "\x05\x02" <> encodeInstrs instr           ]@@ -376,8 +375,6 @@    "\x03\x0e"   HASH_KEY ->    "\x03\x2b"-  STEPS_TO_QUOTA ->-   "\x03\x4a"   SOURCE ->    "\x03\x47"   SENDER ->@@ -424,21 +421,21 @@   (NIL, _ :: Proxy ('TList t ': s), NTList tn ns) ->     encodeWithAnns [tn] [] vns $ "\x05\x3d" <> encodeNotedT' @t ns   (EMPTY_SET, _ :: Proxy ('TSet t ': s), NTSet tn1 tn2) ->-    encodeWithAnns [tn1] [] vns $ "\x05\x24" <> encodeNotedT' @('Tc t) (NTc tn2)+    encodeWithAnns [tn1] [] vns $ "\x05\x24" <> encodeNotedT' @t (insertTypeAnn tn2 starNotes)   (EMPTY_MAP, _ :: Proxy ('TMap k v ': s), NTMap tn1 tn2 ns) ->     encodeWithAnns [tn1] [] vns $-      "\x07\x23" <> encodeNotedT' @('Tc k) (NTc tn2) <> encodeNotedT' @v ns+      "\x07\x23" <> encodeNotedT' @k (insertTypeAnn tn2 starNotes) <> encodeNotedT' @v ns   (EMPTY_BIG_MAP, _ :: Proxy ('TBigMap k v ': s), NTBigMap tn1 tn2 ns) ->     encodeWithAnns [tn1] [] vns $-      "\x07\x72" <> encodeNotedT' @('Tc k) (NTc tn2) <> encodeNotedT' @v ns-  (PUSH (v :: Value t), _, NTc tn) ->-    "\x07\x43" <> encodeNotedT' @t (NTc tn) <> encodeValue v+      "\x07\x72" <> encodeNotedT' @k (insertTypeAnn tn2 starNotes) <> encodeNotedT' @v ns+  (PUSH (v :: Value t), _, tn) ->+    "\x07\x43" <> encodeNotedT' @t tn <> encodeValue v   (LAMBDA (v :: Value ('TLambda i o)), _, NTLambda _tn ns1 ns2) ->     "\x09\x31" <>     encodeAsList (encodeNotedT' @i ns1 <> encodeNotedT' @o ns2 <> encodeValue v) <>     encodeLength 0  -- encoding of a Variable Annotation (that we don't support)-  (CAST, _ :: Proxy (t ': s), NTc tn) ->-    "\x05\x57" <> encodeNotedT' @t (NTc tn)+  (CAST, _ :: Proxy (t ': s), tn) ->+    "\x05\x57" <> encodeNotedT' @t tn   (UNPACK, _ :: Proxy ('TOption t ': s), NTOption tn ns) ->     encodeWithAnns [tn] [] vns $ "\x05\x0d" <> encodeNotedT' @t ns   -- NOTE: `CONTRACT` may be part of an `InstrWithNotes` with `NTOption`, but is@@ -451,12 +448,33 @@ encodeNotedT' :: forall (t :: T). SingI t => Notes t -> LByteString encodeNotedT' = encodeNotedST (sing @t) noAnn +encodeParamNotes' ::+  forall (t :: T). SingI t => ParamNotes t -> LByteString+encodeParamNotes' ParamNotesUnsafe{..} = encodeNotedST (sing @t) (convAnn pnRootAnn) pnNotes+ -- Note: to encode field annotations we have to accept them as an additional -- parameter because they are stored in the parent's `Notes t`, e.g. see STPair. encodeNotedST :: Sing t -> FieldAnn -> Notes t -> LByteString encodeNotedST st fn n = case (st, n) of-  (STc ct, NTc tn) ->-    encodeCTWithAnns (fromSingCT ct) tn fn+  (STInt, NTInt tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STNat, NTNat tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STString, NTString tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STBytes, NTBytes tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STMutez, NTMutez tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STBool, NTBool tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STKeyHash, NTKeyHash tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STTimestamp, NTTimestamp tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+  (STAddress, NTAddress tn) ->+    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)+   (STKey, NTKey tn) ->     encodeWithAnns [tn] [fn] [] $ "\x03\x5c"   (STUnit, NTUnit tn) ->@@ -470,7 +488,7 @@   (STList a, NTList tn ns) ->     encodeWithAnns [tn] [fn] [] $ "\x05\x5f" <> encodeNotedST a noAnn ns   (STSet a, NTSet tn1 tn2) ->-    encodeWithAnns [tn1] [fn] [] $ "\x05\x66" <> encodeCTWithAnns (fromSingCT a) tn2 noAnn+    encodeWithAnns [tn1] [fn] [] $ "\x05\x66" <> encodeWithAnns [tn2] [] [] (encodeT (fromSingT a))   (STOperation, NTOperation tn) ->     encodeWithAnns [tn] [fn] [] $ "\x03\x6d"   (STContract a, NTContract tn ns) ->@@ -486,43 +504,36 @@       "\x07\x5e" <> encodeNotedST a noAnn ns1 <> encodeNotedST r noAnn ns2   (STMap k v, NTMap tn1 tn2 ns) ->     encodeWithAnns [tn1] [fn] [] $-      "\x07\x60" <> encodeCTWithAnns (fromSingCT k) tn2 noAnn <> encodeNotedST v noAnn ns+      "\x07\x60" <> encodeWithAnns [tn2] [] [] (encodeT (fromSingT k)) <> encodeNotedST v noAnn ns   (STBigMap k v, NTBigMap tn1 tn2 ns) ->     encodeWithAnns [tn1] [fn] [] $-      "\x07\x61" <> encodeCTWithAnns (fromSingCT k) tn2 noAnn <> encodeNotedST v noAnn ns--encodeCTWithAnns :: CT -> TypeAnn -> FieldAnn -> LByteString-encodeCTWithAnns ct tn fn = encodeWithAnns [tn] [fn] [] $ encodeCT ct+      "\x07\x61" <> encodeWithAnns [tn2] [] [] (encodeT (fromSingT k)) <> encodeNotedST v noAnn ns  encodeT :: T -> LByteString encodeT = \case-  Tc ct -> encodeCT ct   TKey  -> "\x03\x5c"   TUnit -> "\x03\x6c"   TSignature -> "\x03\x67"   TChainId -> "\x03\x74"   TOption t -> "\x05\x63" <> encodeT t   TList t -> "\x05\x5f" <> encodeT t-  TSet t -> "\x05\x66" <> encodeCT t+  TSet t -> "\x05\x66" <> encodeT t   TOperation -> "\x03\x6d"   TContract t -> "\x05\x5a" <> encodeT t   TPair a b -> "\x07\x65" <> encodeT a <> encodeT b   TOr a b -> "\x07\x64" <> encodeT a <> encodeT b   TLambda a r -> "\x07\x5e" <> encodeT a <> encodeT r-  TMap k v -> "\x07\x60" <> encodeCT k <> encodeT v-  TBigMap k v -> "\x07\x61" <> encodeCT k <> encodeT v+  TMap k v -> "\x07\x60" <> encodeT k <> encodeT v+  TBigMap k v -> "\x07\x61" <> encodeT k <> encodeT v+  TInt -> "\x03" <> "\x5b"+  TNat -> "\x03" <> "\x62"+  TString -> "\x03" <> "\x68"+  TBytes -> "\x03" <> "\x69"+  TMutez -> "\x03" <> "\x6a"+  TBool -> "\x03" <> "\x59"+  TKeyHash -> "\x03" <> "\x5d"+  TTimestamp -> "\x03" <> "\x6b"+  TAddress -> "\x03" <> "\x6e"  encodeT' :: forall (t :: T). SingI t => LByteString encodeT' = encodeT (demote @t)--encodeCT :: CT -> LByteString-encodeCT = ("\x03" <>) . \case-  CInt -> "\x5b"-  CNat -> "\x62"-  CString -> "\x68"-  CBytes -> "\x69"-  CMutez -> "\x6a"-  CBool -> "\x59"-  CKeyHash -> "\x5d"-  CTimestamp -> "\x6b"-  CAddress -> "\x6e"
src/Michelson/Interpret/Unpack.hs view
@@ -34,7 +34,7 @@ import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Singletons (SingI(..))+import Data.Singletons (Sing, SingI(..)) import Data.Typeable ((:~:)(..)) import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+)) import Text.Hex (encodeHex)@@ -43,15 +43,13 @@ import qualified Michelson.Parser.Annotations as PA import Michelson.Text import Michelson.TypeCheck-  (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..))+  (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..), TypeContext(..), withWTPm) import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1) import Michelson.TypeCheck.Instr (typeCheckList)-import Michelson.Typed (RemFail(..), Sing(..), starNotes)+import Michelson.Typed (RemFail(..), SingT(..), starNotes) import qualified Michelson.Typed as T import Michelson.Typed.EntryPoints-import Michelson.Typed.Scope-  (BigMapPresence(..), ContractPresence(..), OpPresence(..), UnpackedValScope, bigMapAbsense,-  checkBigMapPresence, checkContractTypePresence, checkOpPresence, contractTypeAbsense, opAbsense)+import Michelson.Typed.Scope (UnpackedValScope) import Michelson.Untyped import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core@@ -239,8 +237,6 @@   => Get (T.Value t) decodeValue = Get.label "Value" $   case sing @t of-    STc _ ->-      T.VC <$> decodeCValue     STKey -> T.VKey <$> decodeAsBytesOrString       ( decodeWithTag "key"         [ 0x00 #: decodeBytesLike "key Ed25519"@@ -271,65 +267,80 @@         other -> fail $ "Unknown option tag: " <> show other     STList _ -> do       decodeAsList $ T.VList <$> manyForced decodeValue-    STSet _ -> do+    STSet (st :: Sing st) -> withComparable st $ do       decodeAsList $ do-        vals <- manyForced decodeCValue+        vals <- withUnpackedValueScope @st $ manyForced decodeValue         either (fail . toString) pure $           T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals-    STPair lt _ ->-      case (checkOpPresence lt, checkBigMapPresence lt, checkContractTypePresence lt) of-        (OpAbsent, BigMapAbsent, ContractAbsent) -> do-          expectDescTag "Pair" 2-          expectTag "Pair" 0x07-          T.VPair ... (,) <$> decodeValue <*> decodeValue-    STOr lt _ ->-      case (checkOpPresence lt, checkBigMapPresence lt, checkContractTypePresence lt) of-        (OpAbsent, BigMapAbsent, ContractAbsent) -> do-          expectDescTag "Or" 1-          Get.getWord8 >>= \case-            0x05 -> T.VOr . Left <$> decodeValue-            0x08 -> T.VOr . Right <$> decodeValue-            other -> unknownTag "or constructor" other-    STLambda _ _ -> do+    STPair (_ :: Sing lt) _ ->+      withUnpackedValueScope @lt $ do+        expectDescTag "Pair" 2+        expectTag "Pair" 0x07+        T.VPair ... (,) <$> decodeValue <*> decodeValue+    STOr (_ :: Sing lt) _ ->+      withUnpackedValueScope @lt $ do+        expectDescTag "Or" 1+        Get.getWord8 >>= \case+          0x05 -> T.VOr . Left <$> decodeValue+          0x08 -> T.VOr . Right <$> decodeValue+          other -> unknownTag "or constructor" other+    STLambda (_ :: Sing t1) (_ :: Sing t2) -> do       uinstr <- decodeOps-      T.VLam <$> decodeTypeCheckLam uinstr-    STMap _ _ -> do-      T.VMap <$> decodeMap+      withWTPm @t2 $+        withWTPm @t1 (T.VLam <$> decodeTypeCheckLam uinstr)+    STMap (st :: Sing st) (_ :: Sing sv) ->+      withUnpackedValueScope @st $+        withComparable st $ T.VMap <$> decodeMap -decodeCValue :: forall ct. SingI ct => Get (T.CValue ct)-decodeCValue = case sing @ct of-  SCInt -> do-    expectTag "Int" 0x00-    T.CvInt <$> decodeInt-  SCNat -> do-    expectTag "Nat" 0x00-    T.CvNat <$> decodeInt-  SCString -> do-    expectTag "String" 0x01-    T.CvString <$> decodeString-  SCBytes -> do-    expectTag "Bytes" 0x0a-    T.CvBytes <$> decodeBytes-  SCMutez -> do-    expectTag "Mutez" 0x00-    mmutez <- mkMutez <$> decodeInt-    maybe (fail "Negative mutez") (pure . T.CvMutez) mmutez-  SCBool -> do-    expectDescTag "Bool" 0-    Get.getWord8 >>= \case-      0x0A -> pure (T.CvBool True)-      0x03 -> pure (T.CvBool False)-      other -> unknownTag "bool" other-  SCKeyHash -> T.CvKeyHash <$> decodeAsBytesOrString-    ( decodeWithTag "key_hash" keyHashDecoders-    , parseKeyHash-    )-  SCTimestamp -> do-    expectTag "Timestamp" 0x00-    T.CvTimestamp . timestampFromSeconds <$> decodeInt-  SCAddress ->-    T.CvAddress <$> decodeEpAddress+    STInt -> do+      expectTag "Int" 0x00+      T.VInt <$> decodeInt+    STNat -> do+      expectTag "Nat" 0x00+      T.VNat <$> decodeInt+    STString -> do+      expectTag "String" 0x01+      T.VString <$> decodeString+    STBytes -> do+      expectTag "Bytes" 0x0a+      T.VBytes <$> decodeBytes+    STMutez -> do+      expectTag "Mutez" 0x00+      mmutez <- mkMutez <$> decodeInt+      maybe (fail "Negative mutez") (pure . T.VMutez) mmutez+    STBool -> do+      expectDescTag "Bool" 0+      Get.getWord8 >>= \case+        0x0A -> pure (T.VBool True)+        0x03 -> pure (T.VBool False)+        other -> unknownTag "bool" other+    STKeyHash -> T.VKeyHash <$> decodeAsBytesOrString+      ( decodeWithTag "key_hash" keyHashDecoders+      , parseKeyHash+      )+    STTimestamp -> do+      expectTag "Timestamp" 0x00+      T.VTimestamp . timestampFromSeconds <$> decodeInt+    STAddress ->+      T.VAddress <$> decodeEpAddress +withUnpackedValueScope+  :: forall a v m. (Typeable a, SingI a, MonadFail m)+  => (T.UnpackedValScope a => m v)+  -> m v+withUnpackedValueScope act = case T.checkScope @(T.UnpackedValScope a) of+  Right Dict -> act+  _ -> fail "Unpackable value is required here"++withComparable+  :: forall a v m. (MonadFail m)+  => Sing a+  -> (T.Comparable a => m v)+  -> m v+withComparable a act = case T.getComparableProofS a of+  Just Dict -> act+  Nothing -> fail "Comparable type is required here"+ keyHashDecoders :: [TaggedDecoder KeyHash] keyHashDecoders =   [ 0x00 #: KeyHash KeyHashEd25519 <$> getPayload@@ -414,14 +425,14 @@   decodeAsBytesRaw $ Get.label "Bytes payload" . getByteStringCopy  decodeMap-  :: (SingI k, UnpackedValScope v)-  => Get $ Map (T.CValue k) (T.Value v)-decodeMap = Get.label "Map" $+  :: forall k v.(UnpackedValScope k, UnpackedValScope v)+  => Get $ Map (T.Value k) (T.Value v)+decodeMap = withComparable (sing @k) $ Get.label "Map" $   decodeAsList $ do     es <- manyForced $ do       expectDescTag "Elt" 2       expectTag "Elt" 0x04-      (,) <$> decodeCValue <*> decodeValue+      (,) <$> decodeValue <*> decodeValue     either (fail . toString) pure $       Map.fromDistinctAscList <$> ensureDistinctAsc fst es @@ -475,12 +486,12 @@ -- | Type check instruction occured from a lambda. decodeTypeCheckLam   :: forall inp out m.-     (Typeable inp, SingI inp, SingI out, Typeable out, MonadFail m)+     (Typeable inp, SingI inp, T.WellTyped inp, SingI out, Typeable out, T.WellTyped out, MonadFail m)   => [ExpandedOp]   -> m (RemFail T.Instr '[inp] '[out]) decodeTypeCheckLam uinstr =   either tcErrToFail pure . evaluatingState tcInitEnv . runExceptT $ do-    let inp = (starNotes, noAnn) ::& SNil+    let inp = (starNotes, Dict, noAnn) ::& SNil     _ :/ instr' <- typeCheckList uinstr inp     case instr' of       instr ::: out' ->@@ -493,8 +504,8 @@             let tinp = Type TUnit noAnn                 tout = Type TUnit noAnn             in throwError $-              TCFailedOnInstr (LAMBDA noAnn tinp tout uinstr) (SomeHST inp)-              "Unexpected lambda output type" def (Just err)+              TCFailedOnInstr (LAMBDA noAnn tinp tout uinstr) (SomeHST inp) def+              (Just LambdaCode) (Just err)       AnyOutInstr instr ->         return $ RfAlwaysFails instr   where@@ -613,7 +624,6 @@     (0x03, 0x10) -> SHA512 <$> decodeNoAnn     (0x03, 0x0E) -> BLAKE2B <$> decodeNoAnn     (0x03, 0x2B) -> HASH_KEY <$> decodeNoAnn-    (0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeNoAnn     (0x03, 0x47) -> SOURCE <$> decodeNoAnn     (0x03, 0x48) -> SENDER <$> decodeNoAnn     (0x03, 0x49) -> SELF <$> decodeNoAnn <*> decodeNoAnn@@ -711,7 +721,6 @@     (0x04, 0x10) -> SHA512 <$> decodeVAnn     (0x04, 0x0E) -> BLAKE2B <$> decodeVAnn     (0x04, 0x2B) -> HASH_KEY <$> decodeVAnn-    (0x04, 0x4A) -> STEPS_TO_QUOTA <$> decodeVAnn     (0x04, 0x47) -> SOURCE <$> decodeVAnn     (0x04, 0x48) -> SENDER <$> decodeVAnn     (0x04, 0x49) -> decodeWithVFAnns SELF@@ -723,12 +732,10 @@ decodePushVal :: Get (Type, Value) decodePushVal = do   typ <- decodeType-  T.withSomeSingT (T.fromUType typ) $ \(st :: Sing t) ->-    case (opAbsense st, bigMapAbsense st, contractTypeAbsense st) of-      (Nothing, _, _) -> fail "Operation type cannot appear in PUSH"-      (_, Nothing, _) -> fail "BigMap type cannot appear in PUSH"-      (_, _, Nothing) -> fail "'contract' type cannot appear in PUSH"-      (Just Dict, Just Dict, Just Dict) -> do+  T.withSomeSingT (T.fromUType typ) $ \(_ :: Sing t) ->+    case T.checkScope @(T.ConstantScope t) of+      Left bt -> fail $ "Type can not appear in PUSH because it " <> pretty bt+      Right Dict -> do         tval <- decodeValue @t         pure $ (typ, T.untypeValue tval) @@ -736,14 +743,14 @@ decodeContract = decodeAsList $ do   expectTag "Pre contract parameter" 0x05   expectTag "Contract parameter" 0x00-  p <- decodeType+  (t, ta, root) <- decodeTWithAnns   expectTag "Pre contract storage" 0x05   expectTag "Contract storage" 0x01   s <- decodeType   expectTag "Pre contract code" 0x05   expectTag "Contract code" 0x02   c <- decodeOps-  pure (Contract p s c)+  pure (Contract (ParameterType (Type t ta) (convAnn root)) s c)  decodeOp :: Get ExpandedOp decodeOp = Get.label "Op" $ do@@ -755,11 +762,11 @@ decodeOps :: Get [ExpandedOp] decodeOps = decodeAsList $ manyForced decodeOp -decodeComparable :: Get Comparable+decodeComparable :: Get Type decodeComparable = do   (ct, tAnn, fAnn) <- decodeCTWithAnns   if fAnn == noAnn-    then pure $ Comparable ct tAnn+    then pure $ Type ct tAnn     else fail "This Comparable should not have a Field annotation"  decodeType :: Get Type@@ -769,25 +776,26 @@     then pure $ Type t tAnn     else fail "This Type should not have a Field annotation" -decodeCTWithAnns :: Get (CT, TypeAnn, FieldAnn)+decodeCTWithAnns :: Get (T, TypeAnn, FieldAnn) decodeCTWithAnns = 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 |+ ""   ct <- case tag of-    0x5B -> pure CInt-    0x62 -> pure CNat-    0x68 -> pure CString-    0x69 -> pure CBytes-    0x6A -> pure CMutez-    0x59 -> pure CBool-    0x5D -> pure CKeyHash-    0x6B -> pure CTimestamp-    0x6E -> pure CAddress+    0x5B -> pure TInt+    0x62 -> pure TNat+    0x68 -> pure TString+    0x69 -> pure TBytes+    0x6A -> pure TMutez+    0x59 -> pure TBool+    0x5D -> pure TKeyHash+    0x6B -> pure TTimestamp+    0x6E -> pure TAddress     _ -> fail failMessage   case pretag of     0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn     0x04 -> decodeWithTFAnns (ct,,)+    0x05 -> decodeWithTFAnns (ct,,)     _ -> fail failMessage  decodeTWithAnns :: Get (T, TypeAnn, FieldAnn)@@ -795,7 +803,7 @@   where     decodeTc = do       (ct, tAnn, fAnn) <- decodeCTWithAnns-      pure ((Tc ct), tAnn, fAnn)+      pure (ct, tAnn, fAnn)     doDecode = do       pretag <- Get.getWord8 ? "Pre complex type tag"       tag <- Get.getWord8 ? "Complex type tag"
src/Michelson/Let.hs view
@@ -3,11 +3,12 @@   , LetValue (..)   ) where -import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import qualified Data.Text as T  import Michelson.Macro (ParsedOp) import Michelson.Untyped (Type, Value')+import Util.Aeson  -- | A programmer-defined constant data LetValue = LetValue@@ -22,5 +23,5 @@   , ltSig :: Type   } deriving stock (Eq, Show) -deriveJSON defaultOptions ''LetValue-deriveJSON defaultOptions ''LetType+deriveJSON morleyAesonOptions ''LetValue+deriveJSON morleyAesonOptions ''LetType
src/Michelson/Macro.hs view
@@ -32,7 +32,7 @@   , expandMapCadr   ) where -import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import qualified Data.Text as T import Fmt (Buildable(build), genericF, (+|), (+||), (|+), (||+))@@ -41,6 +41,7 @@ import Michelson.ErrorPos import Michelson.Printer (RenderDoc(..)) import Michelson.Untyped+import Util.Aeson import Util.Generic import Util.Positive @@ -176,7 +177,8 @@  -- | Expand all macros in parsed contract. expandContract :: Contract' ParsedOp -> Contract-expandContract Contract {..} = Contract para stor (expandList code)+expandContract contract =+  contract { contractCode = expandList (contractCode contract) }  -- Probably, some SYB can be used here expandValue :: ParsedValue -> Value@@ -431,8 +433,8 @@       getLeaf (a:as) = (a, as)       getLeaf _      = ((noAnn, noAnn), []) -deriveJSON defaultOptions ''ParsedOp-deriveJSON defaultOptions ''LetMacro-deriveJSON defaultOptions ''PairStruct-deriveJSON defaultOptions ''CadrStruct-deriveJSON defaultOptions ''Macro+deriveJSON morleyAesonOptions ''ParsedOp+deriveJSON morleyAesonOptions ''LetMacro+deriveJSON morleyAesonOptions ''PairStruct+deriveJSON morleyAesonOptions ''CadrStruct+deriveJSON morleyAesonOptions ''Macro
src/Michelson/OpSize.hs view
@@ -73,9 +73,9 @@   CONS va -> annsOpSize va   IF_CONS l r -> ifOpSize l r   SIZE va -> annsOpSize va-  EMPTY_SET ta va ct -> annsOpSize ta va <> comparableOpSize ct-  EMPTY_MAP ta va ct t -> annsOpSize ta va <> comparableOpSize ct <> typeOpSize t-  EMPTY_BIG_MAP ta va ct t -> annsOpSize ta va <> comparableOpSize ct <> typeOpSize t+  EMPTY_SET ta va ct -> annsOpSize ta va <> innerOpSize ct+  EMPTY_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t+  EMPTY_BIG_MAP ta va ct t -> annsOpSize ta va <> innerOpSize ct <> typeOpSize t   MAP va is -> annsOpSize va <> subcodeOpSize is   ITER is -> subcodeOpSize is   MEM va -> annsOpSize va@@ -132,7 +132,6 @@   SHA512 va -> annsOpSize va   BLAKE2B va -> annsOpSize va   HASH_KEY va -> annsOpSize va-  STEPS_TO_QUOTA va -> annsOpSize va   SOURCE va -> annsOpSize va   SENDER va -> annsOpSize va   ADDRESS va -> annsOpSize va@@ -152,8 +151,8 @@ expandedInstrsOpSize = foldMap expandedInstrOpSize  contractOpSize :: Contract -> OpSize-contractOpSize (Contract cp st is) =-  OpSize 16 <> typeOpSize cp <> typeOpSize st <> expandedInstrsOpSize is+contractOpSize (Contract (ParameterType cp rootAnn) st is) =+  OpSize 16 <> typeOpSize' [convAnn rootAnn] cp <> typeOpSize st <> expandedInstrsOpSize is  numOpSize :: Integral i => i -> OpSize numOpSize = OpSize . fromIntegral . length . encodeIntPayload . fromIntegral@@ -188,33 +187,35 @@   tOpSize t <> annsOpSize ta anns  tOpSize :: T -> OpSize-tOpSize = \case-  Tc ct -> ctOpSize ct-  TKey -> baseOpSize-  TUnit -> baseOpSize-  TSignature -> baseOpSize-  TChainId -> baseOpSize-  TOption a -> baseOpSize <> typeOpSize a-  TList a -> baseOpSize <> typeOpSize a-  TSet a -> baseOpSize <> comparableOpSize a-  TOperation -> baseOpSize-  TContract a -> baseOpSize <> typeOpSize a-  TPair al ar l r -> baseOpSize <> typeOpSize' [al] l <> typeOpSize' [ar] r-  TOr al ar l r -> baseOpSize <> typeOpSize' [al] l <> typeOpSize' [ar] r-  TLambda i o -> baseOpSize <> typeOpSize i <> typeOpSize o-  TMap k v -> baseOpSize <> comparableOpSize k <> typeOpSize v-  TBigMap k v -> baseOpSize <> comparableOpSize k <> typeOpSize v-  where-    -- TODO: use this once in the function beginning (and inline it) once 'CT'-    -- and 'Comparable' are gone-    baseOpSize = OpSize 2--comparableOpSize :: Comparable -> OpSize-comparableOpSize (Comparable ct a) =-  ctOpSize ct <> annsOpSize a+tOpSize t =+  OpSize 2 <> case t of+    TKey -> mempty+    TUnit -> mempty+    TSignature -> mempty+    TChainId -> mempty+    TOption a -> typeOpSize a+    TList a -> typeOpSize a+    TSet a -> innerOpSize a+    TOperation -> mempty+    TContract a -> typeOpSize a+    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+    TBigMap k v -> innerOpSize k <> typeOpSize v+    TInt -> mempty+    TNat -> mempty+    TString -> mempty+    TBytes -> mempty+    TMutez -> mempty+    TBool -> mempty+    TKeyHash -> mempty+    TTimestamp -> mempty+    TAddress -> mempty -ctOpSize :: CT -> OpSize-ctOpSize _ = OpSize 2+innerOpSize :: Type -> OpSize+innerOpSize (Type _ a) =+  (OpSize 2) <> annsOpSize a  -- | Accepts an arbitrary number of 'TypeAnn' 'FieldAnn' and/or 'VarAnn' that -- belong to the same entity and returns their total operation size.
src/Michelson/Optimizer.hs view
@@ -25,14 +25,13 @@  import Michelson.Interpret.Pack (packValue') import Michelson.Typed.Aliases (Value)-import Michelson.Typed.CValue import Michelson.Typed.Instr import Michelson.Typed.Scope (PackedValScope) import Michelson.Typed.Sing import Michelson.Typed.T import Michelson.Typed.Util (DfsSettings(..), dfsInstr) import Michelson.Typed.Value-import Util.Peano (Sing(..))+import Util.Peano (SingNat(..))  ---------------------------------------------------------------------------- -- High level@@ -189,8 +188,8 @@   Seq NONE  (Seq (IF_NONE f _) c) -> Just (Seq f c)   Seq SOME  (Seq (IF_NONE _ f) c) -> Just (Seq f c) -  Seq (PUSH (VC (CvBool True)))  (Seq (IF f _) c) -> Just (Seq f c)-  Seq (PUSH (VC (CvBool False))) (Seq (IF _ f) c) -> Just (Seq f c)+  Seq (PUSH (VBool True))  (Seq (IF f _) c) -> Just (Seq f c)+  Seq (PUSH (VBool False)) (Seq (IF _ f) c) -> Just (Seq f c)    Seq LEFT       (IF_LEFT f _)    -> Just f   Seq RIGHT      (IF_LEFT _ f)    -> Just f@@ -199,17 +198,17 @@   Seq NONE       (IF_NONE f _)    -> Just f   Seq SOME       (IF_NONE _ f)    -> Just f -  Seq (PUSH (VC (CvBool True)))  (IF f _) -> Just f-  Seq (PUSH (VC (CvBool False))) (IF _ f) -> Just f+  Seq (PUSH (VBool True))  (IF f _) -> Just f+  Seq (PUSH (VBool False)) (IF _ f) -> Just f    _ -> Nothing  compareWithZero :: Rule compareWithZero = \case-  Seq (PUSH (VC (CvInt 0))) (Seq COMPARE (Seq EQ c)) -> Just          (Seq EQ c)-  Seq (PUSH (VC (CvNat 0))) (Seq COMPARE (Seq EQ c)) -> Just (Seq INT (Seq EQ c))-  Seq (PUSH (VC (CvInt 0))) (Seq COMPARE      EQ)    -> Just               EQ-  Seq (PUSH (VC (CvNat 0))) (Seq COMPARE      EQ)    -> Just (Seq INT      EQ)+  Seq (PUSH (VInt 0)) (Seq COMPARE (Seq EQ c)) -> Just          (Seq EQ c)+  Seq (PUSH (VNat 0)) (Seq COMPARE (Seq EQ c)) -> Just (Seq INT (Seq EQ c))+  Seq (PUSH (VInt 0)) (Seq COMPARE      EQ)    -> Just               EQ+  Seq (PUSH (VNat 0)) (Seq COMPARE      EQ)    -> Just (Seq INT      EQ)   _                                                  -> Nothing  simpleDrops :: Rule@@ -307,8 +306,8 @@    _ -> Nothing   where-    pushPacked :: PackedValScope t => Value t -> Instr s ('Tc 'CBytes ': s)-    pushPacked = PUSH . VC . CvBytes . packValue'+    pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)+    pushPacked = PUSH . VBytes . packValue'  -- | Append LHS of 'Seq' to RHS and re-run pointwise ruleset at each point. --   That might cause reinvocation of this function (see 'defaultRules'),
src/Michelson/Parser.hs view
@@ -88,16 +88,16 @@ contract :: Parser (Contract' ParsedOp) contract = do   mSpace-  (p,s,c) <- braces contractTuple <|> contractTuple-  return $ Contract p s c+  ((r, p), s, c) <- braces contractTuple <|> contractTuple+  return $ Contract (ParameterType p (convAnn r)) s c   where     contractTuple = intercalateEffect semicolon $                      (,,) <$> toPermutation parameter                           <*> toPermutation storage                           <*> toPermutation code -    parameter :: Parser Type-    parameter = symbol "parameter" *> type_+    parameter :: Parser (FieldAnn, Type)+    parameter = symbol "parameter" *> field      storage :: Parser Type     storage = symbol "storage" *> type_
src/Michelson/Parser/Annotations.hs view
@@ -1,5 +1,6 @@ module Michelson.Parser.Annotations   ( note+  , noteF   , noteV   , noteDef   , noteV2Def@@ -46,6 +47,9 @@  noteDef :: KnownAnnTag tag => Parser (Annotation tag) noteDef = parseDef note++noteF :: Parser FieldAnn+noteF = note  noteF2 :: Parser (FieldAnn, FieldAnn) noteF2 = do a <- note; b <- note; return (a, b)
src/Michelson/Parser/Instr.hs view
@@ -38,7 +38,7 @@   , transferTokensOp, setDelegateOp   , createContractOp contractParser, implicitAccountOp, nowOp, amountOp   , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp-  , stepsToQuotaOp, sourceOp, senderOp, chainIdOp+  , sourceOp, senderOp, chainIdOp   ]  -- | Parse a sequence of instructions.@@ -201,14 +201,14 @@  emptySetOp :: Parser ParsedInstr emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;-                EMPTY_SET t v <$> comparable+                EMPTY_SET t v <$> typeWithParen  emptyMapOp :: Parser ParsedInstr-emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- comparable;+emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- typeWithParen;                 EMPTY_MAP t v a <$> type_  emptyBigMapOp :: Parser ParsedInstr-emptyBigMapOp = do symbol' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- comparable;+emptyBigMapOp = do symbol' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- typeWithParen;                    EMPTY_BIG_MAP t v a <$> type_  memOp :: Parser ParsedInstr@@ -307,9 +307,6 @@  nowOp :: Parser ParsedInstr nowOp = word' "NOW" NOW <*> noteDef--stepsToQuotaOp :: Parser ParsedInstr-stepsToQuotaOp = word' "STEPS_TO_QUOTA" STEPS_TO_QUOTA <*> noteDef  chainIdOp :: Parser ParsedInstr chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef
src/Michelson/Parser/Type.hs view
@@ -2,7 +2,8 @@  module Michelson.Parser.Type   ( type_-  , comparable+  , typeWithParen+  , field   ) where  import Prelude hiding (many, note, some, try)@@ -60,7 +61,9 @@ typeInner   :: Parser FieldAnn -> Parser (FieldAnn, Type) typeInner fp = lexeme $ choice $ (\x -> x fp) <$>-  [ t_ct, t_key, t_unit, t_signature, t_chain_id+  [ 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_option, t_list, t_set   , t_operation, t_contract, t_pair, t_or   , t_lambda, t_map, t_big_map, t_view@@ -73,22 +76,8 @@ -- Comparable types ---------------------------------------------------------------------------- -comparable :: Parser Comparable-comparable = mparens $ Comparable <$> ct <*> noteDef--t_ct :: (Default a) => Parser a -> Parser (a, Type)-t_ct fp = do ct' <- ct; (f,t) <- fieldType fp; return (f, Type (Tc ct') t)--ct :: Parser CT-ct =  word' "Int" CInt-  <|> word' "Nat" CNat-  <|> word' "String" CString-  <|> word' "Bytes" CBytes-  <|> word' "Mutez" CMutez-  <|> word' "Bool" CBool-  <|> word' "KeyHash" CKeyHash <|> word "key_hash" CKeyHash-  <|> word' "Timestamp" CTimestamp-  <|> word' "Address" CAddress+typeWithParen :: Parser Type+typeWithParen = mparens type_  ---------------------------------------------------------------------------- -- Non-comparable types@@ -97,6 +86,34 @@ mkType :: T -> (a, TypeAnn) -> (a, Type) mkType t (a, ta) = (a, Type t ta) ++t_int :: (Default a) => Parser a -> Parser (a, Type)+t_int fp = word' "Int" (mkType TInt) <*> fieldType fp++t_nat :: (Default a) => Parser a -> Parser (a, Type)+t_nat fp = word' "Nat" (mkType TNat) <*> fieldType fp++t_string :: (Default a) => Parser a -> Parser (a, Type)+t_string fp = word' "String" (mkType TString) <*> fieldType fp++t_bytes :: (Default a) => Parser a -> Parser (a, Type)+t_bytes fp = word' "Bytes" (mkType TBytes) <*> fieldType fp++t_mutez :: (Default a) => Parser a -> Parser (a, Type)+t_mutez fp = word' "Mutez" (mkType TMutez) <*> fieldType fp++t_bool :: (Default a) => Parser a -> Parser (a, Type)+t_bool fp = word' "Bool" (mkType TBool) <*> fieldType fp++t_keyhash :: (Default a) => Parser a -> Parser (a, Type)+t_keyhash fp = ((word' "KeyHash" (mkType TKeyHash)) <|> (word "key_hash" (mkType TKeyHash))) <*> fieldType fp++t_timestamp :: (Default a) => Parser a -> Parser (a, Type)+t_timestamp fp = word' "Timestamp" (mkType TTimestamp) <*> fieldType fp++t_address :: (Default a) => Parser a -> Parser (a, Type)+t_address fp = word' "Address" (mkType TAddress) <*> fieldType fp+ t_key :: (Default a) => Parser a -> Parser (a, Type) t_key fp = word' "Key" (mkType TKey) <*> fieldType fp @@ -189,19 +206,19 @@     core = do       symbol' "Set"       (f, t) <- fieldType fp-      a <- comparable+      a <- typeWithParen       return (f, Type (TSet a) t)     braceSet = do-      a <- braces comparable+      a <- braces typeWithParen       (f, t) <- fieldType fp       return (f, Type (TSet a) t)  t_map_like   :: Default a-  => Parser a -> Parser (Comparable, Type, a, TypeAnn)+  => Parser a -> Parser (Type, Type, a, TypeAnn) t_map_like fp = do   (f, t) <- fieldType fp-  a <- comparable+  a <- typeWithParen   b <- type_   return (a, b, f, t)
src/Michelson/Preprocess.hs view
@@ -22,21 +22,16 @@ transformStrings :: Bool -> (MText -> MText) -> Instr inp out -> Instr inp out transformStrings goToValues f = transformConstants goToValues valF   where-    cvalF :: CValue t -> CValue t-    cvalF = \case-      CvString str -> CvString $ f str-      cv -> cv-     valF :: Value t -> Value t     valF = \case-      VC cval -> VC (cvalF cval)+      VString str -> VString $ f str       VOption mv -> VOption (valF <$> mv)       VList vs -> VList (valF <$> vs)-      VSet vSet -> VSet (Set.map cvalF vSet)+      VSet vSet -> VSet (Set.map valF vSet)       VPair (v1, v2) -> VPair (valF v1, valF v2)       VOr eith -> VOr (bimap valF valF eith)-      VMap m -> VMap . fmap valF . Map.mapKeys cvalF $ m-      VBigMap m -> VBigMap . fmap valF . Map.mapKeys cvalF $ m+      VMap m -> VMap . fmap valF . Map.mapKeys valF $ m+      VBigMap m -> VBigMap . fmap valF . Map.mapKeys valF $ m       -- We do not handle 'VLam' here, because 'dfsInstr' takes care of that.       v -> v @@ -45,21 +40,16 @@ transformBytes :: Bool -> (ByteString -> ByteString) -> Instr inp out -> Instr inp out transformBytes goToValues f = transformConstants goToValues valF   where-    cvalF :: CValue t -> CValue t-    cvalF = \case-      CvBytes str -> CvBytes $ f str-      cv -> cv-     valF :: Value t -> Value t     valF = \case-      VC cval -> VC (cvalF cval)+      VBytes str -> VBytes $ f str       VOption mv -> VOption (valF <$> mv)       VList vs -> VList (valF <$> vs)-      VSet vSet -> VSet (Set.map cvalF vSet)+      VSet vSet -> VSet (Set.map valF vSet)       VPair (v1, v2) -> VPair (valF v1, valF v2)       VOr eith -> VOr (bimap valF valF eith)-      VMap m -> VMap . fmap valF . Map.mapKeys cvalF $ m-      VBigMap m -> VBigMap . fmap valF . Map.mapKeys cvalF $ m+      VMap m -> VMap . fmap valF . Map.mapKeys valF $ m+      VBigMap m -> VBigMap . fmap valF . Map.mapKeys valF $ m       -- We do not handle 'VLam' here, because 'dfsInstr' takes care of that.       v -> v
src/Michelson/Printer.hs view
@@ -6,6 +6,7 @@   , printTypedFullContract   , printSomeContract   , printTypedValue+  , printUntypedValue   ) where  import Data.Constraint (withDict)@@ -28,18 +29,30 @@ printTypedContractCode forceSingleLine =   printUntypedContract forceSingleLine . T.convertContractCode +-- | Convert typed contract into a textual representation which+-- will be accepted by the OCaml reference client. printTypedFullContract :: Bool -> T.FullContract p s -> TL.Text printTypedFullContract forceSingleLine fc@T.FullContract{} =   printUntypedContract forceSingleLine $ T.convertFullContract fc +-- | Convert typed value into a textual representation which+-- will be accepted by the OCaml reference client. printTypedValue   :: forall t.       (T.ProperPrintedValBetterErrors t)   => Bool -> T.Value t -> TL.Text printTypedValue forceSingleLine =   withDict (T.properPrintedValEvi @t) $-  printDoc forceSingleLine . renderDoc doesntNeedParens . T.untypeValue+  printUntypedValue forceSingleLine . T.untypeValue +-- | Convert untyped value into a textual representation which+-- will be accepted by the OCaml reference client.+printUntypedValue :: (RenderDoc op) => Bool -> U.Value' op -> TL.Text+printUntypedValue forceSingleLine =+  printDoc forceSingleLine . renderDoc doesntNeedParens++-- | Convert 'SomeContract' into a textual representation which+-- will be accepted by the OCaml reference client. printSomeContract :: Bool -> SomeContract -> TL.Text printSomeContract forceSingleLine (SomeContract fc) =   printTypedFullContract forceSingleLine fc
src/Michelson/Printer/Util.hs view
@@ -128,5 +128,5 @@  -- | Ensure parentheses are not required, for case when you cannot -- sensibly wrap your expression into them.-assertParensNotNeeded :: HasCallStack => RenderContext -> a -> a+assertParensNotNeeded :: RenderContext -> a -> a assertParensNotNeeded (RenderContext pn) = assert (not pn)
src/Michelson/Runtime.hs view
@@ -365,7 +365,8 @@     typeCheckContract (extractAllContracts gs) (ooContract origination)   typedStorage <- first EEIllTypedStorage $     typeCheckTopLevelType-      (extractAllContracts gs) (U.stor $ ooContract origination) (ooStorage origination)+      (extractAllContracts gs) (U.contractStorage $ ooContract origination)+      (ooStorage origination)   let originatorAddress = ooOriginator origination   originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of     Nothing -> Left (EEUnknownManager originatorAddress)@@ -463,7 +464,7 @@         SomeContractAndStorage typedContract typedStorage           <- getTypedContractAndStorage EEIllTypedContract EEIllTypedStorage gs cs         T.MkEntryPointCallRes _ epc-          <- T.mkEntryPointCall epName (T.fcParamNotesSafe typedContract)+          <- T.mkEntryPointCall epName (T.fcParamNotes typedContract)              & maybe (throwError $ EEUnknownEntrypoint epName) pure         typedParameter <- first EEIllTypedParameter $            typeVerifyTopLevelType existingContracts (tdParameter txData)
src/Michelson/Runtime/GState.hs view
@@ -1,48 +1,47 @@ -- | Global blockchain state (emulated).  module Michelson.Runtime.GState-       (-         -- * Auxiliary types-         ContractState (..)-       , getTypedContract-       , getTypedStorage-       , SomeContractAndStorage (..)-       , getTypedContractAndStorage-       , AddressState (..)-       , asBalance+  (+    -- * Auxiliary types+    ContractState (..)+  , getTypedContract+  , getTypedStorage+  , SomeContractAndStorage (..)+  , getTypedContractAndStorage+  , AddressState (..)+  , asBalance -       -- * GState-       , GState (..)-       , gsChainIdL-       , gsAddressesL-       , genesisAddresses-       , genesisKeyHashes-       , genesisAddress-       -- * More genesisAddresses which can be used in tests-       , genesisAddress1-       , genesisAddress2-       , genesisAddress3-       , genesisAddress4-       , genesisAddress5-       , genesisAddress6-       , genesisKeyHash-       , initGState-       , readGState-       , writeGState+  -- * GState+  , GState (..)+  , gsChainIdL+  , gsAddressesL+  , genesisAddresses+  , genesisKeyHashes+  , genesisAddress+  -- * More genesisAddresses which can be used in tests+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6+  , genesisKeyHash+  , initGState+  , readGState+  , writeGState -       -- * Operations on GState-       , GStateUpdate (..)-       , GStateUpdateError (..)-       , applyUpdate-       , applyUpdates-       , extractAllContracts-       ) where+  -- * Operations on GState+  , GStateUpdate (..)+  , GStateUpdateError (..)+  , applyUpdate+  , applyUpdates+  , extractAllContracts+  ) where -import Control.Lens (at, makeLensesWith)+import Control.Lens (at) import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson-import Data.Aeson.Options (defaultOptions) import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString.Lazy as LBS import Data.List.NonEmpty ((!!))@@ -57,10 +56,11 @@ import Michelson.Typed (SomeValue, SomeValue'(..)) import qualified Michelson.Typed as T import Michelson.Typed.Scope-import Michelson.Untyped (Contract, Type, Value, para, stor)+import Michelson.Untyped (Contract, ParameterType, Value, contractParameter, contractStorage) import Tezos.Address (Address(..), ContractHash) import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId) import Tezos.Crypto+import Util.Aeson import Util.Lens  -- | State of a contract with code.@@ -87,9 +87,9 @@  instance ToJSON ContractState where   toJSON ContractState{..} = object-    [ "csBalance" .= csBalance-    , "csStorage" .= csStorage-    , "csContract" .= csContract+    [ "balance" .= csBalance+    , "storage" .= csStorage+    , "contract" .= csContract     ]  -- These instance is a bit hacky because it is quite painful to@@ -97,9 +97,9 @@ -- we typecheck untyped representation instead of parsing. instance FromJSON ContractState where   parseJSON = withObject "contractstate" $ \o -> do-    csBalance <- o .: "csBalance"-    csStorage <- o .: "csStorage"-    csContract <- o .: "csContract"+    csBalance <- o .: "balance"+    csStorage <- o .: "storage"+    csContract <- o .: "contract"     let csTypedContract = Nothing     let csTypedStorage = Nothing     return ContractState {..}@@ -127,7 +127,7 @@       ASSimple balance -> "Balance = " +| balance |+ ""       ASContract cs -> build cs -deriveJSON defaultOptions ''AddressState+deriveJSON morleyAesonOptions ''AddressState  -- | Extract balance from 'AddressState'. asBalance :: AddressState -> Mutez@@ -147,7 +147,7 @@  makeLensesWith postfixLFields ''GState -deriveJSON defaultOptions ''GState+deriveJSON morleyAesonOptions ''GState  getTypedContract :: GState -> ContractState -> Either TCError SomeContract getTypedContract gs ContractState{..} =@@ -155,7 +155,7 @@  getTypedStorage :: GState -> ContractState -> Either TCError SomeValue getTypedStorage gs ContractState{..} =-  typeCheckTopLevelType (extractAllContracts gs) (stor csContract) csStorage+  typeCheckTopLevelType (extractAllContracts gs) (contractStorage csContract) csStorage  -- [#36] TODO: try to get rid of this type, 'ContractState' should become -- broader than it@@ -351,9 +351,11 @@ extractAllContracts :: GState -> TcOriginatedContracts extractAllContracts = Map.fromList . mapMaybe extractContract . toPairs . gsAddresses  where-    extractContract :: (Address, AddressState) -> Maybe (ContractHash, Type)+    extractContract+      :: (Address, AddressState) -> Maybe (ContractHash, ParameterType)     extractContract =       \case (KeyAddress _, ASSimple {}) -> Nothing             (KeyAddress _, _) -> error "broken GState"-            (ContractAddress ca, ASContract cs) -> Just (ca, para $ csContract cs)+            (ContractAddress ca, ASContract cs) ->+              Just (ca, contractParameter $ csContract cs)             (ContractAddress _, _) -> error "broken GState"
src/Michelson/Test/Gen.hs view
@@ -13,19 +13,17 @@ import Data.Time.Format (defaultTimeLocale, parseTimeM) import Test.QuickCheck (Arbitrary(..), choose) -import Michelson.Typed (CT(..), CValue(..), T(..), Value'(..))+import Michelson.Typed (T(..), Value'(..)) import Tezos.Core   (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds,   unsafeMkMutez) -instance Arbitrary (CValue 'CKeyHash) where-  arbitrary = CvKeyHash <$> arbitrary-instance Arbitrary (CValue 'CMutez) where-  arbitrary = CvMutez <$> arbitrary-instance Arbitrary (CValue 'CInt) where-  arbitrary = CvInt <$> arbitrary-instance Arbitrary (CValue a) => Arbitrary (Value' instr ('Tc a)) where-  arbitrary = VC <$> arbitrary+instance Arbitrary (Value' instr 'TKeyHash) where+  arbitrary = VKeyHash <$> arbitrary+instance Arbitrary (Value' instr 'TMutez) where+  arbitrary = VMutez <$> arbitrary+instance Arbitrary (Value' instr 'TInt) where+  arbitrary = VInt <$> arbitrary instance Arbitrary (Value' instr a) => Arbitrary (Value' instr ('TList a)) where   arbitrary = VList <$> arbitrary instance Arbitrary (Value' instr 'TUnit) where@@ -64,8 +62,8 @@   UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay)           (fromInteger $ (maxSec - minSec) `div` 2) -instance Arbitrary (CValue 'CTimestamp) where-  arbitrary = CvTimestamp <$> arbitrary+instance Arbitrary (Value' instr 'TTimestamp) where+  arbitrary = VTimestamp <$> arbitrary  instance Arbitrary Mutez where   arbitrary = unsafeMkMutez <$> choose (unMutez minBound, unMutez maxBound)
src/Michelson/Test/Import.hs view
@@ -145,8 +145,8 @@   case (eqT @cp @cp', eqT @st @st') of     (Just Refl, Just Refl) -> pure (contract, tContract)     (Nothing, _) -> Left $-      ICEUnexpectedParamType (U.para contract) (toUType $ demote @cp)-    _ -> Left (ICEUnexpectedStorageType (U.stor contract) (toUType $ demote @st))+      ICEUnexpectedParamType (U.contractParameter contract) (toUType $ demote @cp)+    _ -> Left (ICEUnexpectedStorageType (U.contractStorage contract) (toUType $ demote @st))  -- | Import contract from a given file path. --@@ -166,7 +166,7 @@  -- | Error type for 'importContract' function. data ImportContractError-  = ICEUnexpectedParamType U.Type U.Type+  = ICEUnexpectedParamType U.ParameterType U.Type   | ICEUnexpectedStorageType U.Type U.Type   | ICEParse ParserException   | ICETypeCheck TCError
src/Michelson/Test/Unit.hs view
@@ -24,9 +24,8 @@ import Michelson.Interpret (ContractEnv, ContractReturn, MichelsonFailed(..), interpret) import Michelson.Printer (printUntypedContract) import Michelson.Runtime (parseExpandContract)-import Michelson.Typed (FullContract, IsoValue(..), ToT, epNameToParamAnn)+import Michelson.Typed (FullContract, IsoValue(..), ToT) import qualified Michelson.Typed as T-import Michelson.Untyped (EpName, para) import Michelson.Untyped hiding (Contract) import qualified Michelson.Untyped as U @@ -101,7 +100,8 @@   where     parsedContract = parseExpandContract Nothing       (toText $ printUntypedContract True contract)-    phi (para -> Type t _) = conv $ filter (\ep -> not (hasEp t ep)) (Map.toList eps)+    phi (contractParameter -> ParameterType (Type t _) _) =+      conv $ filter (\ep -> not (hasEp t ep)) (Map.toList eps)     conv l | null l = Right ()            | otherwise = Left $ fromList l
src/Michelson/Text.hs view
@@ -36,7 +36,6 @@ import Data.Data (Data) import qualified Data.Text as T import Fmt (Buildable)-import GHC.TypeLits (ErrorMessage(..), TypeError) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import Test.QuickCheck (Arbitrary(..), choose, listOf)
src/Michelson/TypeCheck.hs view
@@ -4,7 +4,6 @@   , typeVerifyTopLevelType   , typeCheckValue   , typeCheckList-  , typeCheckCValue   , typeCheckExt   , module E   , module M@@ -18,6 +17,5 @@ import Michelson.TypeCheck.Instr import Michelson.TypeCheck.TypeCheck as T import Michelson.TypeCheck.Types as M-import Michelson.TypeCheck.Value  import Michelson.TypeCheck.Helpers (eqType, matchTypes)
src/Michelson/TypeCheck/Error.hs view
@@ -2,13 +2,14 @@  module Michelson.TypeCheck.Error   ( NotEnoughItemsInstr (..)+  , TypeContext (..)   , TCTypeError (..)   , TCError (..)   , ExtError (..)   , StackSize (..)   ) where -import Fmt (Buildable(..), listF, pretty, (+|), (+||), (|+), (||+))+import Fmt (Buildable(..), pretty, (+|), (+||), (|+), (||+)) import qualified Text.Show (show)  import Michelson.ErrorPos (InstrCallStack)@@ -40,6 +41,46 @@     NotEnoughDig -> "DIG"     NotEnoughDug -> "DUG" +-- | Contexts where type error can occur.+data TypeContext+  = LambdaArgument+  | LambdaCode+  | DipCode+  | ConsArgument+  | ComparisonArguments+  | ContractParameter+  | ContractStorage+  | ArithmeticOperation+  | Iteration+  | Cast+  | CarArgument+  | CdrArgument+  | If+  | ConcatArgument+  | ContainerKeyType+  | ContainerValueType+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)++instance Buildable TypeContext where+  build = \case+    LambdaArgument -> "argument to some lambda"+    LambdaCode -> "code in LAMBDA"+    DipCode -> "code in DIP"+    ConsArgument -> "argument to CONS"+    ComparisonArguments -> "arguments to comparison function"+    ContractParameter -> "contract parameter"+    ContractStorage -> "contract storage"+    ArithmeticOperation -> "arguments to arithmetic operation"+    Iteration -> "iteration (ITER / MAP / etc) code"+    Cast -> "argument to CAST"+    CarArgument -> "argument to CAR"+    CdrArgument -> "argument to CDR"+    If -> "conditional expression"+    ConcatArgument -> "argument to CONCAT"+    ContainerKeyType -> "container key type"+    ContainerValueType -> "container value type"+ -- | Data type that represents various errors -- which are related to type system. -- These errors are used to specify info about type check errors@@ -51,10 +92,16 @@   -- ^ Type equality error   | StackEqError [T.T] [T.T]   -- ^ Stacks equality error-  | UnsupportedTypes [T.T]+  | UnsupportedTypeForScope T.T T.BadTypeForScope   -- ^ Error that happens when type cannot be used in the corresponding scope.-  -- Argument of this constructor carries types which, in the aggregate, violate-  -- the restriction (e.g. @timestamp@ and @timestamp@ passed to @MUL@ instruction).+  -- Argument of this constructor carries type which violates+  -- the restriction, e.g. @big_map@ in @UNPACK@, and a concrete reason why the+  -- type is unsuported.+  | 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).+  | InvalidInstruction U.ExpandedInstr+  -- ^ Some instruction can not be used in a specific context, like @SELF@ in @LAMBDA@.   | 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`)@@ -78,9 +125,14 @@   -- ^ KeyHash couldn't be parsed from its textual representation   | InvalidTimestamp   -- ^ Timestamp is not RFC339 compliant+  | CodeAlwaysFails+  -- ^ Code always fails, but shouldn't, like ITER body.+  | EmptyCode+  -- ^ Empty block of code, like ITER body.+  | AnyError+  -- ^ Generic error when instruction does not match something sensible.   deriving stock (Show, Eq, Generic)--instance NFData TCTypeError+  deriving anyclass (NFData)  instance Buildable TCTypeError where   build = \case@@ -89,8 +141,14 @@       "Types not equal: " +| type1 |+ " /= " +| type2 |+ ""     StackEqError st1 st2 ->       "Stacks not equal: " +| buildStack st1 |+ " /= " +| buildStack st2 |+ ""-    UnsupportedTypes types ->-      "Unsupported types: " +| listF types |+ ""+    UnsupportedTypeForScope typ reason ->+      "Type '" +| typ |+ "' is unsupported here because it "+      +| reason |+ ""+    NotNumericTypes t1 t2 ->+      "Some of the types in an arithmetic operation are not numeric: "+      +| t1 |+ " and " +| t2 |+ ""+    InvalidInstruction instr ->+      "Forbidden instruction " +| instr |+ ""     InvalidValueType t ->       "Value type is never a valid `" +| t |+ "`"     NotEnoughItemsOnStack n instr ->@@ -106,10 +164,13 @@     InvalidAddress e -> build e     InvalidKeyHash e -> build e     InvalidTimestamp -> "Is not a valid RFC3339 timestamp"+    CodeAlwaysFails -> "Code always fails, but is not supposed to"+    EmptyCode -> "Code block is empty"+    AnyError -> "Some of the arguments have invalid types"  -- | Type check error data TCError-  = TCFailedOnInstr U.ExpandedInstr SomeHST Text InstrCallStack (Maybe TCTypeError)+  = TCFailedOnInstr U.ExpandedInstr SomeHST InstrCallStack (Maybe TypeContext) (Maybe TCTypeError)   | TCFailedOnValue U.Value T.T Text InstrCallStack (Maybe TCTypeError)   | TCContractError Text (Maybe TCTypeError)   | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp)@@ -122,11 +183,12 @@ -- Buildable instance within TM-151. instance Buildable TCError where   build = \case-    TCFailedOnInstr instr (SomeHST t) custom _ mbTCTypeError ->+    TCFailedOnInstr instr (SomeHST t) _ mbTCTypeContext mbTCTypeError ->       "Error checking expression "       +| instr |+ " against input stack type "-      +| t ||+ bool (": " +| custom |+ " ") "" (null custom)-      +| (maybe "" (\e -> " " +| e |+ "") mbTCTypeError)+      +| t |+ maybe "" (\c -> ". Error in " +| c |+ "") mbTCTypeContext+      +| maybe "" (\e -> ": " +| e |+ "") mbTCTypeError+      +| "."     TCFailedOnValue v t custom _ mbTCTypeError ->       "Error checking value "       +| v |+ " against type "@@ -138,8 +200,8 @@     TCUnreachableCode _ instrs ->       "Unreachable code: " +| buildTruncated 3 (toList instrs)     TCExtError (SomeHST t) _ e ->-      "Error occured during Morley extension typecheck: "-      +| e |+ " on stack " +| t ||+ ""+      "Error occurred during Morley extension typecheck: "+      +| e |+ " on stack " +| t |+ ""     where     buildTruncated k l       | null (drop k l) = build l
src/Michelson/TypeCheck/Ext.hs view
@@ -4,8 +4,9 @@   ) where  import Control.Lens ((%=))+import Data.Constraint (Dict(..)) import Control.Monad.Except (MonadError, liftEither, throwError)-import Data.Map.Lazy (Map, insert, lookup)+import Data.Map.Lazy (insert, lookup) import Data.Typeable ((:~:)(..))  import Michelson.ErrorPos@@ -16,10 +17,10 @@ import Michelson.Typed (Notes(..), converge, mkUType, notesT, withUType) import qualified Michelson.Typed as T import Michelson.Untyped-  (CT(..), ExpandedOp, StackFn, TyVar(..), Type, Var, VarAnn, inPattern, outPattern,+  (ExpandedOp, StackFn, TyVar(..), Type, Var, VarAnn, inPattern, outPattern,   quantifiedVars, varSet) import qualified Michelson.Untyped as U-import Util.Peano (Sing(SS, SZ))+import Util.Peano (SingNat(SS, SZ))  type TypeCheckListHandler inp =      [U.ExpandedOp]@@ -45,16 +46,20 @@       case si of         AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError                          "TEST_ASSERT has to return Bool, but it always fails"-        instr ::: (((_ :: (T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do+        instr ::: (((_ :: (T.Notes b, Dict (T.WellTyped b), VarAnn)) ::& (_ :: HST out1))) -> do           Refl <- liftEither $                     first (const $ TCExtError (SomeHST hst) instrPos $                            TestAssertError "TEST_ASSERT has to return Bool, but returned something else") $-                      eqType @b @('T.Tc 'CBool)+                      eqType @b @'T.TBool           tcom <- verifyPrint tassComment           pure . toSomeInstr $ T.TEST_ASSERT $ T.TestAssert tassName tcom instr         _ ->           throwError $ TCExtError (SomeHST hst) instrPos $             TestAssertError "TEST_ASSERT has to return Bool, but the stack is empty"+    U.UCOMMENT t ->+      -- TODO if we are going to analyze/parse programs from files,+      -- there should be parsing of string and creation of FunctionStarted/FunctionFinished/etc+      pure $ toSomeInstr $ T.COMMENT_ITEM $ T.JustComment t   where     verifyPrint :: U.PrintComment -> TypeCheckInstr (T.PrintComment s)     verifyPrint (U.PrintComment pc) = do@@ -125,7 +130,7 @@     go m _ U.StkEmpty SNil = pure $ BoundVars m Nothing     go _ _ U.StkEmpty _    = Left $ LengthMismatch s     go _ _ _ SNil        = Left $ LengthMismatch s-    go m n (U.StkCons tyVar ts) ((xann :: Notes xt, _) ::& xs) =+    go m n (U.StkCons tyVar ts) ((xann :: Notes xt, _, _) ::& xs) =       let         handleType :: U.Type -> Either ExtError BoundVars         handleType t =
src/Michelson/TypeCheck/Helpers.hs view
@@ -14,10 +14,9 @@      , ensureDistinctAsc     , eqType-    , checkEqT-    , checkEqHST     , onTypeCheckInstrAnnErr     , onTypeCheckInstrErr+    , onScopeCheckInstrErr     , typeCheckInstrErr     , typeCheckInstrErr'     , typeCheckImpl@@ -36,24 +35,26 @@     , mulImpl     , edivImpl     , unaryArithImpl+    , withCompareableCheck     ) where  import Prelude hiding (EQ, GT, LT) -import Control.Monad.Except (MonadError, liftEither, throwError)+import Control.Monad.Except (MonadError, throwError)+import Data.Constraint (Dict(..), withDict) import Data.Default (def)-import Data.Singletons (SingI(sing), demote)+import Data.Singletons (Sing, SingI(sing), demote) import qualified Data.Text as T import Data.Typeable ((:~:)(..), eqT) import Fmt ((+||), (||+))  import Michelson.ErrorPos (InstrCallStack)-import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))+import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..), TypeContext(..)) import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.Types import Michelson.Typed-  (CT(..), Instr(..), Notes(..), PackedNotes(..), Sing(..), T(..), converge, notesT, orAnn,-  starNotes)+  (BadTypeForScope(..), Comparable, Instr(..), Notes(..), PackedNotes(..),+   SingT(..), T(..), WellTyped, converge , getComparableProofS, notesT, orAnn, starNotes) import Michelson.Typed.Annotation (AnnConvergeError, isStar) import Michelson.Typed.Arith (Add, ArithOp(..), Mul, Sub, UnaryArithOp(..)) import Michelson.Typed.Polymorphic@@ -123,11 +124,11 @@    in (an, avn)  convergeHSTEl-  :: (Notes t, VarAnn)-  -> (Notes t, VarAnn)-  -> Either AnnConvergeError (Notes t, VarAnn)-convergeHSTEl (an, avn) (bn, bvn) =-  (,) <$> converge an bn+  :: (Notes t, Dict (WellTyped t), VarAnn)+  -> (Notes t, Dict (WellTyped t), VarAnn)+  -> Either AnnConvergeError (Notes t, Dict (WellTyped t), VarAnn)+convergeHSTEl (an, d@Dict, avn) (bn, _, bvn) =+  (,,) <$> converge an bn <*> pure d       <*> pure (bool def avn $ avn == bvn)  -- | Combine annotations from two given stack types@@ -144,7 +145,7 @@ hstToTs :: HST st -> [T] hstToTs = \case   SNil -> []-  (notes, _) ::& hst -> notesT notes : hstToTs hst+  (notes, _, _) ::& hst -> notesT notes : hstToTs hst  -- | Check whether the given stack types are equal. eqHST@@ -162,7 +163,7 @@ -- given type. This function is a specialized version of `eqHST`. eqHST1   :: forall t st.-      (Typeable st, Typeable t, SingI t)+      (Typeable st, Typeable t, SingI t, WellTyped t)   => HST st -> Either TCTypeError (st :~: '[t]) eqHST1 hst = do   let hst' = sing @t -:& SNil@@ -188,19 +189,6 @@     else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ")"   l -> Right l -checkEqT-  :: forall (a :: T) (b :: T) ts m .-  ( Each [Typeable, SingI] [a, b], Typeable ts-  , MonadReader InstrCallStack m, MonadError TCError m-  )-  => Un.ExpandedInstr-  -> HST ts-  -> Text-  -> m (a :~: b)-checkEqT instr i m = do-  pos <- ask-  liftEither $ eqType @a @b `onLeft` (TCFailedOnInstr instr (SomeHST i) (m <> ": ") pos . Just)- -- | Function @eqType@ is a simple wrapper around @Data.Typeable.eqT@ suited -- for use within @Either TCTypeError a@ applicative. eqType@@ -209,47 +197,59 @@   => Either TCTypeError (a :~: b) eqType = maybe (Left $ TypeEqError (demote @a) (demote @b)) pure eqT -checkEqHST-  :: forall (a :: [T]) (b :: [T]) ts m .-  ( Typeable a, Typeable b, Typeable ts-  , MonadReader InstrCallStack m, MonadError TCError m-  )-  => HST a-  -> HST b-  -> Un.ExpandedInstr-  -> HST ts-  -> Text-  -> m (a :~: b)-checkEqHST a b instr i m = do-  pos <- ask-  liftEither $ eqHST a b `onLeft` (TCFailedOnInstr instr (SomeHST i) (m <> ": ") pos . Just)- onTypeCheckInstrErr   :: (MonadReader InstrCallStack m, MonadError TCError m)-  => Un.ExpandedInstr -> SomeHST -> Text -> Either TCTypeError a -> m a-onTypeCheckInstrErr instr hst msg ei = do-  either (typeCheckInstrErr' instr hst msg) return ei+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> Either TCTypeError a -> m a+onTypeCheckInstrErr instr hst mContext ei = do+  either (typeCheckInstrErr' instr hst mContext) return ei +onScopeCheckInstrErr+  :: forall (t :: T) m a.+      (MonadReader InstrCallStack m, MonadError TCError m, SingI t)+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> Either BadTypeForScope a -> m a+onScopeCheckInstrErr instr hst mContext = \case+  Right a -> return a+  Left e -> do+    pos <- ask+    throwError $ TCFailedOnInstr instr hst pos mContext $+      Just $ UnsupportedTypeForScope (demote @t) e+ typeCheckInstrErr   :: (MonadReader InstrCallStack m, MonadError TCError m)-  => Un.ExpandedInstr -> SomeHST -> Text -> m a-typeCheckInstrErr instr hst msg = do+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> m a+typeCheckInstrErr instr hst mContext = do   pos <- ask-  throwError $ TCFailedOnInstr instr hst msg pos Nothing+  throwError $ TCFailedOnInstr instr hst pos mContext Nothing  typeCheckInstrErr'   :: (MonadReader InstrCallStack m, MonadError TCError m)-  => Un.ExpandedInstr -> SomeHST -> Text -> TCTypeError -> m a-typeCheckInstrErr' instr hst msg err = do+  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext+  -> TCTypeError -> m a+typeCheckInstrErr' instr hst mContext err = do   pos <- ask-  throwError $ TCFailedOnInstr instr hst msg pos (Just err)+  throwError $ TCFailedOnInstr instr hst pos mContext (Just err)  onTypeCheckInstrAnnErr   :: (MonadReader InstrCallStack m, MonadError TCError m, Typeable ts)-  => Un.ExpandedInstr -> HST ts -> Text -> Either AnnConvergeError a -> m a-onTypeCheckInstrAnnErr instr i msg ei =-  onTypeCheckInstrErr instr (SomeHST i) msg (ei `onLeft` AnnError)+  => Un.ExpandedInstr -> HST ts -> Maybe TypeContext+  -> Either AnnConvergeError a -> m a+onTypeCheckInstrAnnErr instr i mContext ei =+  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onLeft` AnnError) +withCompareableCheck+  :: forall a m v ts. (Typeable ts, MonadReader InstrCallStack m, MonadError TCError m)+  => Sing a+  -> Un.ExpandedInstr+  -> HST ts+  -> (Comparable a => v)+  -> m v+withCompareableCheck sng instr i act = case getComparableProofS sng of+  Just d@Dict -> pure $ withDict d act+  Nothing -> typeCheckInstrErr instr (SomeHST i) $ Just ComparisonArguments+ typeCheckImpl   :: forall inp . Typeable inp   => TcInstrHandler@@ -304,8 +304,8 @@     wrapWithNotes :: HST d -> Instr c d -> Instr c d     wrapWithNotes h ins = case h of       -- do not wrap in notes if the notes are "star"-      ((n, _) ::& _) | isStar n -> ins-      ((n, _) ::& _) -> InstrWithNotes (PackedNotes n) ins+      ((n, _, _) ::& _) | isStar n -> ins+      ((n, _, _) ::& _) -> InstrWithNotes (PackedNotes n) ins       SNil -> ins      extractInstrPos :: Un.ExpandedOp -> InstrCallStack@@ -328,10 +328,10 @@  -- | Generic implementation for MEMeration memImpl-  :: forall (q :: CT) (c :: T) ts inp m .+  :: forall (q :: T) (c :: T) ts inp m .     ( MonadReader InstrCallStack m, MonadError TCError m, Typeable ts     , Typeable (MemOpKey c), SingI (MemOpKey c), MemOp c-    , inp ~ ('Tc q : c : ts)+    , inp ~ (q : c : ts)     )   => Un.ExpandedInstr   -> HST inp@@ -339,16 +339,17 @@   -> m (SomeInstr inp) memImpl instr i@(_ ::& _ ::& rs) vn = do   pos <- ask-  case eqType @('Tc q) @('Tc (MemOpKey c)) of-    Right Refl -> pure $ i :/ MEM ::: ((starNotes, vn) ::& rs)+  case eqType @q @(MemOpKey c) of+    Right Refl -> pure $ i :/ MEM ::: ((starNotes, Dict, vn) ::& rs)     Left m     -> throwError $-      TCFailedOnInstr instr (SomeHST i) "query element type is not equal to set's element type" pos (Just m)+      TCFailedOnInstr instr (SomeHST i) pos (Just ContainerKeyType) (Just m)  getImpl   :: forall c getKey rs inp m .     ( GetOp c, Typeable (GetOpKey c)     , Typeable (GetOpVal c)     , SingI (GetOpVal c), SingI (GetOpKey c)+    , WellTyped (GetOpVal c)     , inp ~ (getKey : c : rs)     , MonadReader InstrCallStack m     , MonadError TCError m@@ -360,11 +361,11 @@   -> m (SomeInstr inp) getImpl instr i@(_ ::& _ ::& rs) vns vn = do   pos <- ask-  case eqType @getKey @('Tc (GetOpKey c)) of+  case eqType @getKey @(GetOpKey c) of     Right Refl -> do       let rn = NTOption def vns-      pure $ i :/ GET ::: ((rn, vn) ::& rs)-    Left m -> throwError $ TCFailedOnInstr instr (SomeHST i) "wrong key stack type" pos (Just m)+      pure $ i :/ GET ::: ((rn, Dict, vn) ::& rs)+    Left m -> throwError $ TCFailedOnInstr instr (SomeHST i) pos (Just ContainerKeyType) (Just m)  updImpl   :: forall c updKey updParams rs inp m .@@ -381,13 +382,13 @@   -> m (SomeInstr inp) updImpl instr i@(_ ::& _ ::& cTuple ::& rest) vn = do   pos <- ask-  case (eqType @updKey @('Tc (UpdOpKey c)), eqType @updParams @(UpdOpParams c)) of+  case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of     (Right Refl, Right Refl) ->-      pure $ i :/ UPDATE ::: ((cTuple & _2 .~ vn) ::& rest)+      pure $ i :/ UPDATE ::: ((cTuple & _3 .~ vn) ::& rest)     (Left m, _) -> throwError $ TCFailedOnInstr instr (SomeHST i)-                      "wrong key stack type" pos (Just m)+                      pos (Just ContainerKeyType) (Just m)     (_, Left m) -> throwError $ TCFailedOnInstr instr (SomeHST i)-                      "wrong update value stack type" pos (Just m)+                      pos (Just ContainerValueType) (Just m)  sizeImpl   :: (SizeOp c, inp ~ (c ': rs), Monad m)@@ -395,59 +396,61 @@   -> VarAnn   -> m (SomeInstr inp) sizeImpl i@(_ ::& rs) vn =-  pure $ i :/ SIZE ::: ((starNotes, vn) ::& rs)+  pure $ i :/ SIZE ::: ((starNotes, Dict, vn) ::& rs)  sliceImpl-  :: (SliceOp c, Typeable c, inp ~ ('Tc 'CNat ': 'Tc 'CNat ': c ': rs), Monad m)+  :: (SliceOp c, Typeable c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m)   => HST inp   -> Un.VarAnn   -> m (SomeInstr inp)-sliceImpl i@(_ ::& _ ::& (cn, cvn) ::& rs) vn = do+sliceImpl i@(_ ::& _ ::& (cn, Dict, cvn) ::& rs) vn = do   let vn' = vn `orAnn` deriveVN "slice" cvn       rn = NTOption def cn-  pure $ i :/ SLICE ::: ((rn, vn') ::& rs)+  pure $ i :/ SLICE ::: ((rn, Dict, vn') ::& rs)  concatImpl'-  :: (ConcatOp c, Typeable c, SingI c, inp ~ ('TList c : rs), Monad m)+  :: (ConcatOp c, Typeable c, SingI c, WellTyped c, inp ~ ('TList c : rs), Monad m)   => HST inp   -> Un.VarAnn   -> m (SomeInstr inp)-concatImpl' i@((NTList _ n, _) ::& rs) vn = do-  pure $ i :/ CONCAT' ::: ((n, vn) ::& rs)+concatImpl' i@((NTList _ n, Dict, _) ::& rs) vn = do+  pure $ i :/ CONCAT' ::: ((n, Dict, vn) ::& rs)  concatImpl   :: ( ConcatOp c, Typeable c, inp ~ (c ': c ': rs)+     , WellTyped c      , MonadReader InstrCallStack m      , MonadError TCError m      )   => HST inp   -> Un.VarAnn   -> m (SomeInstr inp)-concatImpl i@((cn1, _) ::& (cn2, _) ::& rs) vn = do-  cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i "wrong operand types for concat operation" (converge cn1 cn2)-  pure $ i :/ CONCAT ::: ((cn, vn) ::& rs)+concatImpl i@((cn1, _, _) ::& (cn2, _, _) ::& rs) vn = do+  cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i (Just ConcatArgument) (converge cn1 cn2)+  pure $ i :/ CONCAT ::: ((cn, Dict, vn) ::& rs)  -- | Helper function to construct instructions for binary arithmetic -- operations. arithImpl   :: ( Typeable (ArithRes aop n m)      , SingI (ArithRes aop n m)-     , Typeable ('Tc (ArithRes aop n m) ': s)-     , inp ~ ('Tc n ': 'Tc m ': s)+     , Typeable (ArithRes aop n m ': s)+     , WellTyped (ArithRes aop n m)+     , inp ~ (n ': m ': s)      , Monad t      )-  => Instr inp ('Tc (ArithRes aop n m) ': s)+  => Instr inp (ArithRes aop n m ': s)   -> HST inp   -> VarAnn   -> t (SomeInstr inp) arithImpl mkInstr i@(_ ::& _ ::& rs) vn = do-  pure $ i :/ mkInstr ::: ((starNotes, vn) ::& rs)+  pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)  addImpl   :: forall a b inp rs m.      ( Typeable rs      , Each [Typeable, SingI] [a, b]-     , inp ~ ('Tc a ': 'Tc b ': rs)+     , inp ~ (a ': b ': rs)      , MonadReader InstrCallStack m      , MonadError TCError m      )@@ -456,22 +459,21 @@   -> VarAnn   -> m (SomeInstr inp) addImpl t1 t2 = case (t1, t2) of-  (SCInt, SCInt) -> arithImpl @Add ADD-  (SCInt, SCNat) -> arithImpl @Add ADD-  (SCNat, SCInt) -> arithImpl @Add ADD-  (SCNat, SCNat) -> arithImpl @Add ADD-  (SCInt, SCTimestamp) -> arithImpl @Add ADD-  (SCTimestamp, SCInt) -> arithImpl @Add ADD-  (SCMutez, SCMutez) -> arithImpl @Add ADD-  _ -> \i vn -> onTypeCheckInstrErr (Un.ADD vn) (SomeHST i)-    "wrong operand types for add operation"-    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+  (STInt, STInt) -> arithImpl @Add ADD+  (STInt, STNat) -> arithImpl @Add ADD+  (STNat, STInt) -> arithImpl @Add ADD+  (STNat, STNat) -> arithImpl @Add ADD+  (STInt, STTimestamp) -> arithImpl @Add ADD+  (STTimestamp, STInt) -> arithImpl @Add ADD+  (STMutez, STMutez) -> arithImpl @Add ADD+  _ -> \i vn -> typeCheckInstrErr' (Un.ADD vn) (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)  edivImpl   :: forall a b inp rs m.      ( Typeable rs      , Each [Typeable, SingI] [a, b]-     , inp ~ ('Tc a ': 'Tc b ': rs)+     , inp ~ (a ': b ': rs)      , MonadReader InstrCallStack m      , MonadError TCError m      )@@ -480,15 +482,14 @@   -> VarAnn   -> m (SomeInstr inp) edivImpl t1 t2 = case (t1, t2) of-  (SCInt, SCInt) -> edivImplDo-  (SCInt, SCNat) -> edivImplDo-  (SCNat, SCInt) -> edivImplDo-  (SCNat, SCNat) -> edivImplDo-  (SCMutez, SCMutez) -> edivImplDo-  (SCMutez, SCNat) -> edivImplDo-  _ -> \i vn -> onTypeCheckInstrErr (Un.EDIV vn) (SomeHST i)-    "wrong operand types for ediv operation"-    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+  (STInt, STInt) -> edivImplDo+  (STInt, STNat) -> edivImplDo+  (STNat, STInt) -> edivImplDo+  (STNat, STNat) -> edivImplDo+  (STMutez, STMutez) -> edivImplDo+  (STMutez, STNat) -> edivImplDo+  _ -> \i vn -> typeCheckInstrErr' (Un.EDIV vn) (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)  edivImplDo   :: ( EDivOp n m@@ -496,20 +497,22 @@      , Typeable (EModOpRes n m)      , SingI (EDivOpRes n m)      , Typeable (EDivOpRes n m)-     , inp ~ ('Tc n ': 'Tc m ': s)+     , WellTyped (EModOpRes n m)+     , WellTyped (EDivOpRes n m)+     , inp ~ (n ': m ': s)      , Monad t      )   => HST inp   -> VarAnn   -> t (SomeInstr inp) edivImplDo i@(_ ::& _ ::& rs) vn = do-  pure $ i :/ EDIV ::: ((starNotes, vn) ::& rs)+  pure $ i :/ EDIV ::: ((starNotes, Dict, vn) ::& rs)  subImpl   :: forall a b inp rs m.      ( Typeable rs      , Each [Typeable, SingI] [a, b]-     , inp ~ ('Tc a ': 'Tc b ': rs)+     , inp ~ (a ': b ': rs)      , MonadReader InstrCallStack m      , MonadError TCError m      )@@ -518,22 +521,21 @@   -> VarAnn   -> m (SomeInstr inp) subImpl t1 t2 = case (t1, t2) of-  (SCInt, SCInt) -> arithImpl @Sub SUB-  (SCInt, SCNat) -> arithImpl @Sub SUB-  (SCNat, SCInt) -> arithImpl @Sub SUB-  (SCNat, SCNat) -> arithImpl @Sub SUB-  (SCTimestamp, SCTimestamp) -> arithImpl @Sub SUB-  (SCTimestamp, SCInt) -> arithImpl @Sub SUB-  (SCMutez, SCMutez) -> arithImpl @Sub SUB-  _ -> \i vn -> onTypeCheckInstrErr (Un.SUB vn) (SomeHST i)-    "wrong operand types for sub operation"-    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+  (STInt, STInt) -> arithImpl @Sub SUB+  (STInt, STNat) -> arithImpl @Sub SUB+  (STNat, STInt) -> arithImpl @Sub SUB+  (STNat, STNat) -> arithImpl @Sub SUB+  (STTimestamp, STTimestamp) -> arithImpl @Sub SUB+  (STTimestamp, STInt) -> arithImpl @Sub SUB+  (STMutez, STMutez) -> arithImpl @Sub SUB+  _ -> \i vn -> typeCheckInstrErr' (Un.SUB vn) (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)  mulImpl   :: forall a b inp rs m.      ( Typeable rs      , Each [Typeable, SingI] [a, b]-     , inp ~ ('Tc a ': 'Tc b ': rs)+     , inp ~ (a ': b ': rs)      , MonadReader InstrCallStack m      , MonadError TCError m      )@@ -542,28 +544,28 @@   -> VarAnn   -> m (SomeInstr inp) mulImpl t1 t2 = case (t1, t2) of-  (SCInt, SCInt) -> arithImpl @Mul MUL-  (SCInt, SCNat) -> arithImpl @Mul MUL-  (SCNat, SCInt) -> arithImpl @Mul MUL-  (SCNat, SCNat) -> arithImpl @Mul MUL-  (SCNat, SCMutez) -> arithImpl @Mul MUL-  (SCMutez, SCNat) -> arithImpl @Mul MUL-  _ -> \i vn -> onTypeCheckInstrErr (Un.MUL vn) (SomeHST i)-    "wrong operand types for mul operation"-    (Left $ UnsupportedTypes [demote @('Tc a), demote @('Tc b)])+  (STInt, STInt) -> arithImpl @Mul MUL+  (STInt, STNat) -> arithImpl @Mul MUL+  (STNat, STInt) -> arithImpl @Mul MUL+  (STNat, STNat) -> arithImpl @Mul MUL+  (STNat, STMutez) -> arithImpl @Mul MUL+  (STMutez, STNat) -> arithImpl @Mul MUL+  _ -> \i vn -> typeCheckInstrErr' (Un.MUL vn) (SomeHST i) (Just ArithmeticOperation) $+    NotNumericTypes (demote @a) (demote @b)  -- | Helper function to construct instructions for binary arithmetic -- operations. unaryArithImpl   :: ( Typeable (UnaryArithRes aop n)      , SingI (UnaryArithRes aop n)-     , Typeable ('Tc (UnaryArithRes aop n) ': s)-     , inp ~ ('Tc n ': s)+     , Typeable (UnaryArithRes aop n ': s)+     , WellTyped (UnaryArithRes aop n)+     , inp ~ (n ': s)      , Monad t      )-  => Instr inp ('Tc (UnaryArithRes aop n) ': s)+  => Instr inp (UnaryArithRes aop n ': s)   -> HST inp   -> VarAnn   -> t (SomeInstr inp) unaryArithImpl mkInstr i@(_ ::& rs) vn = do-  pure $ i :/ mkInstr ::: ((starNotes, vn) ::& rs)+  pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)
src/Michelson/TypeCheck/Instr.hs view
@@ -35,10 +35,9 @@ import Prelude hiding (EQ, GT, LT)  import Control.Monad.Except (MonadError, liftEither, throwError)-import Data.Constraint (Dict(..)) import Data.Default (def) import Data.Generics (everything, mkQ)-import Data.Singletons (SingI(sing), demote)+import Data.Singletons (Sing, demote) import Data.Typeable ((:~:)(..))  import Michelson.ErrorPos@@ -48,6 +47,7 @@ import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.Types import Michelson.TypeCheck.Value+import Michelson.Typed.Value  import Michelson.Typed import Util.Peano@@ -59,64 +59,69 @@   :: TcOriginatedContracts   -> U.Contract   -> Either TCError SomeContract-typeCheckContract cs c = runTypeCheck (U.para c) cs $ typeCheckContractImpl c+typeCheckContract cs c =+  runTypeCheck (U.contractParameter c) cs $ typeCheckContractImpl c +withWTP :: forall t a. SingI t => (WellTyped t => TypeCheck a) -> TypeCheck a+withWTP fn = case getWTP @t of+  Just Dict -> fn+  Nothing -> throwError $ TCContractError "Not a well typed value" Nothing++withWTPInstr_ :: forall t a. SingI t => U.ExpandedInstr -> SomeHST -> (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a+withWTPInstr_ v t fn = case getWTP @t of+  Just Dict -> fn+  Nothing -> do+    loc <- ask+    throwError $ TCFailedOnInstr v t loc Nothing Nothing+ typeCheckContractImpl   :: U.Contract   -> TypeCheck SomeContract-typeCheckContractImpl (U.Contract mParam mStorage pCode) = do-  code <- maybe (throwError $ TCContractError "no instructions in contract code" Nothing)+typeCheckContractImpl (U.Contract (U.ParameterType mParam rootAnn) mStorage pCode) = do+  _ <- maybe (throwError $ TCContractError "no instructions in contract code" $ Just EmptyCode)                 pure (nonEmpty pCode)   withUType mParam $ \(paramNote :: Notes param) ->     withUType mStorage $ \(storageNote :: Notes st) -> do-      (Dict, Dict) <--        note (hasTypeError "parameter" paramNote) $-          (,) <$> opAbsense (notesSing paramNote)-              <*> nestedBigMapsAbsense (notesSing paramNote)-      (Dict, Dict, Dict) <--        note (hasTypeError "storage" storageNote) $-          (,,) <$> opAbsense (notesSing storageNote)-               <*> nestedBigMapsAbsense (notesSing storageNote)-               <*> contractTypeAbsense (notesSing storageNote)-      let inpNote = NTPair def def def paramNote storageNote-      let inp = (inpNote, def) ::& SNil-      inp' :/ instrOut <- typeCheckNE code inp-      let (paramNotesRaw, fcStoreNotes) = case inp' of-            (NTPair _ _ _ cpNotes stNotes, _) ::& SNil -> (cpNotes, stNotes)-      fcParamNotesSafe <--        liftEither $-        mkParamNotes paramNotesRaw `onLeft`-        (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)-      case instrOut of-        instr ::: out -> liftEither $ do-          case eqHST1 @(ContractOut1 st) out of-            Right Refl -> do-              let (outN, _) ::& SNil = out-              _ <- converge outN (NTPair def def def starNotes storageNote)-                      `onLeft`-                  ((TCContractError "contract output type violates convention:") . Just . AnnError)+      withWTP @st $ do+        withWTP @param $ do+          Dict <- either (hasTypeError @param "parameter") pure+            $ checkScope @(ParameterScope param)+          Dict <- either (hasTypeError @st "storage") pure+            $ checkScope @(StorageScope st)+          let inpNote = NTPair def def def paramNote storageNote+          let inp = (inpNote, Dict, def) ::& SNil+          inp' :/ instrOut <- usingReaderT def $ typeCheckImpl typeCheckInstr pCode inp+          let (paramNotesRaw, fcStoreNotes) = case inp' of+                (NTPair _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)+          fcParamNotes <-+            liftEither $+            mkParamNotes paramNotesRaw rootAnn `onLeft`+                (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)+          case instrOut of+            instr ::: out -> liftEither $ do+              case eqHST1 @(ContractOut1 st) out of+                Right Refl -> do+                  let (outN, _, _) ::& SNil = out+                  _ <- converge outN (NTPair def def def starNotes storageNote)+                          `onLeft`+                      ((TCContractError "contract output type violates convention:") . Just . AnnError)+                  pure $ SomeContract FullContract+                    { fcCode = instr+                , fcParamNotes+                , fcStoreNotes+                    }+                Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err+            AnyOutInstr instr ->               pure $ SomeContract FullContract                 { fcCode = instr-                , fcParamNotesSafe, fcStoreNotes+            , fcParamNotes+            , fcStoreNotes                 }-            Left err -> Left $ TCContractError "contract output type violates convention:" $ Just err-        AnyOutInstr instr ->-          pure $ SomeContract FullContract-            { fcCode = instr-            , fcParamNotesSafe, fcStoreNotes-            }   where-    hasTypeError name (_ :: proxy t) =+    hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a+    hasTypeError name reason = throwError $       TCContractError ("contract " <> name <> " type error") $-      Just $ UnsupportedTypes [demote @t]---- | Like 'typeCheck', but for non-empty lists.-typeCheckNE-  :: (Typeable inp)-  => NonEmpty U.ExpandedOp-  -> HST inp-  -> TypeCheck (SomeInstr inp)-typeCheckNE (x :| xs) = usingReaderT def . typeCheckImpl typeCheckInstr (x : xs)+      Just $ UnsupportedTypeForScope (demote @t) reason  -- | Function @typeCheckList@ converts list of Michelson instructions -- given in representation from @Michelson.Type@ module to representation@@ -220,8 +225,8 @@       go n i = case (n, i) of         (0, _) -> pure (TCDropHelper SZ i) -        (_, SNil) -> onTypeCheckInstrErr uInstr-          (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDrop))+        (_, SNil) -> typeCheckInstrErr' uInstr (SomeHST SNil) Nothing+          $ NotEnoughItemsOnStack nTotal NotEnoughDrop          (_, (_ ::& iTail)) -> do           go (n - 1) iTail <&> \case TCDropHelper s out -> TCDropHelper (SS s) out@@ -242,8 +247,8 @@         -> TypeCheckInstr (TCDigHelper inp)       go n i = case (n, i) of         -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).-        (_, SNil) -> onTypeCheckInstrErr uInstr-          (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDig))+        (_, SNil) -> typeCheckInstrErr' uInstr (SomeHST SNil) Nothing+          $ NotEnoughItemsOnStack nTotal NotEnoughDig          (0, (_ ::& _)) -> pure (TCDigHelper SZ i) @@ -269,238 +274,235 @@         -- Two cases:         -- 1. Input stack is empty.         -- 2. n > 0 and input stack has exactly 1 item.-        _ -> onTypeCheckInstrErr uInstr-          (SomeHST i) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDug))+        _ -> typeCheckInstrErr' uInstr (SomeHST i) Nothing+          $ NotEnoughItemsOnStack nTotal NotEnoughDug    (U.PUSH vn mt mval, i) ->     withUType mt $ \(nt :: Notes t) -> do       val <- typeCheckValue @t mval-      proofOp <--        maybe (onTypeCheckInstrErr uInstr (SomeHST i)-              "Operations in constant are not allowed"-              $ Left $ UnsupportedTypes [demote @t])-        pure (opAbsense $ notesSing nt)-      proofBigMap <--        maybe (onTypeCheckInstrErr uInstr (SomeHST i)-              "BigMaps in constant are not allowed"-              $ Left $ UnsupportedTypes [demote @t])-        pure (bigMapAbsense $ notesSing nt)-      proofContract <--        maybe (onTypeCheckInstrErr uInstr (SomeHST i)-              "Contract type in constant is not allowed"-              $ Left $ UnsupportedTypes [demote @t])-        pure (contractTypeAbsense $ notesSing nt)-      case (proofOp, proofBigMap, proofContract) of-        (Dict, Dict, Dict) -> pure $ i :/ PUSH val ::: ((nt, vn) ::& i)+      proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST i) Nothing+        $ checkScope @(ConstantScope t)+      case proofScope of+        Dict -> withWTPInstr @t $  pure $ i :/ PUSH val ::: ((nt, Dict, vn) ::& i) -  (U.SOME tn vn, (an, _) ::& rs) -> do-    pure (inp :/ SOME ::: ((NTOption tn an, vn) ::& rs))+  (U.SOME tn vn, (an, Dict, _) ::& rs) -> do+    pure (inp :/ SOME ::: ((NTOption tn an, Dict, vn) ::& rs))    (U.NONE tn vn elMt, _) ->-    withUType elMt $ \elNotes ->-      pure $ inp :/ NONE ::: ((NTOption tn elNotes, vn) ::& inp)+    withUType elMt $ \(elNotes :: Notes t) ->+      withWTPInstr @t $+        pure $ inp :/ NONE ::: ((NTOption tn elNotes, Dict, vn) ::& inp)    (U.UNIT tn vn, _) ->-    pure $ inp :/ UNIT ::: ((NTUnit tn, vn) ::& inp)+    pure $ inp :/ UNIT ::: ((NTUnit tn, Dict, vn) ::& inp) -  (U.IF_NONE mp mq, (STOption{}, ons, ovn) ::&+ rs) -> do+  (U.IF_NONE mp mq, (STOption{}, (ons :: Notes ('TOption a)), Dict, ovn) ::&+ rs) -> do     let (an, avn) = deriveNsOption ons ovn-    genericIf IF_NONE U.IF_NONE mp mq rs ((an, avn) ::& rs) inp+    withWTPInstr @a $+      genericIf IF_NONE U.IF_NONE mp mq rs ((an, Dict, avn) ::& rs) inp -  (U.PAIR tn vn pfn qfn, (an, avn) ::& (bn, bvn) ::& rs) -> do+  (U.PAIR tn vn pfn qfn, (an, _, avn) ::& (bn, _, bvn) ::& rs) -> do     let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn-        ns = NTPair tn pfn' qfn' an bn-    pure (inp :/ PAIR ::: ((ns, vn `orAnn` vn') ::& rs))+    case NTPair tn pfn' qfn' an bn of+      (ns :: Notes ('TPair a b)) -> withWTPInstr @('TPair a b) $ pure (inp :/ PAIR ::: ((ns, Dict, vn `orAnn` vn') ::& rs)) -  (U.CAR vn fn, (STPair{}, NTPair pairTN pfn qfn pns qns, pairVN) ::&+ rs) -> do-    pfn' <- onTypeCheckInstrAnnErr uInstr inp "wrong car type:" (convergeAnns fn pfn)-    let vn' = deriveSpecialVN vn pfn' pairVN-        i' = (NTPair pairTN pfn' qfn pns qns, pairVN) ::& rs-    pure $ i' :/ AnnCAR fn ::: ((pns, vn') ::& rs)+  (U.CAR vn fn, (STPair{}, NTPair pairTN pfn qfn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> do+    pfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeAnns 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+        pure $ i' :/ AnnCAR fn ::: ((pns, Dict, vn') ::& rs) -  (U.CDR vn fn, (STPair{}, NTPair pairTN pfn qfn pns qns, pairVN) ::&+ rs) -> do-    qfn' <- onTypeCheckInstrAnnErr uInstr inp "wrong cdr type:" (convergeAnns fn qfn)+  (U.CDR vn fn, (STPair{}, NTPair pairTN pfn qfn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> do+    qfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeAnns fn qfn) -    let vn' = deriveSpecialVN vn qfn' pairVN-        i' = (NTPair pairTN pfn qfn' pns qns, pairVN) ::& rs-    pure $ i' :/ AnnCDR fn ::: ((qns, vn') ::& rs)+    withWTPInstr @q $+      withWTPInstr @('TPair p q) $ do+        let vn' = deriveSpecialVN vn qfn' pairVN+            i' = (NTPair pairTN pfn qfn' pns qns, Dict, pairVN) ::& rs+        pure $ i' :/ AnnCDR fn ::: ((qns, Dict, vn') ::& rs) -  (U.LEFT tn vn pfn qfn bMt, (an, _) ::& rs) ->-    withUType bMt $ \bn -> do-      let ns = NTOr tn pfn qfn an bn-      pure (inp :/ LEFT ::: ((ns, vn) ::& rs))+  (U.LEFT tn vn pfn qfn bMt, (an :: Notes l, Dict, _) ::& rs) ->+    withUType bMt $ \(bn :: Notes r) -> do+      withWTPInstr @r $ do+        let ns = NTOr tn pfn qfn an bn+        pure (inp :/ LEFT ::: ((ns, Dict, vn) ::& rs)) -  (U.RIGHT tn vn pfn qfn aMt, (bn, _) ::& rs) ->-    withUType aMt $ \an -> do-      let ns = NTOr tn pfn qfn an bn-      pure (inp :/ RIGHT ::: ((ns, vn) ::& rs))+  (U.RIGHT tn vn pfn qfn aMt, (bn :: Notes r, Dict, _) ::& rs) ->+    withUType aMt $ \(an :: Notes l) -> do+      withWTPInstr @l $ do+        let ns = NTOr tn pfn qfn an bn+        pure (inp :/ RIGHT ::: ((ns, Dict, vn) ::& rs)) -  (U.IF_LEFT mp mq, (STOr{}, ons, ovn) ::&+ rs) -> do-    let (an, bn, avn, bvn) = deriveNsOr ons ovn-        ait = (an, avn) ::& rs-        bit = (bn, bvn) ::& rs-    genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp+  (U.IF_LEFT mp mq, (STOr{}, ons, _, ovn) ::&+ rs) -> do+    case deriveNsOr ons ovn of+      (an :: Notes a, bn :: Notes b, avn, bvn) ->+        withWTPInstr @a $+          withWTPInstr @b $ do+            let+              ait = (an, Dict, avn) ::& rs+              bit = (bn, Dict, bvn) ::& rs+            genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp    (U.NIL tn vn elMt, i) ->-    withUType elMt $ \elNotes ->-      pure $ i :/ NIL ::: ((NTList tn elNotes, vn) ::& i)+    withUType elMt $ \(elNotes :: Notes t) ->+      withWTPInstr @('TList t) $+        pure $ i :/ NIL ::: ((NTList tn elNotes, Dict, vn) ::& i) -  (U.CONS vn, ((an :: Notes a), _)-                ::& ((ln :: Notes l), _) ::& rs) ->+  (U.CONS vn, ((an :: Notes a), _, _)+                ::& ((ln :: Notes l), _, _) ::& rs) ->     case eqType @('TList a) @l of       Right Refl -> do-        n <- onTypeCheckInstrAnnErr uInstr inp "wrong cons type:" (converge ln (NTList def an))-        pure $ inp :/ CONS ::: ((n, vn) ::& rs)-      Left m -> onTypeCheckInstrErr uInstr (SomeHST inp)-                  ("list element type is different from one "-                  <> "that is being CONSed:") (Left m)--  (U.IF_CONS mp mq, (STList{}, ns, vn) ::&+ rs) -> do-    let NTList _ an = ns-        ait = (an, vn <> "hd") ::& (ns, vn <> "tl") ::& rs-    genericIf IF_CONS U.IF_CONS mp mq ait rs inp--  (U.SIZE vn, (NTList{}, _) ::& _) -> sizeImpl inp vn-  (U.SIZE vn, (NTSet{}, _) ::& _) -> sizeImpl inp vn-  (U.SIZE vn, (NTMap{}, _) ::& _) -> sizeImpl inp vn-  (U.SIZE vn, (NTcs SCString, _) ::& _) -> sizeImpl inp vn-  (U.SIZE vn, (NTcs SCBytes, _) ::& _) -> sizeImpl inp vn+        (n :: Notes t) <- onTypeCheckInstrAnnErr uInstr inp (Just ConsArgument) (converge ln (NTList def an))+        withWTPInstr @t $+          pure $ inp :/ CONS ::: ((n, Dict, vn) ::& rs)+      Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just ConsArgument) m -  (U.EMPTY_SET tn vn (U.Comparable mk ktn), i) ->-    withSomeSingCT mk $ \k ->-      pure $ i :/ EMPTY_SET ::: ((STSet k, NTSet tn ktn, vn) ::&+ inp)+  (U.IF_CONS mp mq, (STList{}, ns, Dict, vn) ::&+ rs) -> do+    case ns of+      NTList _ (an :: Notes t1) -> do+        ait <- withWTPInstr @t1 $ pure $ (an, Dict, vn <> "hd") ::& (ns, Dict, vn <> "tl") ::& rs+        genericIf IF_CONS U.IF_CONS mp mq ait rs inp -  (U.EMPTY_MAP tn vn (U.Comparable mk ktn) mv, i) ->-    withUType mv $ \vns ->-    withSomeSingCT mk $ \k -> do-      let ns = NTMap tn ktn vns-      pure $ i :/ EMPTY_MAP ::: ((STMap k sing, ns, vn) ::&+ i)+  (U.SIZE vn, (NTList{}, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (NTSet{}, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (NTMap{}, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (NTString{}, _, _) ::& _) -> sizeImpl inp vn+  (U.SIZE vn, (NTBytes{}, _, _) ::& _) -> sizeImpl inp vn+  (U.EMPTY_SET tn vn (U.Type mk ktn), i) ->+      withSomeSingT (fromUType $ U.Type mk U.noAnn) $ \(k :: Sing k) -> do+        withWTPInstr @('TSet k) $+          withCompareableCheck k uInstr inp $ i :/ EMPTY_SET ::: ((STSet k, NTSet tn ktn, Dict, vn) ::&+ inp) -  (U.EMPTY_BIG_MAP tn vn (U.Comparable mk ktn) mv, i) ->-    withUType mv $ \vns ->-    withSomeSingCT mk $ \k -> do-      let ns = NTBigMap tn ktn vns-      pure $ i :/ EMPTY_BIG_MAP ::: ((STBigMap k sing, ns, vn) ::&+ i)+  (U.EMPTY_MAP tn vn (U.Type mk ktn) mv, i) ->+    withUType mv $ \(vns :: Notes v)  ->+    withSomeSingT (fromUType $ U.Type mk U.noAnn) $ \(k :: Sing k) ->do+      withWTPInstr @('TMap k v) $+        withCompareableCheck k uInstr inp $ i :/ EMPTY_MAP ::: ((STMap k sing, NTMap tn ktn vns, Dict, vn) ::&+ i) -  (U.MAP vn mp, (STList _, NTList _ vns, _vn) ::&+ _) -> do-    mapImpl vns uInstr mp inp-      (\rn -> (::&) (NTList def rn, vn))+  (U.EMPTY_BIG_MAP tn vn (U.Type mk ktn) mv, i) ->+    withUType mv $ \(vns :: Notes v) ->+    withSomeSingT (fromUType $ U.Type mk U.noAnn) $ \(k :: Sing k) -> do+      withWTPInstr @('TBigMap k v) $+        withCompareableCheck k uInstr inp $ i :/ EMPTY_BIG_MAP ::: ((STBigMap k sing, NTBigMap tn ktn vns, Dict, vn) ::&+ i) +  (U.MAP vn mp, (STList _, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> do+    withWTPInstr @t1 $+      mapImpl vns uInstr mp inp+        (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $  (NTList def rn, Dict, vn) ::& hst) -  (U.MAP vn mp, (STMap{}, NTMap _ kns vns, _vn) ::&+ _) -> do-    let pns = NTPair def def def (NTc kns) vns-    mapImpl pns uInstr mp inp-      (\rn -> (::&) (NTMap def kns rn, vn))+  (U.MAP vn mp, (STMap{}, NTMap _ kns vns, Dict, _vn) ::&+ _) -> do+    case NTPair def def def (insertTypeAnn kns starNotes) vns of+      (pns :: Notes ('TPair k v1)) ->+        withWTPInstr @('TPair k v1) $+          mapImpl pns uInstr mp inp+             (\(rn :: Notes v) hst -> withWTPInstr @('TMap k v) $ pure $ (NTMap def kns rn, Dict, vn) ::& hst)  -- case `U.HSTER []` is wrongly typed by definition -- (as it is required to at least drop an element), so we don't consider it -  (U.ITER (i1 : ir), (STSet _, NTSet _ en, _) ::&+ _) -> do-    iterImpl (NTc en) uInstr (i1 :| ir) inp+  (U.ITER is, (STSet (_ :: Sing t1), NTSet _ en, _, _) ::&+ _) -> do+    withWTPInstr @t1 $+      iterImpl (insertTypeAnn en starNotes) uInstr is inp -  (U.ITER (i1 : ir), (STList _, NTList _ en, _) ::&+ _) -> do-    iterImpl en uInstr (i1 :| ir) inp+  (U.ITER is, (STList (_ :: Sing t1), NTList _ en, _, _) ::&+ _) -> do+    withWTPInstr @t1 $+      iterImpl en uInstr is inp -  (U.ITER (i1 : ir), (STMap _ _, NTMap _ kns vns, _) ::&+ _) -> do-    let en = NTPair def def def (NTc kns) vns-    iterImpl en uInstr (i1 :| ir) inp+  (U.ITER is, (STMap _ _, NTMap _ kns vns, _, _) ::&+ _) -> do+    case NTPair def def def (insertTypeAnn kns starNotes) vns of+      (en :: Notes ('TPair a b)) ->+        withWTPInstr @('TPair a b) $ iterImpl en uInstr is inp -  (U.MEM vn, (NTc _, _) ::& (STSet{}, NTSet{}, _) ::&+ _) ->+  (U.MEM vn, _ ::& (STSet{}, NTSet{}, _, _) ::&+ _) ->     memImpl uInstr inp vn-  (U.MEM vn, (NTc _, _) ::& (STMap{}, NTMap{}, _) ::&+ _) ->+  (U.MEM vn, _ ::& (STMap{}, NTMap{}, _, _) ::&+ _) ->     memImpl uInstr inp vn-  (U.MEM vn, (NTc _, _) ::& (STBigMap{}, NTBigMap{}, _) ::&+ _) ->+  (U.MEM vn, _ ::& (STBigMap{}, NTBigMap{}, _, _) ::&+ _) ->     memImpl uInstr inp vn -  (U.GET vn, _ ::& (STMap{}, NTMap _ _ v, _) ::&+ _) ->-    getImpl uInstr inp v vn-  (U.GET vn, _ ::& (STBigMap{}, NTBigMap _ _ v, _) ::&+ _) ->-    getImpl uInstr inp v vn+  (U.GET vn, _ ::& (STMap{}, NTMap _ _ (v :: Notes v), _, _) ::&+ _) ->+    withWTPInstr @v $ getImpl uInstr inp v vn+  (U.GET vn, _ ::& (STBigMap{}, NTBigMap _ _ (v :: Notes v), _, _) ::&+ _) ->+    withWTPInstr @v $ getImpl uInstr inp v vn -  (U.UPDATE vn, _ ::& _ ::& (STMap _ _, _, _) ::&+ _) ->+  (U.UPDATE vn, _ ::& _ ::& (STMap _ _, _, _, _) ::&+ _) ->     updImpl uInstr inp vn-  (U.UPDATE vn, _ ::& _ ::& (STBigMap _ _, _, _) ::&+ _) ->+  (U.UPDATE vn, _ ::& _ ::& (STBigMap _ _, _, _, _) ::&+ _) ->     updImpl uInstr inp vn-  (U.UPDATE vn, _ ::& _ ::& (STSet _, _, _) ::&+ _) ->+  (U.UPDATE vn, _ ::& _ ::& (STSet _, _, _, _) ::&+ _) ->     updImpl uInstr inp vn -  (U.IF mp mq, (NTcs SCBool, _) ::& rs) ->+  (U.IF mp mq, (NTBool{}, _, _) ::& rs) ->     genericIf IF U.IF mp mq rs rs inp -  (U.LOOP is, (NTcs SCBool, _) ::& (rs :: HST rs)) -> do+  (U.LOOP is, (NTBool{}, _, _) ::& (rs :: HST rs)) -> do     _ :/ tp <- lift $ typeCheckList is rs     case tp of       subI ::: (o :: HST o) -> do-        case eqHST o (sing @('Tc 'CBool) -:& rs) of+        case eqHST o (sing @('TBool) -:& rs) of           Right Refl -> do             let _ ::& rs' = o             pure $ inp :/ LOOP subI ::: rs'-          Left m -> onTypeCheckInstrErr uInstr (SomeHST inp)-                      "iteration expression has wrong output stack type:" (Left m)+          Left m -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m       AnyOutInstr subI ->         pure $ inp :/ LOOP subI ::: rs -  (U.LOOP_LEFT is, (os@STOr{}, ons, ovn) ::&+ rs) -> do-    let (an, bn, avn, bvn) = deriveNsOr ons ovn-        ait = (an, avn) ::& rs-    _ :/ tp <- lift $ typeCheckList is ait-    case tp of-      subI ::: o -> do-        case (eqHST o (os -:& rs), o) of-          (Right Refl, ((ons', ovn') ::& rs')) -> do-              let (_, bn', _, bvn') = deriveNsOr ons' ovn'-              br <- onTypeCheckInstrAnnErr uInstr inp "wrong LOOP_LEFT input type:" $-                      convergeHSTEl (bn, bvn) (bn', bvn')-              pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs')-          (Left m, _) -> onTypeCheckInstrErr uInstr (SomeHST inp)-                          "iteration expression has wrong output stack type:" (Left m)-      AnyOutInstr subI -> do-        let br = (bn, bvn)-        pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs)+  (U.LOOP_LEFT is, (os@STOr{}, ons, Dict, ovn) ::&+ rs) -> do+    case deriveNsOr ons ovn of+      (an :: Notes t, bn :: Notes b, avn, bvn) -> do+        withWTPInstr @t $ withWTPInstr @b $ do+          let ait = (an, Dict, avn) ::& rs+          _ :/ tp <- lift $ typeCheckList is ait+          case tp of+            subI ::: o -> do+              case (eqHST o (os -:& rs), o) of+                (Right Refl, ((ons', Dict, ovn') ::& rs')) -> do+                    let (_, bn', _, bvn') = deriveNsOr ons' ovn'+                    br <- onTypeCheckInstrAnnErr uInstr inp+                            (Just Iteration)+                            (convergeHSTEl (bn, Dict, bvn) (bn', Dict, bvn'))+                    pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs')+                (Left m, _) -> typeCheckInstrErr' uInstr (SomeHST inp) (Just Iteration) m+            AnyOutInstr subI -> do+              let br = (bn, Dict, bvn)+              pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs) -  (U.LAMBDA vn (AsUType ins) (AsUType ons) is, i) -> do+  (U.LAMBDA vn (AsUType (ins :: Notes t)) (AsUType (ons :: Notes u)) is, i) -> do     -- further processing is extracted into another function just not to     -- litter our main typechecking logic-    lamImpl uInstr is vn ins ons i+    withWTPInstr @t $+      withWTPInstr @u $+        lamImpl uInstr is vn ins ons i -  (U.EXEC vn, ((_ :: Notes t1), _)+  (U.EXEC vn, ((_ :: Notes t1), _, _)                               ::& ( STLambda _ _-                                  , NTLambda _ (_ :: Notes t1') t2n+                                  , NTLambda _ (_ :: Notes t1') (t2n :: Notes t2')                                   , _+                                  , _                                   )                               ::&+ rs) -> do-    Refl <- onTypeCheckInstrErr uInstr (SomeHST inp)-                  "lambda is given argument with wrong type:" (eqType @t1 @t1')-    pure $ inp :/ EXEC ::: ((t2n, vn) ::& rs)+    Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)+                  (eqType @t1 @t1')+    withWTPInstr @t2' $ pure $ inp :/ EXEC ::: ((t2n, Dict, vn) ::& rs) -  (U.APPLY vn, ((_ :: Notes a'), _)-                  ::& ( STLambda (STPair sa _) _+  (U.APPLY vn, ((_ :: Notes a'), _, _)+                  ::& ( STLambda (STPair _ _) _                       , NTLambda vann (NTPair _ _ _ (_ :: Notes a) (nb :: Notes b)) sc+                      , _                       , _)                   ::&+ rs) -> do-    let-      l2n = NTLambda vann nb sc+    case NTLambda vann nb sc of+      (l2n :: Notes ('TLambda t1 t2)) -> withWTPInstr @('TLambda t1 t2) $ do -    proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp)-                  "lambda is given argument with wrong type:" (eqType @a' @a)-    proofOp <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-              "Operations in argument of partially applied lambda are not allowed"-              $ Left $ UnsupportedTypes [demote @a])-      pure (opAbsense sa)-    proofBigMap <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-              "BigMaps in argument of partially applied lambda are not allowed"-              $ Left $ UnsupportedTypes [demote @a])-      pure (bigMapAbsense sa)-    proofContract <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-              "Contract type in constant is not allowed"-              $ Left $ UnsupportedTypes [demote @a])-      pure (contractTypeAbsense sa)-    case (proofArgEq, proofOp, proofBigMap, proofContract) of-      (Refl, Dict, Dict, Dict) ->-        pure $ inp :/ (APPLY @a) ::: ((l2n, vn) ::& rs)+        proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)+                      (eqType @a' @a)+        proofScope <- onScopeCheckInstrErr @a uInstr (SomeHST inp) (Just LambdaArgument)+          $ checkScope @(ConstantScope a)+        case (proofArgEq, proofScope) of+          (Refl, Dict) ->+            pure $ inp :/ (APPLY @a) ::: ((l2n, Dict, vn) ::& rs)    (U.DIP is, a ::& s) -> do     typeCheckDipBody uInstr is s $@@ -517,282 +519,244 @@       go n curHST = case (n, curHST) of         (0, _) -> typeCheckDipBody uInstr instructions curHST $ \subI t ->           pure (TCDipHelper SZ subI t)-        (_, SNil) -> onTypeCheckInstrErr uInstr-          (SomeHST SNil) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDip))+        (_, SNil) -> typeCheckInstrErr' uInstr (SomeHST SNil) Nothing+          $ NotEnoughItemsOnStack nTotal NotEnoughDip         (_, hstHead ::& hstTail) ->           go (n - 1) hstTail <&> \case           TCDipHelper s subI out -> TCDipHelper (SS s) subI (hstHead ::& out)--  (U.FAILWITH, (_ ::& _)) ->-    pure $ inp :/ AnyOutInstr FAILWITH--  (U.CAST vn (AsUType castToNotes), (en, evn) ::& rs) -> do-    (Refl, _) <- errM $ matchTypes en castToNotes-    pure $ inp :/ CAST ::: ((castToNotes, vn `orAnn` evn) ::& rs)-    where-      errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a-      errM = onTypeCheckInstrErr uInstr (SomeHST inp) "cast to incompatible type:"+  (u, v) -> case (u, v) of -- Workaround for not exceeding -fmax-pmcheck-iterations limit+    (U.FAILWITH, (_ ::& _)) ->+      pure $ inp :/ AnyOutInstr FAILWITH -  (U.RENAME vn, (an, _) ::& rs) ->-    pure $ inp :/ RENAME ::: ((an, vn) ::& rs)+    (U.CAST vn (AsUType (castToNotes :: Notes t)), (en, _, evn) ::& rs) -> do+      (Refl, _) <- errM $ matchTypes en castToNotes+      withWTPInstr @t $+        pure $ inp :/ CAST ::: ((castToNotes, Dict, vn `orAnn` evn) ::& rs)+      where+        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a+        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just Cast) -  (U.UNPACK tn vn mt, (NTcs SCBytes, _) ::& rs) ->-    withUType mt $ \tns -> do-      let ns = NTOption tn tns-      proofOp <--        maybe (typeCheckInstrErr uInstr (SomeHST inp)-              "Operation cannot appear in serialized data")-        pure (opAbsense $ notesSing tns)-      proofBigMap <--        maybe (typeCheckInstrErr uInstr (SomeHST inp)-              "BigMap cannot appear in serialized data")-        pure (bigMapAbsense $ notesSing tns)-      proofContract <--        maybe (typeCheckInstrErr uInstr (SomeHST inp)-              "UNPACK should not contain 'contract' type")-        pure (contractTypeAbsense $ notesSing tns)-      case (proofOp, proofBigMap, proofContract) of-        (Dict, Dict, Dict) ->-          pure $ inp :/ UNPACK ::: ((ns, vn) ::& rs)+    (U.RENAME vn, (an, Dict, _) ::& rs) ->+      pure $ inp :/ RENAME ::: ((an, Dict, vn) ::& rs) -  (U.PACK vn, (a, _) ::& rs) -> do-    proofOp <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-            "Operations cannot appear in serialized data"-            $ Left $ UnsupportedTypes [notesT a])-      pure (opAbsense $ notesSing a)-    proofBigMap <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-            "BigMap cannot appear in serialized data"-            $ Left $ UnsupportedTypes [notesT a])-      pure (bigMapAbsense $ notesSing a)-    case (proofOp, proofBigMap) of-      (Dict, Dict) ->-        pure $ inp :/ PACK ::: ((starNotes, vn) ::& rs)+    (U.UNPACK tn vn mt, (NTBytes{}, _, _) ::& rs) ->+      withUType mt $ \(tns :: Notes tn) -> do+        case NTOption tn tns of+          (ns :: Notes ('TOption t1)) -> withWTPInstr @('TOption t1) $ do+            Dict <- onScopeCheckInstrErr @tn uInstr (SomeHST inp) Nothing+              $ checkScope @(UnpackedValScope tn)+            pure $ inp :/ UNPACK ::: ((ns, Dict, vn) ::& rs) -  (U.CONCAT vn, (NTcs SCBytes, _) ::& (NTcs SCBytes, _) ::& _) ->-    concatImpl inp vn-  (U.CONCAT vn, (NTcs SCString, _) ::& (NTcs SCString, _) ::& _) ->-    concatImpl inp vn-  (U.CONCAT vn, (STList (STc SCBytes), _, _) ::&+ _) ->-    concatImpl' inp vn-  (U.CONCAT vn, (STList (STc SCString), _, _) ::&+ _) ->-    concatImpl' inp vn-  (U.SLICE vn, (NTcs SCNat, _) ::&-               (NTcs SCNat, _) ::&-               (NTcs SCString, _) ::& _) -> sliceImpl inp vn-  (U.SLICE vn, (NTcs SCNat, _) ::&-               (NTcs SCNat, _) ::&-               (NTcs SCBytes, _) ::& _) -> sliceImpl inp vn+    (U.PACK vn, (_ :: Notes a, _, _) ::& rs) -> do+      Dict <- onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing+        $ checkScope @(PackedValScope a)+      pure $ inp :/ PACK ::: ((starNotes, Dict, vn) ::& rs) -  (U.ISNAT vn', (NTcs SCInt, oldVn) ::& rs) -> do-    let vn = vn' `orAnn` oldVn-    pure $ inp :/ ISNAT ::: ((starNotes, vn) ::& rs)+    (U.CONCAT vn, (NTBytes{}, _, _) ::& (NTBytes{}, _, _) ::& _) ->+      concatImpl inp vn+    (U.CONCAT vn, (NTString{}, _, _) ::& (NTString{}, _, _) ::& _) ->+      concatImpl inp vn+    (U.CONCAT vn, (STList STBytes, _, _, _) ::&+ _) ->+      concatImpl' inp vn+    (U.CONCAT vn, (STList STString, _, _, _) ::&+ _) ->+      concatImpl' inp vn+    (U.SLICE vn, (NTNat{}, _, _) ::&+                 (NTNat{}, _, _) ::&+                 (NTString{}, _, _) ::& _) -> sliceImpl inp vn+    (U.SLICE vn, (NTNat{}, _, _) ::&+                 (NTNat{}, _, _) ::&+                 (NTBytes{}, _, _) ::& _) -> sliceImpl inp vn -  (U.ADD vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> addImpl a b inp vn-  (U.SUB vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> subImpl a b inp vn-  (U.MUL vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> mulImpl a b inp vn-  (U.EDIV vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> edivImpl a b inp vn+    (U.ISNAT vn', (NTInt{}, _, oldVn) ::& rs) -> do+      let vn = vn' `orAnn` oldVn+      pure $ inp :/ ISNAT ::: ((starNotes, Dict, vn) ::& rs) -  (U.ABS vn, (STc SCInt, _, _) ::&+ _) -> unaryArithImpl @Abs ABS inp vn+    (U.ADD vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> addImpl a b inp vn+    (U.SUB vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> subImpl a b inp vn+    (U.MUL vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> mulImpl a b inp vn+    (U.EDIV vn, (a, _, _, _) ::&+ (b, _, _, _) ::&+ _) -> edivImpl a b inp vn -  (U.NEG vn, (STc SCInt, _, _) ::&+ _) -> unaryArithImpl @Neg NEG inp vn-  (U.NEG vn, (STc SCNat, _, _) ::&+ _) -> unaryArithImpl @Neg NEG inp vn+    (U.ABS vn, (STInt, _, _, _) ::&+ _) -> unaryArithImpl @Abs ABS inp vn -  (U.LSL vn, (STc SCNat, _, _) ::&+-             (STc SCNat, _, _) ::&+ _) -> arithImpl @Lsl LSL inp vn+    (U.NEG vn, (STInt, _, _, _) ::&+ _) -> unaryArithImpl @Neg NEG inp vn+    (U.NEG vn, (STNat, _, _, _) ::&+ _) -> unaryArithImpl @Neg NEG inp vn -  (U.LSR vn, (STc SCNat, _, _) ::&+-             (STc SCNat, _, _) ::&+ _) -> arithImpl @Lsr LSR inp vn+    (U.LSL vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> arithImpl @Lsl LSL inp vn -  (U.OR vn, (STc SCBool, _, _) ::&+-            (STc SCBool, _, _) ::&+ _) -> arithImpl @Or OR inp vn-  (U.OR vn, (STc SCNat, _, _) ::&+-            (STc SCNat, _, _) ::&+ _) -> arithImpl @Or OR inp vn+    (U.LSR vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> arithImpl @Lsr LSR inp vn -  (U.AND vn, (STc SCInt, _, _) ::&+-             (STc SCNat, _, _) ::&+ _) -> arithImpl @And AND inp vn-  (U.AND vn, (STc SCNat, _, _) ::&+-             (STc SCNat, _, _) ::&+ _) -> arithImpl @And AND inp vn-  (U.AND vn, (STc SCBool, _, _) ::&+-             (STc SCBool, _, _) ::&+ _) -> arithImpl @And AND inp vn+    (U.OR vn, (STBool, _, _, _) ::&++              (STBool, _, _, _) ::&+ _) -> arithImpl @Or OR inp vn+    (U.OR vn, (STNat, _, _, _) ::&++              (STNat, _, _, _) ::&+ _) -> arithImpl @Or OR inp vn -  (U.XOR vn, (STc SCBool, _, _) ::&+-             (STc SCBool, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn-  (U.XOR vn, (STc SCNat, _, _) ::&+-             (STc SCNat, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn+    (U.AND vn, (STInt, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> arithImpl @And AND inp vn+    (U.AND vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> arithImpl @And AND inp vn+    (U.AND vn, (STBool, _, _, _) ::&++               (STBool, _, _, _) ::&+ _) -> arithImpl @And AND inp vn -  (U.NOT vn, (STc SCNat, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn-  (U.NOT vn, (STc SCBool, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn-  (U.NOT vn, (STc SCInt, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn+    (U.XOR vn, (STBool, _, _, _) ::&++               (STBool, _, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn+    (U.XOR vn, (STNat, _, _, _) ::&++               (STNat, _, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn -  (U.COMPARE vn,-        (an :: Notes aT, _)-    ::& (bn :: Notes bT, _)-    ::& rs-    )-    -> do-    case eqType @aT @bT of-      Right Refl -> do-        void . errConv $ converge an bn-        proof <--          maybe (onTypeCheckInstrErr (U.COMPARE vn) (SomeHST inp)-                  "comparison is given incomparable arguments"-                  $ Left $ UnsupportedTypes [demote @aT, demote @bT])-            pure (comparabilityPresence $ notesSing an)+    (U.NOT vn, (STNat, _, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn+    (U.NOT vn, (STBool, _, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn+    (U.NOT vn, (STInt, _, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn -        case proof of-          Dict -> do-            pure $ inp :/ COMPARE ::: ((starNotes, vn) ::& rs)+    (U.COMPARE vn,+          (an :: Notes aT, _, _)+      ::& (bn :: Notes bT, _, _)+      ::& rs+      )+      -> do+      case eqType @aT @bT of+        Right Refl -> do+          void . errConv $ converge an bn+          proofScope <- onScopeCheckInstrErr @aT (U.COMPARE vn) (SomeHST inp) (Just ComparisonArguments)+            $ checkScope @(ComparabilityScope aT)+          case proofScope of+            Dict ->+              pure $ inp :/ COMPARE ::: ((starNotes, Dict, vn) ::& rs) -      Left err -> do-        typeCheckInstrErr' uInstr (SomeHST inp) "comparing different types:" err-    where-      errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a-      errConv = onTypeCheckInstrAnnErr uInstr inp "comparing types with different annotations:"+        Left err -> do+          typeCheckInstrErr' uInstr (SomeHST inp) (Just ComparisonArguments) err+      where+        errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a+        errConv = onTypeCheckInstrAnnErr uInstr inp (Just ComparisonArguments) -  (U.EQ vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Eq' EQ inp vn+    (U.EQ vn, (NTInt{}, _, _) ::& _) -> unaryArithImpl @Eq' EQ inp vn -  (U.NEQ vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Neq NEQ inp vn+    (U.NEQ vn, (NTInt{}, _, _) ::& _) -> unaryArithImpl @Neq NEQ inp vn -  (U.LT vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Lt LT inp vn+    (U.LT vn, (NTInt{}, _, _) ::& _) -> unaryArithImpl @Lt LT inp vn -  (U.GT vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Gt GT inp vn+    (U.GT vn, (NTInt{}, _, _) ::& _) -> unaryArithImpl @Gt GT inp vn -  (U.LE vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Le LE inp vn+    (U.LE vn, (NTInt{}, _, _) ::& _) -> unaryArithImpl @Le LE inp vn -  (U.GE vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Ge GE inp vn+    (U.GE vn, (NTInt{}, _, _) ::& _) -> unaryArithImpl @Ge GE inp vn -  (U.INT vn, (NTcs SCNat, _) ::& rs) ->-    pure $ inp :/ INT ::: ((starNotes, vn) ::& rs)+    (U.INT vn, (NTNat{}, _, _) ::& rs) ->+      pure $ inp :/ INT ::: ((starNotes, Dict, vn) ::& rs) -  (U.SELF vn fn, _) -> do-    cpType <- gets tcContractParam-    let t = fromUType cpType-    -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-    -- valid parameter type-    withUType cpType $ \(ParamNotesUnsafe -> notescp :: ParamNotes t) -> do-      proofOp <--        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-                "contract param type cannot contain operation"-                $ Left $ UnsupportedTypes [t])-        pure (opAbsense $ sing @t)-      proofBigMap <--        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-                "contract param type cannot contain nested big_map"-                $ Left $ UnsupportedTypes [t])-        pure (nestedBigMapsAbsense $ sing @t)-      case (proofOp, proofBigMap) of-        (Dict, Dict) -> do-          epName <- onTypeCheckInstrErr uInstr (SomeHST inp) "Bad annotation:" $-                      epNameFromRefAnn fn `onLeft` IllegalEntryPoint-          MkEntryPointCallRes (argNotes :: Notes arg) epc <--            mkEntryPointCall epName notescp-              & maybeToRight (EntryPointNotFound epName)-              & onTypeCheckInstrErr uInstr (SomeHST inp) "entrypoint not found"-          let ntRes = NTContract U.noAnn argNotes-          pure $ inp :/ SELF @arg (SomeEpc epc)-                  ::: ((ntRes, vn) ::& inp)+    (U.SELF vn fn, _) -> do+      (U.ParameterType cpType rootAnn) <- gets tcContractParam+      -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has+      -- valid parameter type+      withUType cpType $ \((`ParamNotesUnsafe` rootAnn) -> notescp :: ParamNotes t) -> do+        proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)+          $ checkScope @(ParameterScope t)+        case proofScope of+          Dict -> do+            epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing $+                        epNameFromRefAnn fn `onLeft` IllegalEntryPoint+            MkEntryPointCallRes (argNotes :: Notes arg) epc <-+              mkEntryPointCall epName notescp+                & maybeToRight (EntryPointNotFound epName)+                & onTypeCheckInstrErr uInstr (SomeHST inp) Nothing -  (U.CONTRACT vn fn mt, (NTcs SCAddress, _) ::& rs) ->-    withUType mt $ \(tns :: Notes t) -> do-      proofOp <--        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-                "contract param type cannot contain operation"-                $ Left $ UnsupportedTypes [fromUType mt])-        pure (opAbsense $ sing @t)-      proofBigMap <--        maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-                "contract param type cannot contain nested big_map"-                $ Left $ UnsupportedTypes [fromUType mt])-        pure (nestedBigMapsAbsense $ sing @t)-      let ns = NTOption def $ NTContract def tns-      epName <- onTypeCheckInstrErr uInstr (SomeHST inp) "Bad annotation:" $-                  epNameFromRefAnn fn `onLeft` IllegalEntryPoint-      case (proofOp, proofBigMap) of-        (Dict, Dict) ->-          pure $ inp :/ CONTRACT tns epName ::: ((ns, vn) ::& rs)+            case NTContract U.noAnn argNotes of+                    (ntRes :: Notes ('TContract t1)) ->+                      withWTPInstr @('TContract t1) $+                        pure $ inp :/ SELF @arg (SomeEpc epc) ::: ((ntRes, Dict, vn) ::& inp) -  (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _)-    ::& (NTcs SCMutez, _)-    ::& (STContract (p :: Sing p), _, _) ::&+ rs) -> do-    proofOp <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-              "contract param type cannot contain operation"-              $ Left $ UnsupportedTypes [fromSingT p])-      pure (opAbsense p)-    proofBigMap <--      maybe (onTypeCheckInstrErr uInstr (SomeHST inp)-              "contract param type cannot contain big_map"-              $ Left $ UnsupportedTypes [fromSingT p])-      pure (nestedBigMapsAbsense p)-    case (eqType @p @p', proofOp, proofBigMap) of-      (Right Refl, Dict, Dict) ->-        pure $ inp :/ TRANSFER_TOKENS ::: ((starNotes, vn) ::& rs)-      (Left m, _, _) ->-        onTypeCheckInstrErr uInstr (SomeHST inp)-          "mismatch of contract param type:" (Left m)+    (U.CONTRACT vn fn mt, (NTAddress{}, _, _) ::& rs) ->+      withUType mt $ \(tns :: Notes t) -> do+        proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)+          $ checkScope @(ParameterScope t)+        let ns = NTOption def $ NTContract def tns+        epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing+          $ epNameFromRefAnn fn `onLeft` IllegalEntryPoint+        case proofScope of+          Dict ->+            withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs) -  (U.SET_DELEGATE vn, (STOption (STc SCKeyHash), _, _) ::&+ rs) -> do-    pure $ inp :/ SET_DELEGATE ::: ((starNotes, vn) ::& rs)+    (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _, _)+      ::& (NTMutez{}, _, _)+      ::& (STContract (_ :: Sing p), _, _, _) ::&+ rs) -> do+      proofScope <- onScopeCheckInstrErr @p uInstr (SomeHST inp) (Just ContractParameter)+        $ checkScope @(ParameterScope p)+      case (eqType @p @p', proofScope) of+        (Right Refl, Dict) ->+          pure $ inp :/ TRANSFER_TOKENS ::: ((starNotes, Dict, vn) ::& rs)+        (Left m, _) ->+          typeCheckInstrErr' uInstr (SomeHST inp) (Just ContractParameter) m -  (U.CREATE_CONTRACT ovn avn contract,-                 (STOption (STc SCKeyHash), _, _)-            ::&+ (NTcs SCMutez, _)-             ::& (gn :: Notes g, _) ::& rs) -> do-    (SomeContract (FullContract (contr :: ContractCode p' g') paramNotes storeNotes))-      <- lift $ typeCheckContractImpl contract-    Refl <- checkEqT @g @g' uInstr inp "contract storage type mismatch"-    void $ onTypeCheckInstrAnnErr uInstr inp "contract storage type mismatch" (converge gn storeNotes)-    pure $ inp :/ CREATE_CONTRACT (FullContract contr paramNotes storeNotes) :::-          ((starNotes, ovn) ::& (starNotes, avn) ::& rs)+    (U.SET_DELEGATE vn,+      (STOption STKeyHash, NTOption _ NTKeyHash{}, _, _)+      ::&+ rs) -> do+        pure $ inp :/ SET_DELEGATE ::: ((starNotes, Dict, vn) ::& rs) -  (U.IMPLICIT_ACCOUNT vn, (NTcs SCKeyHash, _) ::& rs) ->-    pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, vn) ::& rs)+    (U.CREATE_CONTRACT ovn avn contract,+      (STOption STKeyHash, NTOption _ (_ :: Notes ('TKeyHash)), _, _)+      ::&+ (NTMutez{}, _, _)+      ::& (gn :: Notes g, Dict, _) ::& rs) -> do+        (SomeContract+          (FullContract+            (contr :: ContractCode p' g')+            paramNotes+            storeNotes))+          <- lift $ typeCheckContractImpl contract+        Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage)+          $ eqType @g @g'+        void $ onTypeCheckInstrAnnErr uInstr inp (Just ContractStorage) (converge gn storeNotes)+        pure+          $ inp :/ CREATE_CONTRACT (FullContract contr paramNotes storeNotes)+          ::: ((starNotes, Dict, ovn) ::& (starNotes, Dict, avn) ::& rs) -  (U.NOW vn, _) ->-    pure $ inp :/ NOW ::: ((starNotes, vn) ::& inp)+    (U.IMPLICIT_ACCOUNT vn, (NTKeyHash{}, _, _) ::& rs) ->+      pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, Dict, vn) ::& rs) -  (U.AMOUNT vn, _) ->-    pure $ inp :/ AMOUNT ::: ((starNotes, vn) ::& inp)+    (U.NOW vn, _) ->+      pure $ inp :/ NOW ::: ((starNotes, Dict, vn) ::& inp) -  (U.BALANCE vn, _) ->-    pure $ inp :/ BALANCE ::: ((starNotes, vn) ::& inp)+    (U.AMOUNT vn, _) ->+      pure $ inp :/ AMOUNT ::: ((starNotes, Dict, vn) ::& inp) -  (U.CHECK_SIGNATURE vn,-             (NTKey _, _)-             ::& (NTSignature _, _) ::& (NTcs SCBytes, _) ::& rs) ->-    pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, vn) ::& rs)+    (U.BALANCE vn, _) ->+      pure $ inp :/ BALANCE ::: ((starNotes, Dict, vn) ::& inp) -  (U.SHA256 vn, (NTcs SCBytes, _) ::& rs) ->-    pure $ inp :/ SHA256 ::: ((starNotes, vn) ::& rs)+    (U.CHECK_SIGNATURE vn,+               (NTKey _, _, _)+               ::& (NTSignature _, _, _) ::& (NTBytes{}, _, _) ::& rs) ->+      pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, Dict, vn) ::& rs) -  (U.SHA512 vn, (NTcs SCBytes, _) ::& rs) ->-    pure $ inp :/ SHA512 ::: ((starNotes, vn) ::& rs)+    (U.SHA256 vn, (NTBytes{}, _, _) ::& rs) ->+      pure $ inp :/ SHA256 ::: ((starNotes, Dict, vn) ::& rs) -  (U.BLAKE2B vn, (NTcs SCBytes, _) ::& rs) ->-    pure $ inp :/ BLAKE2B ::: ((starNotes, vn) ::& rs)+    (U.SHA512 vn, (NTBytes{}, _, _) ::& rs) ->+      pure $ inp :/ SHA512 ::: ((starNotes, Dict, vn) ::& rs) -  (U.HASH_KEY vn, (NTKey{}, _) ::& rs) ->-    pure $ inp :/ HASH_KEY ::: ((starNotes, vn) ::& rs)+    (U.BLAKE2B vn, (NTBytes{}, _, _) ::& rs) ->+      pure $ inp :/ BLAKE2B ::: ((starNotes, Dict, vn) ::& rs) -  (U.STEPS_TO_QUOTA vn, _) ->-    pure $ inp :/ STEPS_TO_QUOTA ::: ((starNotes, vn) ::& inp)+    (U.HASH_KEY vn, (NTKey{}, _, _) ::& rs) ->+      pure $ inp :/ HASH_KEY ::: ((starNotes, Dict, vn) ::& rs) -  (U.SOURCE vn, _) ->-    pure $ inp :/ SOURCE ::: ((starNotes, vn) ::& inp)+    (U.SOURCE vn, _) ->+      pure $ inp :/ SOURCE ::: ((starNotes, Dict, vn) ::& inp) -  (U.SENDER vn, _) ->-    pure $ inp :/ SENDER ::: ((starNotes, vn) ::& inp)+    (U.SENDER vn, _) ->+      pure $ inp :/ SENDER ::: ((starNotes, Dict, vn) ::& inp) -  (U.ADDRESS vn, (NTContract{}, _) ::& rs) ->-    pure $ inp :/ ADDRESS ::: ((starNotes, vn) ::& rs)+    (U.ADDRESS vn, (NTContract{}, _, _) ::& rs) ->+      pure $ inp :/ ADDRESS ::: ((starNotes, Dict, vn) ::& rs) -  (U.CHAIN_ID vn, _) ->-    pure $ inp :/ CHAIN_ID ::: ((starNotes, vn) ::& inp)+    (U.CHAIN_ID vn, _) ->+      pure $ inp :/ CHAIN_ID ::: ((starNotes, Dict, vn) ::& inp) -  _ ->-    typeCheckInstrErr uInstr (SomeHST inp) "unknown expression"+    _ ->+      -- TODO #154 maksbotan: get rid of this clause, by explicitly matching all possible+      -- instructions and generating relevant errors.+      typeCheckInstrErr uInstr (SomeHST inp) Nothing+  where+    withWTPInstr :: forall t a. SingI t => (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a+    withWTPInstr fn = withWTPInstr_ @t uInstr (SomeHST inp) fn  -- | Helper function for two-branch if where each branch is given a single -- value.@@ -817,9 +781,9 @@   fmap (i :/) $ case (pinstr, qinstr) of     (p ::: po, q ::: qo) -> do       let instr = mCons mbt mbf-      Refl <- checkEqHST qo po instr i-                    "branches have different output stack types:"-      o <- onTypeCheckInstrAnnErr instr i "branches have different output stack types:" (convergeHST po qo)+      Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just If)+        $ eqHST po qo+      o <- onTypeCheckInstrAnnErr instr i (Just If) (convergeHST po qo)       pure $ cons p q ::: o     (AnyOutInstr p, q ::: qo) -> do       pure $ cons p q ::: qo@@ -833,6 +797,7 @@     ( MapOp c     , SingI (MapOpInp c)     , Typeable (MapOpInp c)+    , WellTyped (MapOpInp c)     , Typeable (MapOpRes c)     )   => Notes (MapOpInp c)@@ -840,46 +805,51 @@   -> [U.ExpandedOp]   -> HST (c ': rs)   -> (forall v' . (Typeable v', SingI v') =>-        Notes v' -> HST rs -> HST (MapOpRes c v' ': rs))+        Notes v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs)))   -> TypeCheckInstr (SomeInstr (c ': rs)) mapImpl vn instr mp i@(_ ::& rs) mkRes = do-  _ :/ subp <- lift $ typeCheckList mp ((vn, def) ::& rs)+  _ :/ subp <- lift $ typeCheckList mp ((vn, Dict, def) ::& rs)   case subp of     sub ::: subo ->       case subo of-        (bn, _bvn) ::& rs' -> do-          Refl <- checkEqHST rs rs' instr i $-                      "map expression has changed not only top of the stack"-          pure $ i :/ MAP sub ::: mkRes bn rs'-        _ -> typeCheckInstrErr instr (SomeHST i) "map expression has wrong output stack type (empty stack)"+        (bn, _, _bvn) ::& rs' -> do+          Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration)+            $ eqHST rs rs'+          x <- mkRes bn rs'+          pure $ i :/ MAP sub ::: x+        _ -> typeCheckInstrErr instr (SomeHST i) (Just Iteration)     AnyOutInstr _ ->-      typeCheckInstrErr instr (SomeHST i) "MAP code block always fails, which is not allowed"+      typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails  iterImpl   :: forall c rs .     ( IterOp c     , SingI (IterOpEl c)+    , WellTyped (IterOpEl c)     , Typeable (IterOpEl c)     )   => Notes (IterOpEl c)   -> U.ExpandedInstr-  -> NonEmpty U.ExpandedOp+  -> [U.ExpandedOp]   -> HST (c ': rs)   -> TypeCheckInstr (SomeInstr (c ': rs))-iterImpl en instr mp i@((_, lvn) ::& rs) = do+iterImpl en instr mp i@((_, _, lvn) ::& rs) = do   let evn = deriveVN "elt" lvn-  _ :/ subp <- lift $ typeCheckNE mp ((en, evn) ::& rs)+  _ :/ subp <-+    case mp of+      [] -> typeCheckInstrErr' instr (SomeHST i) (Just Iteration) EmptyCode+      _ -> typeCheckImpl typeCheckInstr mp ((en, Dict, evn) ::& rs)   case subp of     subI ::: o -> do-      Refl <- checkEqHST o rs instr i-                "iteration expression has wrong output stack type"+      Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration)+        $ eqHST o rs       pure $ i :/ ITER subI ::: o     AnyOutInstr _ ->-      typeCheckInstrErr instr (SomeHST i) "ITER code block always fails, which is not allowed"+      typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails  lamImpl   :: forall it ot ts .-    ( Typeable it, Typeable ts, Typeable ot+    ( Typeable it, WellTyped it, Typeable ts, Typeable ot, WellTyped ot     , SingI it, SingI ot     )   => U.ExpandedInstr@@ -890,29 +860,28 @@   -> HST ts   -> TypeCheckInstr (SomeInstr ts) lamImpl instr is vn ins ons i = do-  when (any hasSelf is) $-    typeCheckInstrErr instr (SomeHST i) "The SELF instruction cannot appear in a lambda"-  _ :/ lamI <- lift $ typeCheckList is ((ins, def) ::& SNil)+  whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr ->+    typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) $ InvalidInstruction selfInstr+  _ :/ lamI <- lift $ typeCheckList is ((ins, Dict, def) ::& SNil)   let lamNotes onsr = NTLambda def ins onsr-  let lamSt onsr = (lamNotes onsr, vn) ::& i+  let lamSt onsr = (lamNotes onsr, Dict, vn) ::& i   fmap (i :/) $ case lamI of     lam ::: lo -> do       case eqHST1 @ot lo of         Right Refl -> do-            let (ons', _) ::& SNil = lo-            onsr <- onTypeCheckInstrAnnErr instr i "wrong output type of lambda's expression:" (converge ons ons')+            let (ons', _, _) ::& SNil = lo+            onsr <- onTypeCheckInstrAnnErr instr i (Just LambdaCode) (converge ons ons')             pure (LAMBDA (VLam $ RfNormal lam) ::: lamSt onsr)-        Left m -> onTypeCheckInstrErr instr (SomeHST i)-                    "wrong output type of lambda's expression:" (Left m)+        Left m -> typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) m     AnyOutInstr lam ->       pure (LAMBDA (VLam $ RfAlwaysFails lam) ::: lamSt ons)   where-    hasSelf :: U.ExpandedOp -> Bool-    hasSelf = everything (||)-      (mkQ False+    hasSelf :: U.ExpandedOp -> First U.ExpandedInstr+    hasSelf = everything (<>)+      (mkQ (First Nothing)        (\case-           (U.SELF{} :: U.InstrAbstract U.ExpandedOp) -> True-           _ -> False+           selfInstr@(U.SELF{} :: U.InstrAbstract U.ExpandedOp) -> First $ Just selfInstr+           _ -> First Nothing        )       ) @@ -944,6 +913,5 @@       -- if output stack of code block within @DIP@ occurs to be any, an       -- error "FAILWITH must be at tail position" is raised.       -- It is not allowed even in `DIP 0`.-      typeCheckInstrErr mainInstr (SomeHST inputHST)-          "Code within DIP instruction always fails, which is not allowed"+      typeCheckInstrErr' mainInstr (SomeHST inputHST) (Just DipCode) CodeAlwaysFails     subI ::: t -> callback subI t
src/Michelson/TypeCheck/TypeCheck.hs view
@@ -15,7 +15,6 @@   , tcExtFramesL   ) where -import Control.Lens (makeLensesWith) import Control.Monad.Except (withExceptT) import Control.Monad.Reader (mapReaderT) import Data.Default (def)@@ -31,18 +30,18 @@   ExceptT TCError     (State TypeCheckEnv) -type TcOriginatedContracts = Map ContractHash U.Type+type TcOriginatedContracts = Map ContractHash U.ParameterType  -- | The typechecking state data TypeCheckEnv = TypeCheckEnv-  { tcExtFrames     :: ~TcExtFrames-  , tcContractParam :: ~U.Type-  , tcContracts     :: ~TcOriginatedContracts+  { tcExtFrames       :: ~TcExtFrames+  , tcContractParam   :: ~U.ParameterType+  , tcContracts       :: ~TcOriginatedContracts   }  makeLensesWith postfixLFields ''TypeCheckEnv -runTypeCheck :: U.Type -> TcOriginatedContracts -> TypeCheck a -> Either TCError a+runTypeCheck :: U.ParameterType -> TcOriginatedContracts -> TypeCheck a -> Either TCError a runTypeCheck param contracts act =   evaluatingState (TypeCheckEnv [] param contracts) $ runExceptT act
src/Michelson/TypeCheck/Types.hs view
@@ -8,21 +8,25 @@     , SomeContract (..)     , BoundVars (..)     , TcExtFrames+    , getWTP+    , withWTPm     , mapSomeContract     , noBoundVars     ) where -import Data.Singletons (SingI)+import Data.Constraint (Dict(..))+import qualified Data.Map.Lazy as Map+import Data.Singletons (Sing, SingI(..))+import Fmt (Buildable(..), Builder, (+|), (|+)) import Prelude hiding (EQ, GT, LT) import qualified Text.Show-import qualified Data.Map.Lazy as Map -import Michelson.Untyped (Var, Type, noAnn)-import Michelson.Untyped.Annotation (VarAnn)-import Michelson.Typed-  (Notes(..), Sing(..), T(..), starNotes, notesT)+import Michelson.Typed (Notes(..), T(..), SingT(..), notesT, starNotes)+import Michelson.Typed.Haskell.Value (WellTyped) import qualified Michelson.Typed as T import Michelson.Typed.Instr+import Michelson.Untyped (Type, Var, noAnn)+import Michelson.Untyped.Annotation (VarAnn) import Util.Typeable  -- | Data type holding type information for stack (Heterogeneous Stack Type).@@ -51,38 +55,47 @@ data HST (ts :: [T])  where   SNil :: HST '[]   (::&) :: (Typeable xs, Typeable x, SingI x)-        => (Notes x, VarAnn)+        => (Notes x, Dict (WellTyped x), VarAnn)         -> HST xs         -> HST (x ': xs)  instance NFData (HST ts) where   rnf (SNil) = ()-  rnf ((a, b) ::& hst) = rnf (a, b, hst)+  rnf ((a, d, b) ::& hst) = rnf (a, d, b, hst)  instance Show (HST ts) where   show SNil = "[]"   show (r ::& rs) = "[ " <> showDo (r ::& rs) <> " ]"     where       showDo :: HST (t ': ts_) -> String-      showDo ((notesT -> t, _vn) ::& (b ::& c)) =+      showDo ((notesT -> t, Dict, _vn) ::& (b ::& c)) =           show t <> ", " <> showDo (b ::& c)-      showDo ((notesT -> t, _vn) ::& SNil) = show t+      showDo ((notesT -> t, Dict, _vn) ::& SNil) = show t +instance Buildable (HST ts) where+  build SNil = "[]"+  build (r ::& rs) = "[ " +| showDo (r ::& rs) |+ " ]"+    where+      showDo :: HST (t ': ts_) -> Builder+      showDo ((notesT -> t, Dict, _vn) ::& (b ::& c)) =+          build t |+ ", " +| showDo (b ::& c)+      showDo ((notesT -> t, Dict, _vn) ::& SNil) = build t+ infixr 7 ::&  instance Eq (HST ts) where   SNil == SNil = True-  (n1, a1) ::& h1 == (n2, a2) ::& h2 =+  (n1, Dict, a1) ::& h1 == (n2, Dict, a2) ::& h2 =     n1 == n2 && a1 == a2 && h1 == h2  -- | Append a type to 'HST', assuming that notes and annotations -- for this type are unknown. (-:&)-  :: (Typeable xs, Typeable x, SingI x)+  :: (Typeable xs, Typeable x, SingI x, WellTyped x)   => Sing x   -> HST xs   -> HST (x ': xs)-_ -:& hst = (starNotes, noAnn) ::& hst+_ -:& hst = (starNotes, Dict, noAnn) ::& hst infixr 7 -:&  -- | Extended pattern-match - adds @Sing x@ argument.@@ -92,11 +105,11 @@   => ( ys ~ (x ': xs)      , Typeable x, SingI x, Typeable xs      )-  => (Sing x, Notes x, VarAnn)+  => (Sing x, Notes x, Dict (WellTyped x), VarAnn)   -> HST xs   -> HST ys-pattern x ::&+ hst <- ((\(n, v) -> (T.notesSing n, n, v)) -> x) ::& hst-  where (_, n, v) ::&+ hst = (n, v) ::& hst+pattern x ::&+ hst <- ((\(n, d, v) -> (T.notesSing n, n, d, v)) -> x) ::& hst+  where (_, n, d, v) ::&+ hst = (n, d, v) ::& hst  -- | No-argument type wrapper for @HST@ data type. data SomeHST where@@ -169,3 +182,52 @@  -- | State for type checking @nop@ type TcExtFrames = [BoundVars]++fromMDict :: Maybe (Dict a) -> (a => Maybe (Dict b)) -> Maybe (Dict b)+fromMDict ma b = ma >>= (\Dict -> b)++-- | Given a type, provide evidence that it is well typed w.r.t to the+--  Michelson rules regarding where comparable types are required.+getWTP :: forall t. SingI t => Maybe (Dict (WellTyped t))+getWTP = case sing @t of+  STKey -> Just Dict+  STUnit -> Just Dict+  STSignature -> Just Dict+  STChainId -> Just Dict+  STOption s -> fromMDict (getWTP_ s) (Just Dict)+  STList s -> fromMDict (getWTP_ s) (Just Dict)+  STSet s -> fromMDict (getWTP_ s) $ fromMDict (T.getComparableProofS s) (Just Dict)+  STOperation  -> Just Dict+  STContract s -> fromMDict (getWTP_ s) (Just Dict)+  STPair s1 s2 -> fromMDict (getWTP_ s1) $ fromMDict (getWTP_ s2) $ Just Dict+  STOr s1 s2 -> fromMDict (getWTP_ s1) $ fromMDict (getWTP_ s2) $ Just Dict+  STLambda s1 s2 -> fromMDict (getWTP_ s1) $ fromMDict (getWTP_ s2) $ Just Dict+  STMap s1 s2 ->+    fromMDict (getWTP_ s1) $+    fromMDict (getWTP_ s2) $+    fromMDict (T.getComparableProofS s1) $ Just Dict+  STBigMap s1 s2 ->+    fromMDict (getWTP_ s1) $+    fromMDict (getWTP_ s2) $+    fromMDict (T.getComparableProofS s1) $ Just Dict+  STInt -> Just Dict+  STNat -> Just Dict+  STString -> Just Dict+  STBytes -> Just Dict+  STMutez -> Just Dict+  STBool -> Just Dict+  STKeyHash -> Just Dict+  STTimestamp -> Just Dict+  STAddress -> Just Dict+  where+    getWTP_ :: forall t1. SingI t1 => Sing t1 -> Maybe (Dict (WellTyped t1))+    getWTP_ _ = getWTP @t1++-- | Given a type and an action that requires evidence that the type is well typed,+--  generate the evidence and execute the action, or else fail with an error.+withWTPm :: forall t m a. (MonadFail m, SingI t) => (WellTyped t => m a) -> m a+withWTPm a = case getWTP @t of+  Just Dict -> a+  Nothing ->+    fail ("This type is not well typed because it has an non-comparable type in it," <>+          "where a comparable type is required")
src/Michelson/TypeCheck/Value.hs view
@@ -1,6 +1,5 @@ module Michelson.TypeCheck.Value     ( typeCheckValImpl-    , typeCheckCValue     ) where  import Control.Monad.Except (liftEither, throwError)@@ -8,7 +7,7 @@ import Data.Default (def) import qualified Data.Map as M import qualified Data.Set as S-import Data.Singletons (SingI(..), demote)+import Data.Singletons (Sing, SingI(..), demote) import Data.Typeable ((:~:)(..)) import Prelude hiding (EQ, GT, LT) @@ -18,52 +17,13 @@ import Michelson.TypeCheck.TypeCheck (TcInstrHandler, TypeCheckEnv(..), TypeCheckInstr) import Michelson.TypeCheck.Types import Michelson.Typed-  (pattern AsUTypeExt, CValue(..), EpAddress(..), Notes(..), Sing(..), Value'(..), fromSingCT,-  fromSingT, starNotes)+  (pattern AsUTypeExt, EpAddress(..), Notes(..), ParamNotes(..), SingT(..), Value'(..), fromSingT, starNotes) import qualified Michelson.Typed as T import qualified Michelson.Untyped as U import Tezos.Address (Address(..)) import Tezos.Core import Tezos.Crypto (parseKeyHash, parsePublicKey, parseSignature) -typeCheckCValue-  :: forall op ct-  .  U.Value' op -> Sing ct -> Either (U.Value' op, TCTypeError) (CValue ct)-typeCheckCValue val ct = case (val, ct) of-  (U.ValueInt i, SCInt) -> pure $ CvInt i-  (U.ValueInt i, SCNat)-    | i >= 0 -> pure $ CvNat (fromInteger i)-    | otherwise -> Left (U.ValueInt i, NegativeNat)-  (v@(U.ValueInt i), SCMutez) -> do-    mtz <- maybeToRight (v, InvalidTimestamp) . mkMutez $ fromInteger i-    pure $ CvMutez mtz-  (U.ValueString s, SCString) ->-    pure $ CvString s-  (v@(U.ValueString s), SCAddress) -> do-    addr <- T.parseEpAddress (unMText s) `onLeft` ((v, ) . InvalidAddress)-    pure $ CvAddress addr-  (v@(U.ValueString s), SCKeyHash) -> do-    kHash <- parseKeyHash (unMText s) `onLeft` ((v, ) . InvalidKeyHash)-    pure $ CvKeyHash kHash-  (v@(U.ValueString s), SCTimestamp) -> do-    tstamp <- maybeToRight (v, InvalidTimestamp) . parseTimestamp $ unMText s-    pure $ CvTimestamp tstamp-  (U.ValueInt i, SCTimestamp) ->-    pure $ CvTimestamp (timestampFromSeconds i)-  (U.ValueBytes (U.InternalByteString s), SCBytes) ->-    pure $ CvBytes s-  (U.ValueTrue, SCBool) -> pure $ CvBool True-  (U.ValueFalse, SCBool) -> pure $ CvBool False-  (v, t) ->-    Left $ (v, InvalidValueType $ T.Tc $ fromSingCT t)--typeCheckCVals-  :: forall t op-  .  [U.Value' op]-  -> Sing t-  -> Either (U.Value' op, TCTypeError) [CValue t]-typeCheckCVals mvs t = traverse (`typeCheckCValue` t) mvs- tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a tcFailedOnValue v t msg err = do   loc <- ask@@ -88,10 +48,35 @@   -> U.Value   -> TypeCheckInstr (T.Value ty) typeCheckValImpl tcDo uvalue = case (uvalue, sing @ty) of-  (mv, t@(STc ct)) -> do-    case typeCheckCValue mv ct of-      Left (uval, err) -> tcFailedOnValue uval (fromSingT t) "" (Just err)-      Right v -> pure $ VC v+  (U.ValueInt i, STInt) -> pure $ T.VInt i+  (v@(U.ValueInt i), t@STNat)+    | i >= 0 -> pure $ VNat (fromInteger i)+    | otherwise -> tcFailedOnValue v (fromSingT t) "" (Just NegativeNat)+  (v@(U.ValueInt i), t@STMutez) -> do+    case mkMutez $ fromInteger i of+      Just mtz -> pure $ VMutez mtz+      Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)+  (U.ValueString s, STString) ->+    pure $ VString s+  (v@(U.ValueString s), t@STAddress) -> do+    case T.parseEpAddress (unMText s) of+      Right addr -> pure $ VAddress addr+      Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidAddress err)+  (v@(U.ValueString s), t@STKeyHash) -> do+    case parseKeyHash (unMText s)  of+      Right kHash -> pure $ VKeyHash kHash+      Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)+  (v@(U.ValueString s), t@STTimestamp) -> do+    case parseTimestamp $ unMText s of+      Just tstamp -> pure $ VTimestamp tstamp+      Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)+  (U.ValueInt i, STTimestamp) ->+    pure $ VTimestamp (timestampFromSeconds i)+  (U.ValueBytes (U.InternalByteString s), STBytes) ->+    pure $ VBytes s+  (U.ValueTrue, STBool) -> pure $ VBool True+  (U.ValueFalse, STBool) -> pure $ VBool False+   (U.ValueString (parsePublicKey . unMText -> Right s), STKey) ->     pure $ T.VKey s @@ -112,11 +97,10 @@           liftEither @_ @TypeCheckInstr $           first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $             eqType @cp @t'-    let unsupportedType :: Text -> Either TCError a-        unsupportedType desc =-          Left $-          TCFailedOnValue cv (fromSingT pc) (desc <> " in type argument of 'contract' type") instrPos $-          Just (UnsupportedTypes [fromSingT pc])+    let unsupportedType :: T.BadTypeForScope -> TCError+        unsupportedType reason =+          TCFailedOnValue cv (fromSingT pc) ("Unsupported type in type argument of 'contract' type") instrPos $+          Just $ UnsupportedTypeForScope (fromSingT pc) reason     let EpAddress addr epName = epAddr     case addr of       KeyAddress _ -> do@@ -124,12 +108,13 @@         pure $ VContract addr T.sepcPrimitive       ContractAddress ca ->         case M.lookup ca contracts of-          -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has-          -- valid parameter type-          Just (AsUTypeExt cpSing (T.ParamNotesUnsafe -> cpNotes)) -> do-            Dict <- liftEither $ maybe (unsupportedType "Operation") pure (T.opAbsense cpSing)-            Dict <- liftEither $ maybe (unsupportedType "Nested BigMaps") pure (T.nestedBigMapsAbsense cpSing)-            case T.mkEntryPointCall epName cpNotes of+          Just (U.ParameterType (AsUTypeExt (_ :: Sing cp') cpNotes) rootAnn) -> do+            -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has+            -- valid parameter type+            let paramNotes = ParamNotesUnsafe { pnNotes = cpNotes, pnRootAnn = rootAnn }+            Dict <- liftEither $ T.checkScope @(T.ParameterScope cp')+              `onLeft` unsupportedType+            case T.mkEntryPointCall epName paramNotes of               Nothing ->                 throwError $                 TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $@@ -165,28 +150,31 @@     els <- typeCheckValsImpl tcDo mels     pure $ VList els -  (U.ValueNil, STSet _) ->-    pure $ T.VSet S.empty+  (U.ValueNil, STSet (s :: Sing st)) -> do+    instrPos <- ask+    case T.getComparableProofS s of+      Just Dict -> pure (T.VSet S.empty)+      Nothing -> throwError $ TCFailedOnValue uvalue (demote @st) "Non comparable types are not allowed in Sets"+        instrPos (Just $ UnsupportedTypeForScope (demote @st) T.BtNotComparable) -  (sq@(U.ValueSeq (toList -> mels)), STSet vt) -> do+  (sq@(U.ValueSeq (toList -> mels)), s@(STSet (vt :: Sing st))) -> withComparable vt sq s $ do     instrPos <- ask-    els <- liftEither $ typeCheckCVals mels vt-            `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc vt)-                                        "wrong type of set element:" instrPos (Just err)++    els <- typeCheckValsImpl tcDo mels     elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els-              `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc vt) msg instrPos Nothing+              `onLeft` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing     pure $ VSet elsS -  (U.ValueNil, STMap _ _) -> pure $ T.VMap M.empty+  (v@U.ValueNil, s@(STMap (st :: Sing st) _)) -> withComparable st v s $ pure $ T.VMap M.empty -  (sq@(U.ValueMap (toList -> mels)), STMap kt _) -> do+  (sq@(U.ValueMap (toList -> mels)), s@(STMap (kt :: Sing st) _)) -> withComparable kt sq s $ do     keyOrderedElts <- typeCheckMapVal tcDo mels sq kt     pure $ VMap (M.fromDistinctAscList keyOrderedElts) -  (U.ValueNil, STBigMap _ _) ->-    pure $ T.VBigMap M.empty+  (v@U.ValueNil, s@(STBigMap (st :: Sing st) _)) ->+    withComparable st v s $ pure $ T.VBigMap M.empty -  (sq@(U.ValueMap (toList -> mels)), STBigMap kt _) -> do+  (sq@(U.ValueMap (toList -> mels)), s@(STBigMap (kt :: Sing st) _)) -> withComparable kt sq s $ do     keyOrderedElts <- typeCheckMapVal tcDo mels sq kt     pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) @@ -195,9 +183,9 @@       U.ValueNil       -> pure []       U.ValueLambda mp -> pure $ toList mp       _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing-    _ :/ instr <- typeCheckImpl tcDo mp ((starNotes @it, def) ::& SNil)+    _ :/ instr <- withWTP @it $ typeCheckImpl tcDo mp ((starNotes @it, Dict, def) ::& SNil)     case instr of-      lam ::: (lo :: HST lo) -> do+      lam ::: (lo :: HST lo) -> withWTP @ot $ do         case eqHST1 @ot lo of           Right Refl -> do             pure $ VLam (T.RfNormal lam)@@ -208,27 +196,42 @@         pure $ VLam (T.RfAlwaysFails lam)    (v, t) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing+  where+    withWTP :: forall t a. SingI t => (T.WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a+    withWTP fn = case getWTP @t of+      Just Dict -> fn+      Nothing -> tcFailedOnValue uvalue (fromSingT $ sing @ty) "Value is not well typed" Nothing +withComparable+  :: forall a (t :: T.T) ty. Sing a+  -> U.Value+  -> Sing t+  -> (T.Comparable a => TypeCheckInstr ty)+  -> TypeCheckInstr ty+withComparable s uv t act = case T.getComparableProofS s of+  Just Dict -> act+  Nothing -> do+    instrPos <- ask+    liftEither $ Left $ TCFailedOnValue uv (fromSingT t) "Require a comparable type here" instrPos Nothing+ -- | Function @typeCheckMapVal@ typechecks given list of @Elt@s and -- ensures, that its keys are in ascending order. -- -- It return list of pairs (key, value) with keys in ascending order -- so it is safe to call @fromDistinctAscList@ on returned list typeCheckMapVal-  :: (SingI kt, Typeable kt, SingI vt)+  :: forall kt vt. (SingI kt, SingI vt)   => TcInstrHandler   -> [U.Elt U.ExpandedOp]   -> U.Value   -> Sing kt-  -> TypeCheckInstr [(CValue kt, T.Value vt)]-typeCheckMapVal tcDo mels sq kt = do+  -> TypeCheckInstr [(T.Value kt, T.Value vt)]+typeCheckMapVal tcDo mels sq kt = withComparable kt sq kt $ do   instrPos <- ask-  ks <- liftEither $ typeCheckCVals (map (\(U.Elt k _) -> k) mels) kt-          `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc kt)-                                      "wrong type of map key:" instrPos (Just err)-  vals <- typeCheckValsImpl tcDo (map (\(U.Elt _ v) -> v) mels)+  ks <- typeCheckValsImpl @kt tcDo (map (\(U.Elt k _) -> k) mels)+  vals <- typeCheckValsImpl @vt tcDo (map (\(U.Elt _ v) -> v) mels)   ksS <- liftEither $ ensureDistinctAsc id ks-        `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc kt) msg instrPos Nothing+        `onLeft` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing   pure $ zip ksS vals  typeCheckValsImpl
src/Michelson/Typed.hs view
@@ -6,7 +6,6 @@ import Michelson.Typed.Annotation as Exports import Michelson.Typed.Arith as Exports import Michelson.Typed.Convert as Exports-import Michelson.Typed.CValue as Exports import Michelson.Typed.Doc as Exports import Michelson.Typed.EntryPoints as Exports import Michelson.Typed.Extract as Exports
src/Michelson/Typed/Annotation.hs view
@@ -19,17 +19,17 @@   , AnnConvergeError(..)   , converge   , convergeAnns+  , insertTypeAnn   , orAnn   , isStar   , starNotes   , notesSing   , notesT-  , pattern NTcs   ) where  import Data.Default (Default(..)) import qualified Data.Kind as Kind-import Data.Singletons (SingI(..))+import Data.Singletons (Sing, SingI(..)) import Fmt (Buildable(..), (+|), (|+)) import Text.PrettyPrint.Leijen.Text (Doc, (<+>)) import qualified Text.Show@@ -49,7 +49,6 @@ -- and holds all type and field annotations that can be attributed to a -- Michelson type corrspoding to @t@. data Notes t where-  NTc         :: TypeAnn -> Notes ('Tc ct)   NTKey       :: TypeAnn -> Notes 'TKey   NTUnit      :: TypeAnn -> Notes 'TUnit   NTSignature :: TypeAnn -> Notes 'TSignature@@ -66,6 +65,15 @@   NTLambda    :: TypeAnn -> Notes p -> Notes q -> Notes ('TLambda p q)   NTMap       :: TypeAnn -> TypeAnn -> Notes v -> Notes ('TMap k v)   NTBigMap    :: TypeAnn -> TypeAnn -> Notes v -> Notes ('TBigMap k v)+  NTInt       :: TypeAnn -> Notes 'TInt+  NTNat       :: TypeAnn -> Notes 'TNat+  NTString    :: TypeAnn -> Notes 'TString+  NTBytes     :: TypeAnn -> Notes 'TBytes+  NTMutez     :: TypeAnn -> Notes 'TMutez+  NTBool      :: TypeAnn -> Notes 'TBool+  NTKeyHash   :: TypeAnn -> Notes 'TKeyHash+  NTTimestamp :: TypeAnn -> Notes 'TTimestamp+  NTAddress   :: TypeAnn -> Notes 'TAddress  deriving stock instance Eq (Notes t) $(deriveGADTNFData ''Notes)@@ -79,7 +87,15 @@  instance RenderDoc (Notes t) where   renderDoc pn n = addParens pn $ case n of-    NTc ta                  -> "NTc" <+> rendT ta+    NTInt ta                -> "NTInt" <+> rendT ta+    NTNat ta                -> "NTNat" <+> rendT ta+    NTString ta             -> "NTString" <+> rendT ta+    NTBytes ta              -> "NTBytes" <+> rendT ta+    NTMutez ta              -> "NTMutez" <+> rendT ta+    NTBool ta               -> "NTBool" <+> rendT ta+    NTKeyHash ta            -> "NTKeyHash" <+> 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@@ -118,15 +134,19 @@ notesT :: SingI t => Notes t -> T notesT = fromSingT . notesSing --- | Similar to 'NTc' pattern, but gives singleton of the comparable type.-pattern NTcs :: SingI t => (t ~ 'Tc ct) => Sing ct -> Notes t-pattern NTcs s <- (notesSing -> STc s)- -- | In memory of `NStar` constructor. --   Generates notes with no annotations. starNotes :: forall t. SingI t => Notes t starNotes = case sing @t of-  STc _ -> NTc noAnn+  STInt -> NTInt noAnn+  STNat -> NTNat noAnn+  STString -> NTString noAnn+  STBytes -> NTBytes noAnn+  STMutez -> NTMutez noAnn+  STBool -> NTBool noAnn+  STKeyHash -> NTKeyHash noAnn+  STTimestamp -> NTTimestamp noAnn+  STAddress -> NTAddress noAnn   STKey -> NTKey noAnn   STUnit -> NTUnit noAnn   STSignature -> NTSignature noAnn@@ -154,7 +174,15 @@ -- some empty leaves with type or/and field annotations. converge :: Notes t -> Notes t -> Either AnnConvergeError (Notes t) converge n1 n2 = case (n1, n2) of-  (NTc a, NTc b) -> NTc <$> convergeAnns a b+  (NTInt a, NTInt b) -> NTInt <$> convergeAnns a b+  (NTNat a, NTNat b) -> NTNat <$> convergeAnns a b+  (NTString a, NTString b) -> NTString <$> convergeAnns a b+  (NTBytes a, NTBytes b) -> NTBytes <$> convergeAnns a b+  (NTMutez a, NTMutez b) -> NTMutez <$> convergeAnns a b+  (NTBool a, NTBool b) -> NTBool <$> convergeAnns a b+  (NTKeyHash a, NTKeyHash b) -> NTKeyHash <$> 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   (NTSignature a, NTSignature b) ->@@ -183,6 +211,33 @@     NTMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM   (NTBigMap a kN vN, NTBigMap b kM vM) ->     NTBigMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM++-- | Insert the provided type annotation into the provided notes.+insertTypeAnn :: forall (b :: T). TypeAnn -> Notes b -> Notes b+insertTypeAnn nt s = case s of+  NTInt _ -> NTInt nt+  NTNat _ -> NTNat nt+  NTString _ -> NTString nt+  NTBytes _ -> NTBytes nt+  NTMutez _ -> NTMutez nt+  NTBool _ -> NTBool nt+  NTKeyHash _ -> NTKeyHash nt+  NTTimestamp _ -> NTTimestamp nt+  NTAddress _ -> NTAddress nt+  NTKey _ -> NTKey nt+  NTUnit _ -> NTUnit nt+  NTSignature _ -> NTSignature nt+  NTOption _ n1  -> NTOption nt n1+  NTList _ n1 -> NTList nt n1+  NTSet _ n1 -> NTSet nt n1+  NTOperation _ -> NTOperation nt+  NTContract _ n1 -> NTContract nt n1+  NTPair _ n1 n2 n3 n4 -> NTPair nt n1 n2 n3 n4+  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  data AnnConvergeError where   AnnConvergeError
src/Michelson/Typed/Arith.hs view
@@ -30,21 +30,19 @@   ) where  import Data.Bits (complement, shift, (.&.), (.|.))-import Data.Singletons (SingI(..))+import Data.Singletons (Sing, SingI(..)) import Fmt (Buildable(build)) -import Michelson.Typed.CValue (CValue(..))-import Michelson.Typed.Scope (Comparability(..), Comparable, checkComparability)-import Michelson.Typed.Sing (Sing(..))-import Michelson.Typed.T (CT(..))-import Michelson.Typed.Value (Value'(..))+import Michelson.Typed.Sing (SingT(..))+import Michelson.Typed.T (T(..))+import Michelson.Typed.Value (Comparable, Comparability(..), checkComparability, Value'(..)) import Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds)  -- | 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 :: CT) (m :: CT) where+class 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@.@@ -52,10 +50,14 @@   -- For instance, adding integer to natural produces integer,   -- which is reflected in following instance of type family:   -- @ArithRes Add CNat CInt = CInt@.-  type ArithRes aop n m :: CT+  type ArithRes aop n m :: T    -- | Evaluate arithmetic operation on given operands.-  evalOp :: proxy aop -> CValue n -> CValue m -> Either (ArithError (CValue n) (CValue m)) (CValue (ArithRes aop n m))+  evalOp+    :: proxy aop+    -> Value' instr n+    -> Value' instr m+    -> Either (ArithError (Value' instr n) (Value' instr m)) (Value' instr (ArithRes aop n m))  -- | Denotes the error type occured in the arithmetic operation. data ArithErrorType@@ -77,9 +79,9 @@ instance (NFData n, NFData m) => NFData (ArithError n m)  -- | Marker data type for add operation.-class UnaryArithOp aop (n :: CT) where-  type UnaryArithRes aop n :: CT-  evalUnaryArithOp :: proxy aop -> CValue n -> CValue (UnaryArithRes aop n)+class UnaryArithOp aop (n :: T) where+  type UnaryArithRes aop n :: T+  evalUnaryArithOp :: proxy aop -> Value' instr n -> Value' instr (UnaryArithRes aop n)  data Add data Sub@@ -102,174 +104,183 @@ data Le data Ge -instance ArithOp Add 'CNat 'CInt where-  type ArithRes Add 'CNat 'CInt = 'CInt-  evalOp _ (CvNat i) (CvInt j) = Right $ CvInt (toInteger i + j)-instance ArithOp Add 'CInt 'CNat where-  type ArithRes Add 'CInt 'CNat = 'CInt-  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i + toInteger j)-instance ArithOp Add 'CNat 'CNat where-  type ArithRes Add 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i + j)-instance ArithOp Add 'CInt 'CInt where-  type ArithRes Add 'CInt 'CInt = 'CInt-  evalOp _ (CvInt i) (CvInt j) = Right $ CvInt (i + j)-instance ArithOp Add 'CTimestamp 'CInt where-  type ArithRes Add 'CTimestamp 'CInt = 'CTimestamp-  evalOp _ (CvTimestamp i) (CvInt j) =-    Right $ CvTimestamp $ timestampFromSeconds $ timestampToSeconds i + j-instance ArithOp Add 'CInt 'CTimestamp where-  type ArithRes Add 'CInt 'CTimestamp = 'CTimestamp-  evalOp _ (CvInt i) (CvTimestamp j) =-    Right $ CvTimestamp $ timestampFromSeconds $ timestampToSeconds j + i-instance ArithOp Add 'CMutez 'CMutez where-  type ArithRes Add 'CMutez 'CMutez = 'CMutez-  evalOp _ n@(CvMutez i) m@(CvMutez j) = res+instance ArithOp Add 'TNat 'TInt where+  type ArithRes Add 'TNat 'TInt = 'TInt+  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i + j)+instance ArithOp Add 'TInt 'TNat where+  type ArithRes Add 'TInt 'TNat = 'TInt+  evalOp _ (VInt i) (VNat j) = Right $ VInt (i + toInteger j)+instance ArithOp Add 'TNat 'TNat where+  type ArithRes Add 'TNat 'TNat = 'TNat+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i + j)+instance ArithOp Add 'TInt 'TInt where+  type ArithRes Add 'TInt 'TInt = 'TInt+  evalOp _ (VInt i) (VInt j) = Right $ VInt (i + j)+instance ArithOp Add 'TTimestamp 'TInt where+  type ArithRes Add 'TTimestamp 'TInt = 'TTimestamp+  evalOp _ (VTimestamp i) (VInt j) =+    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i + j+instance ArithOp Add 'TInt 'TTimestamp where+  type ArithRes Add 'TInt 'TTimestamp = 'TTimestamp+  evalOp _ (VInt i) (VTimestamp j) =+    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds j + i+instance ArithOp Add 'TMutez 'TMutez where+  type ArithRes Add 'TMutez 'TMutez = 'TMutez+  evalOp _ n@(VMutez i) m@(VMutez j) = res     where-      res = maybe (Left $ MutezArithError AddOverflow n m) (Right . CvMutez) $ i `addMutez` j+      res = maybe (Left $ MutezArithError AddOverflow n m) (Right . VMutez) $ i `addMutez` j -instance ArithOp Sub 'CNat 'CInt where-  type ArithRes Sub 'CNat 'CInt = 'CInt-  evalOp _ (CvNat i) (CvInt j) = Right $ CvInt (toInteger i - j)-instance ArithOp Sub 'CInt 'CNat where-  type ArithRes Sub 'CInt 'CNat = 'CInt-  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i - toInteger j)-instance ArithOp Sub 'CNat 'CNat where-  type ArithRes Sub 'CNat 'CNat = 'CInt-  evalOp _ (CvNat i) (CvNat j) = Right $ CvInt (toInteger i - toInteger j)-instance ArithOp Sub 'CInt 'CInt where-  type ArithRes Sub 'CInt 'CInt = 'CInt-  evalOp _ (CvInt i) (CvInt j) = Right $ CvInt (i - j)-instance ArithOp Sub 'CTimestamp 'CInt where-  type ArithRes Sub 'CTimestamp 'CInt = 'CTimestamp-  evalOp _ (CvTimestamp i) (CvInt j) =-    Right $ CvTimestamp $ timestampFromSeconds $ timestampToSeconds i - j-instance ArithOp Sub 'CTimestamp 'CTimestamp where-  type ArithRes Sub 'CTimestamp 'CTimestamp = 'CInt-  evalOp _ (CvTimestamp i) (CvTimestamp j) =-    Right $ CvInt $ timestampToSeconds i - timestampToSeconds j-instance ArithOp Sub 'CMutez 'CMutez where-  type ArithRes Sub 'CMutez 'CMutez = 'CMutez-  evalOp _ n@(CvMutez i) m@(CvMutez j) = res+instance ArithOp Sub 'TNat 'TInt where+  type ArithRes Sub 'TNat 'TInt = 'TInt+  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i - j)+instance ArithOp Sub 'TInt 'TNat where+  type ArithRes Sub 'TInt 'TNat = 'TInt+  evalOp _ (VInt i) (VNat j) = Right $ VInt (i - toInteger j)+instance ArithOp Sub 'TNat 'TNat where+  type ArithRes Sub 'TNat 'TNat = 'TInt+  evalOp _ (VNat i) (VNat j) = Right $ VInt (toInteger i - toInteger j)+instance ArithOp Sub 'TInt 'TInt where+  type ArithRes Sub 'TInt 'TInt = 'TInt+  evalOp _ (VInt i) (VInt j) = Right $ VInt (i - j)+instance ArithOp Sub 'TTimestamp 'TInt where+  type ArithRes Sub 'TTimestamp 'TInt = 'TTimestamp+  evalOp _ (VTimestamp i) (VInt j) =+    Right $ VTimestamp $ timestampFromSeconds $ timestampToSeconds i - j+instance ArithOp Sub 'TTimestamp 'TTimestamp where+  type ArithRes Sub 'TTimestamp 'TTimestamp = 'TInt+  evalOp _ (VTimestamp i) (VTimestamp j) =+    Right $ VInt $ timestampToSeconds i - timestampToSeconds j+instance ArithOp Sub 'TMutez 'TMutez where+  type ArithRes Sub 'TMutez 'TMutez = 'TMutez+  evalOp _ n@(VMutez i) m@(VMutez j) = res     where-      res = maybe (Left $ MutezArithError SubUnderflow n m) (Right . CvMutez) $ i `subMutez` j+      res = maybe (Left $ MutezArithError SubUnderflow n m) (Right . VMutez) $ i `subMutez` j -instance ArithOp Mul 'CNat 'CInt where-  type ArithRes Mul 'CNat 'CInt = 'CInt-  evalOp _ (CvNat i) (CvInt j) = Right $ CvInt (toInteger i * j)-instance ArithOp Mul 'CInt 'CNat where-  type ArithRes Mul 'CInt 'CNat = 'CInt-  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i * toInteger j)-instance ArithOp Mul 'CNat 'CNat where-  type ArithRes Mul 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i * j)-instance ArithOp Mul 'CInt 'CInt where-  type ArithRes Mul 'CInt 'CInt = 'CInt-  evalOp _ (CvInt i) (CvInt j) = Right $ CvInt (i * j)-instance ArithOp Mul 'CNat 'CMutez where-  type ArithRes Mul 'CNat 'CMutez = 'CMutez-  evalOp _ n@(CvNat i) m@(CvMutez j) = res+instance ArithOp Mul 'TNat 'TInt where+  type ArithRes Mul 'TNat 'TInt = 'TInt+  evalOp _ (VNat i) (VInt j) = Right $ VInt (toInteger i * j)+instance ArithOp Mul 'TInt 'TNat where+  type ArithRes Mul 'TInt 'TNat = 'TInt+  evalOp _ (VInt i) (VNat j) = Right $ VInt (i * toInteger j)+instance ArithOp Mul 'TNat 'TNat where+  type ArithRes Mul 'TNat 'TNat = 'TNat+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i * j)+instance ArithOp Mul 'TInt 'TInt where+  type ArithRes Mul 'TInt 'TInt = 'TInt+  evalOp _ (VInt i) (VInt j) = Right $ VInt (i * j)+instance ArithOp Mul 'TNat 'TMutez where+  type ArithRes Mul 'TNat 'TMutez = 'TMutez+  evalOp _ n@(VNat i) m@(VMutez j) = res     where-      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . CvMutez) $ j `mulMutez` i-instance ArithOp Mul 'CMutez 'CNat where-  type ArithRes Mul 'CMutez 'CNat = 'CMutez-  evalOp _ n@(CvMutez i) m@(CvNat j) = res+      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ j `mulMutez` i+instance ArithOp Mul 'TMutez 'TNat where+  type ArithRes Mul 'TMutez 'TNat = 'TMutez+  evalOp _ n@(VMutez i) m@(VNat j) = res     where-      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . CvMutez) $ i `mulMutez` j+      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . VMutez) $ i `mulMutez` j -instance UnaryArithOp Abs 'CInt where-  type UnaryArithRes Abs 'CInt = 'CNat-  evalUnaryArithOp _ (CvInt i) = CvNat (fromInteger $ abs i)+instance UnaryArithOp Abs 'TInt where+  type UnaryArithRes Abs 'TInt = 'TNat+  evalUnaryArithOp _ (VInt i) = VNat (fromInteger $ abs i) -instance UnaryArithOp Neg 'CInt where-  type UnaryArithRes Neg 'CInt = 'CInt-  evalUnaryArithOp _ (CvInt i) = CvInt (-i)-instance UnaryArithOp Neg 'CNat where-  type UnaryArithRes Neg 'CNat = 'CInt-  evalUnaryArithOp _ (CvNat i) = CvInt (- fromIntegral i)+instance UnaryArithOp Neg 'TInt where+  type UnaryArithRes Neg 'TInt = 'TInt+  evalUnaryArithOp _ (VInt i) = VInt (-i)+instance UnaryArithOp Neg 'TNat where+  type UnaryArithRes Neg 'TNat = 'TInt+  evalUnaryArithOp _ (VNat i) = VInt (- fromIntegral i) -instance ArithOp Or 'CNat 'CNat where-  type ArithRes Or 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i .|. j)-instance ArithOp Or 'CBool 'CBool where-  type ArithRes Or 'CBool 'CBool = 'CBool-  evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i .|. j)+instance ArithOp Or 'TNat 'TNat where+  type ArithRes Or 'TNat 'TNat = 'TNat+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i .|. j)+instance ArithOp Or 'TBool 'TBool where+  type ArithRes Or 'TBool 'TBool = 'TBool+  evalOp _ (VBool i) (VBool j) = Right $ VBool (i .|. j) -instance ArithOp And 'CInt 'CNat where-  type ArithRes And 'CInt 'CNat = 'CNat-  evalOp _ (CvInt i) (CvNat j) = Right $ CvNat ((fromInteger i) .&. j)-instance ArithOp And 'CNat 'CNat where-  type ArithRes And 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i .&. j)-instance ArithOp And 'CBool 'CBool where-  type ArithRes And 'CBool 'CBool = 'CBool-  evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i .&. j)+instance ArithOp And 'TInt 'TNat where+  type ArithRes And 'TInt 'TNat = 'TNat+  evalOp _ (VInt i) (VNat j) = Right $ VNat ((fromInteger i) .&. j)+instance ArithOp And 'TNat 'TNat where+  type ArithRes And 'TNat 'TNat = 'TNat+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i .&. j)+instance ArithOp And 'TBool 'TBool where+  type ArithRes And 'TBool 'TBool = 'TBool+  evalOp _ (VBool i) (VBool j) = Right $ VBool (i .&. j) -instance ArithOp Xor 'CNat 'CNat where-  type ArithRes Xor 'CNat 'CNat = 'CNat-  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i `xor` j)-instance ArithOp Xor 'CBool 'CBool where-  type ArithRes Xor 'CBool 'CBool = 'CBool-  evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i `xor` j)+instance ArithOp Xor 'TNat 'TNat where+  type ArithRes Xor 'TNat 'TNat = 'TNat+  evalOp _ (VNat i) (VNat j) = Right $ VNat (i `xor` j)+instance ArithOp Xor 'TBool 'TBool where+  type ArithRes Xor 'TBool 'TBool = 'TBool+  evalOp _ (VBool i) (VBool j) = Right $ VBool (i `xor` j) -instance ArithOp Lsl 'CNat 'CNat where-  type ArithRes Lsl 'CNat 'CNat = 'CNat-  evalOp _ n@(CvNat i) m@(CvNat j) =+instance ArithOp Lsl 'TNat 'TNat where+  type ArithRes Lsl 'TNat 'TNat = 'TNat+  evalOp _ n@(VNat i) m@(VNat j) =     if j > 256     then Left $ ShiftArithError LslOverflow n m-    else Right $ CvNat (fromInteger $ shift (toInteger i) (fromIntegral j))+    else Right $ VNat (fromInteger $ shift (toInteger i) (fromIntegral j)) -instance ArithOp Lsr 'CNat 'CNat where-  type ArithRes Lsr 'CNat 'CNat = 'CNat-  evalOp _ n@(CvNat i) m@(CvNat j) =+instance ArithOp Lsr 'TNat 'TNat where+  type ArithRes Lsr 'TNat 'TNat = 'TNat+  evalOp _ n@(VNat i) m@(VNat j) =     if j > 256     then Left $ ShiftArithError LsrUnderflow n m-    else Right $ CvNat (fromInteger $ shift (toInteger i) (-(fromIntegral j)))+    else Right $ VNat (fromInteger $ shift (toInteger i) (-(fromIntegral j))) -instance UnaryArithOp Not 'CInt where-  type UnaryArithRes Not 'CInt = 'CInt-  evalUnaryArithOp _ (CvInt i) = CvInt (complement i)-instance UnaryArithOp Not 'CNat where-  type UnaryArithRes Not 'CNat = 'CInt-  evalUnaryArithOp _ (CvNat i) = CvInt (complement $ toInteger i)-instance UnaryArithOp Not 'CBool where-  type UnaryArithRes Not 'CBool = 'CBool-  evalUnaryArithOp _ (CvBool i) = CvBool (not i)+instance UnaryArithOp Not 'TInt where+  type UnaryArithRes Not 'TInt = 'TInt+  evalUnaryArithOp _ (VInt i) = VInt (complement i)+instance UnaryArithOp Not 'TNat where+  type UnaryArithRes Not 'TNat = 'TInt+  evalUnaryArithOp _ (VNat i) = VInt (complement $ toInteger i)+instance UnaryArithOp Not 'TBool where+  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-  (STc _, VC i, VC j) -> toInteger $ fromEnum (compare i j) - 1-  (STPair l _, VPair (a, b), VPair (c, d)) ->+  (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  -> compareOp b d+          0  -> case checkComparability m of+            CanBeCompared -> compareOp b d           r' -> r' -instance UnaryArithOp Eq' 'CInt where-  type UnaryArithRes Eq' 'CInt = 'CBool-  evalUnaryArithOp _ (CvInt i) = CvBool (i == 0)+instance UnaryArithOp Eq' 'TInt where+  type UnaryArithRes Eq' 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i == 0) -instance UnaryArithOp Neq 'CInt where-  type UnaryArithRes Neq 'CInt = 'CBool-  evalUnaryArithOp _ (CvInt i) = CvBool (i /= 0)+instance UnaryArithOp Neq 'TInt where+  type UnaryArithRes Neq 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i /= 0)  -instance UnaryArithOp Lt 'CInt where-  type UnaryArithRes Lt 'CInt = 'CBool-  evalUnaryArithOp _ (CvInt i) = CvBool (i < 0)+instance UnaryArithOp Lt 'TInt where+  type UnaryArithRes Lt 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i < 0) -instance UnaryArithOp Gt 'CInt where-  type UnaryArithRes Gt 'CInt = 'CBool-  evalUnaryArithOp _ (CvInt i) = CvBool (i > 0)+instance UnaryArithOp Gt 'TInt where+  type UnaryArithRes Gt 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i > 0) -instance UnaryArithOp Le 'CInt where-  type UnaryArithRes Le 'CInt = 'CBool-  evalUnaryArithOp _ (CvInt i) = CvBool (i <= 0)+instance UnaryArithOp Le 'TInt where+  type UnaryArithRes Le 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i <= 0) -instance UnaryArithOp Ge 'CInt where-  type UnaryArithRes Ge 'CInt = 'CBool-  evalUnaryArithOp _ (CvInt i) = CvBool (i >= 0)+instance UnaryArithOp Ge 'TInt where+  type UnaryArithRes Ge 'TInt = 'TBool+  evalUnaryArithOp _ (VInt i) = VBool (i >= 0)   instance Buildable ArithErrorType where
− src/Michelson/Typed/CValue.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- | Module, containing CValue data type--- which represents Michelson comparable values.--module Michelson.Typed.CValue-  ( CValue (..)-  ) where--import Michelson.Text-import Michelson.Typed.EntryPoints-import Michelson.Typed.T (CT(..))-import Tezos.Core (Mutez, Timestamp)-import Tezos.Crypto (KeyHash)-import Util.TH---- | Representation of comparable value--- in Michelson language.------ By specification, we're allowed to compare--- only following types: int, nat, string, bytes,--- mutez, bool, key_hash, timestamp, address.------ Only these values can be used as map keys--- or set elements.-data CValue t where-  CvInt       :: Integer ->  CValue 'CInt-  CvNat       :: Natural -> CValue 'CNat-  CvString    :: MText -> CValue 'CString-  CvBytes     :: ByteString -> CValue 'CBytes-  CvMutez     :: Mutez -> CValue 'CMutez-  CvBool      :: Bool -> CValue 'CBool-  CvKeyHash   :: KeyHash -> CValue 'CKeyHash-  CvTimestamp :: Timestamp -> CValue 'CTimestamp-  CvAddress   :: EpAddress -> CValue 'CAddress--deriving stock instance Show (CValue t)-deriving stock instance Eq (CValue t)-deriving stock instance Ord (CValue t)--$(deriveGADTNFData ''CValue)
src/Michelson/Typed/Convert.hs view
@@ -8,18 +8,17 @@   ) where  import qualified Data.Map as Map-import Data.Singletons (SingI(sing), demote)+import Data.Singletons (demote) import Fmt (Buildable(..), pretty)  import Michelson.Text import Michelson.Typed.Annotation (Notes(..))-import Michelson.Typed.CValue import Michelson.Typed.EntryPoints import Michelson.Typed.Extract (mkUType, toUType) import Michelson.Typed.Instr as Instr import Michelson.Typed.Scope-import Michelson.Typed.Sing (Sing(..))-import Michelson.Typed.T (CT(..), T(..))+import Michelson.Typed.Sing (SingT(..))+import Michelson.Typed.T (T(..)) import Michelson.Typed.Value import qualified Michelson.Untyped as U import Tezos.Core (mformatChainId, unMutez)@@ -32,21 +31,23 @@   => ContractCode param store -> U.Contract convertContractCode contract =   U.Contract-    { para = untypeDemoteT @param-    , stor = untypeDemoteT @store-    , code = instrToOps contract+    { contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn+    , contractStorage = untypeDemoteT @store+    , contractCode = instrToOps contract     } -addCtNote :: U.TypeAnn -> U.Comparable -> U.Comparable-addCtNote ta (U.Comparable ct _) = U.Comparable ct ta+addTNote :: U.TypeAnn -> U.Type -> U.Type+addTNote ta (U.Type ct _) = U.Type ct ta  convertFullContract   :: forall param store . (SingI param, SingI store)   => FullContract param store -> U.Contract convertFullContract fc =   let c = convertContractCode (fcCode fc)-  in c { U.para = mkUType (fcParamNotes fc)-       , U.stor = mkUType (fcStoreNotes fc) }+  in c { U.contractParameter = U.ParameterType (mkUType (pnNotes $ fcParamNotes fc))+         (pnRootAnn (fcParamNotes fc))+       , U.contractStorage = mkUType (fcStoreNotes fc)+       }  -- | Convert a typed 'Val' to an untyped 'Value'. --@@ -58,8 +59,17 @@   => Value' Instr t   -> U.Value untypeValue val = case (val, sing @t) of-  (VC cVal, _) ->-    untypeCValue cVal+  (VInt i, _) -> U.ValueInt i+  (VNat i, _) -> U.ValueInt $ toInteger i+  (VString s, _) -> U.ValueString s+  (VBytes b, _) -> U.ValueBytes $ U.InternalByteString b+  (VMutez m, _) -> U.ValueInt $ toInteger $ unMutez m+  (VBool True, _) -> U.ValueTrue+  (VBool False, _) -> U.ValueFalse+  (VKeyHash h, _) -> U.ValueString $ mformatKeyHash h+  (VTimestamp t, _) -> U.ValueString $ mkMTextUnsafe $ pretty t+  (VAddress a, _) -> U.ValueString $ mformatEpAddress a+   (VKey b, _) ->     U.ValueString $ mformatPublicKey b   (VUnit, _) ->@@ -74,8 +84,9 @@     U.ValueNone   (VList l, STList _) ->     vList U.ValueSeq $ map untypeValue l-  (VSet s, _) ->-    vList U.ValueSeq $ map untypeCValue $ toList s+  (VSet s, STSet (st :: SingT st)) ->+    case checkOpPresence st of+      OpAbsent -> vList U.ValueSeq $ map (untypeValue @st) $ toList s   (VContract addr sepc, _) ->     U.ValueString . mformatEpAddress $ EpAddress addr (sepcName sepc) @@ -94,36 +105,23 @@   (VLam (rfAnyInstr -> ops :: Instr '[inp] '[out]), _) ->     vList U.ValueLambda $ instrToOps ops -  (VMap m, STMap _ vt) ->-    case checkOpPresence vt of-      OpAbsent ->+  (VMap m, STMap kt vt) ->+    case (checkOpPresence kt, checkOpPresence vt) of+      (OpAbsent, OpAbsent) ->         vList U.ValueMap $ Map.toList m <&> \(k, v) ->-        U.Elt (untypeCValue k) (untypeValue v)+        U.Elt (untypeValue k) (untypeValue v) -  (VBigMap m, STBigMap _ vt) ->-    case checkOpPresence vt of-      OpAbsent ->+  (VBigMap m, STBigMap kt vt) ->+    case (checkOpPresence kt, checkOpPresence vt) of+      (OpAbsent, OpAbsent) ->         vList U.ValueMap $ Map.toList m <&> \(k, v) ->-        U.Elt (untypeCValue k) (untypeValue v)+        U.Elt (untypeValue k) (untypeValue v)   where     vList ctor = maybe U.ValueNil ctor . nonEmpty  untypeDemoteT :: forall (t :: T). SingI t => U.Type untypeDemoteT = toUType $ demote @t -untypeCValue :: CValue t -> U.Value-untypeCValue cVal = case cVal of-  CvInt i -> U.ValueInt i-  CvNat i -> U.ValueInt $ toInteger i-  CvString s -> U.ValueString s-  CvBytes b -> U.ValueBytes $ U.InternalByteString b-  CvMutez m -> U.ValueInt $ toInteger $ unMutez m-  CvBool True -> U.ValueTrue-  CvBool False -> U.ValueFalse-  CvKeyHash h -> U.ValueString $ mformatKeyHash h-  CvTimestamp t -> U.ValueString $ mkMTextUnsafe $ pretty t-  CvAddress a -> U.ValueString $ mformatEpAddress a- instrToOps :: HasCallStack => Instr inp out -> [U.ExpandedOp] instrToOps = \case   Nop -> []@@ -181,11 +179,11 @@               U.RIGHT ta va f1 f2 (mkUType n1)             (STList _, U.NIL _ va _, NTList ta n) -> U.NIL ta va (mkUType n)             (_, U.EMPTY_SET _ va ct, NTSet ta1 ta2) ->-              U.EMPTY_SET ta1 va (addCtNote ta2 ct)+              U.EMPTY_SET ta1 va (addTNote ta2 ct)             (STMap _ _, U.EMPTY_MAP _ va ct _, NTMap ta1 ta2 n) ->-              U.EMPTY_MAP ta1 va (addCtNote ta2 ct) (mkUType n)+              U.EMPTY_MAP ta1 va (addTNote ta2 ct) (mkUType n)             (STBigMap _ _, U.EMPTY_BIG_MAP _ va ct _, NTBigMap ta1 ta2 n) ->-              U.EMPTY_BIG_MAP ta1 va (addCtNote ta2 ct) (mkUType n)+              U.EMPTY_BIG_MAP ta1 va (addTNote ta2 ct) (mkUType n)             (STLambda _ _, U.LAMBDA va _ _ ops, NTLambda _ n1 n2) ->               U.LAMBDA va (mkUType n1) (mkUType n2) ops             (_, U.CAST va _, n) -> U.CAST va (mkUType n)@@ -257,7 +255,6 @@             (_, a@(U.SHA512 _), _) -> a             (_, a@(U.BLAKE2B _), _) -> a             (_, a@(U.HASH_KEY _), _) -> a-            (_, a@(U.STEPS_TO_QUOTA _), _) -> a             (_, a@(U.SOURCE _), _) -> a             (_, a@(U.SENDER _), _) -> a             (_, a@(U.ADDRESS _), _) -> a@@ -339,7 +336,6 @@             U.SHA256 _ -> U.SHA512 va             U.BLAKE2B _ -> U.BLAKE2B va             U.HASH_KEY _ -> U.HASH_KEY va-            U.STEPS_TO_QUOTA _ -> U.STEPS_TO_QUOTA va             U.SOURCE _ -> U.SOURCE va             U.SENDER _ -> U.SENDER va             U.ADDRESS _ -> U.ADDRESS va@@ -387,12 +383,12 @@       (IF_CONS i1 i2) -> U.IF_CONS (instrToOps i1) (instrToOps i2)       SIZE -> U.SIZE U.noAnn       i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i ->-        U.EMPTY_SET U.noAnn U.noAnn (U.Comparable (demote @e) U.noAnn)+        U.EMPTY_SET U.noAnn U.noAnn (U.Type (U.unwrapT $ untypeDemoteT @e) U.noAnn)       i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i ->-        U.EMPTY_MAP U.noAnn U.noAnn (U.Comparable (demote @a) U.noAnn)+        U.EMPTY_MAP U.noAnn U.noAnn (U.Type (U.unwrapT $ untypeDemoteT @a) U.noAnn)           (untypeDemoteT @b)       i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i ->-        U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Comparable (demote @a) U.noAnn)+        U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Type (U.unwrapT $ untypeDemoteT @a) U.noAnn)           (untypeDemoteT @b)       (MAP op) -> U.MAP U.noAnn $ instrToOps op       (ITER op) -> U.ITER $ instrToOps op@@ -415,7 +411,7 @@       RENAME -> U.RENAME U.noAnn       PACK -> U.PACK U.noAnn       i@UNPACK-        | _ :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) <- i ->+        | _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i ->             U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a)       CONCAT -> U.CONCAT U.noAnn       CONCAT' -> U.CONCAT U.noAnn@@ -444,18 +440,18 @@       SELF sepc ->         U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc)       i@(CONTRACT nt epName)-        | _ :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s) <- i ->+        | _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i ->             let fa = epNameToRefAnn epName             in U.CONTRACT U.noAnn fa (mkUType nt)       TRANSFER_TOKENS -> U.TRANSFER_TOKENS U.noAnn       SET_DELEGATE -> U.SET_DELEGATE U.noAnn       i@(CREATE_CONTRACT fullContract)         | _ :: Instr-            (  'TOption ('Tc 'CKeyHash)-            ': 'Tc 'CMutez+            (  'TOption ('TKeyHash)+            ': 'TMutez             ': g             ': s)-            ('TOperation ': 'Tc 'CAddress ': s) <- i ->+            ('TOperation ': 'TAddress ': s) <- i ->           U.CREATE_CONTRACT U.noAnn U.noAnn (convertFullContract fullContract)       IMPLICIT_ACCOUNT -> U.IMPLICIT_ACCOUNT U.noAnn       NOW -> U.NOW U.noAnn@@ -466,7 +462,6 @@       SHA512 -> U.SHA512 U.noAnn       BLAKE2B -> U.BLAKE2B U.noAnn       HASH_KEY -> U.HASH_KEY U.noAnn-      STEPS_TO_QUOTA -> U.STEPS_TO_QUOTA U.noAnn       SOURCE -> U.SOURCE U.noAnn       SENDER -> U.SENDER U.noAnn       ADDRESS -> U.ADDRESS U.noAnn@@ -485,6 +480,13 @@     one $ U.UTEST_ASSERT $     U.TestAssert nm (untypePrintComment pc) (instrToOps i)   DOC_ITEM{} -> []+  COMMENT_ITEM tp ->+    case tp of+      FunctionStarts name -> one $ U.UCOMMENT $ "Function starts: " <> name+      FunctionEnds name -> one $ U.UCOMMENT $ "Function ends: " <> name+      StatementStarts name -> one $ U.UCOMMENT $ "Statement starts: " <> name+      StatementEnds name -> one $ U.UCOMMENT $ "Statement ends: " <> name+      JustComment com -> one $ U.UCOMMENT com  -- It's an orphan instance, but it's better than checking all cases manually. -- We can also move this convertion to the place where `Instr` is defined,
src/Michelson/Typed/EntryPoints.hs view
@@ -40,12 +40,11 @@   , EpNameFromRefAnnError (..)   ) where +import Control.Monad.Except (throwError) import Data.Constraint (Dict(..)) import Data.Default (Default(..)) import qualified Data.List.NonEmpty as NE-import Data.Singletons (SingI(..)) import qualified Data.Text as T-import Data.Typeable ((:~:)(..)) import Fmt (Buildable(..), pretty, (+|), (|+)) import Test.QuickCheck (Arbitrary(..)) @@ -141,19 +140,19 @@ -- Following the Michelson specification, this type has the following invariants: -- 1. No entrypoint name is duplicated. -- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.-newtype ParamNotes (t :: T) = ParamNotesUnsafe-  { unParamNotes :: Notes t+data ParamNotes (t :: T) = ParamNotesUnsafe+  { pnNotes   :: Notes t+  , pnRootAnn :: RootAnn   } deriving stock (Show, Eq, Generic)--instance NFData (ParamNotes t)+    deriving anyclass (NFData) -pattern ParamNotes :: Notes t -> ParamNotes t-pattern ParamNotes t <- ParamNotesUnsafe t+pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t+pattern ParamNotes t f <- ParamNotesUnsafe t f {-# COMPLETE ParamNotes #-}  -- | Parameter without annotations. starParamNotes :: SingI t => ParamNotes t-starParamNotes = ParamNotesUnsafe starNotes+starParamNotes = ParamNotesUnsafe starNotes noAnn  -- | Coordinates of "arm" in Or tree, used solely in error messages. type ArmCoords = [ArmCoord]@@ -192,15 +191,23 @@     surround pre post builder = pre <> builder <> post  -- | Check whether given notes are valid parameter notes.-verifyParamNotes :: Notes t -> Either ParamEpError ()-verifyParamNotes notes = do+verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()+verifyParamNotes notes ra = do   let allEps = appEndo (gatherEntrypoints notes) []-      duplicatedEps = mapMaybe (safeHead . tail) . NE.group $ sort allEps+      duplicatedEps+        = mapMaybe (safeHead . tail)+        . NE.group+        . sort+        $ maybe allEps (: allEps) (epNameFromParamAnn $ convAnn ra)+   whenJust (nonEmpty duplicatedEps) $ \dups ->-    Left $ ParamEpDuplicatedNames dups+    throwError $ ParamEpDuplicatedNames dups -  void $ ensureAllCallable notes-    & first ParamEpUncallableArm+  -- In case contract have explicit root entrypoint, we assume that everything is+  -- callable.+  when (ra == noAnn) $ void+    $ first ParamEpUncallableArm+    $ ensureAllCallable notes   where     gatherEntrypoints :: Notes t -> Endo [EpName]     gatherEntrypoints = \case@@ -224,16 +231,14 @@       NTOr _ fnL fnR l r -> do         let epNameL = epNameFromParamAnn fnL         let epNameR = epNameFromParamAnn fnR--        haveDefLL <- first (AcLeft :) $ ensureAllCallable l+        haveDefLL <- first (AcLeft  :) $ ensureAllCallable l         haveDefRR <- first (AcRight :) $ ensureAllCallable r+         let haveDefL = or [haveDefLL, epNameL == Just (def @EpName)]         let haveDefR = or [haveDefRR, epNameR == Just (def @EpName)] -        when haveDefL $-          first (AcRight :) $ checkAllEpsNamed epNameR r-        when haveDefR $-          first (AcLeft :) $ checkAllEpsNamed epNameL l+        when haveDefL $ first (AcRight :) $ checkAllEpsNamed epNameR r+        when haveDefR $ first (AcLeft  :) $ checkAllEpsNamed epNameL l          return $ or [haveDefL, haveDefR] @@ -246,13 +251,15 @@           NTOr _ fnL fnR l r -> do             let epNameL = epNameFromParamAnn fnL                 epNameR = epNameFromParamAnn fnR-            first (AcLeft :) $ checkAllEpsNamed epNameL l++            first (AcLeft  :) $ checkAllEpsNamed epNameL l             first (AcRight :) $ checkAllEpsNamed epNameR r-          _ -> Left [] +          _ -> throwError []+ -- | Construct 'ParamNotes' performing all necessary checks.-mkParamNotes :: Notes t -> Either ParamEpError (ParamNotes t)-mkParamNotes nt = verifyParamNotes nt $> ParamNotesUnsafe nt+mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)+mkParamNotes nt fa = verifyParamNotes nt fa $> ParamNotesUnsafe nt fa  ---------------------------------------------------------------------------- -- Entrypoint logic@@ -409,9 +416,19 @@   => EpName   -> ParamNotes param   -> Maybe (MkEntryPointCallRes param)-mkEntryPointCall epName (ParamNotes paramNotes) =+mkEntryPointCall epName (ParamNotes paramNotes root) =   asum-  [ withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) ->+  [ do+      epName' <- epNameFromParamAnn $ convAnn root+      guard (epName == epName')+      return $ MkEntryPointCallRes+        paramNotes+        EntryPointCall+          { epcName = epName+          , epcParamProxy = Proxy+          , epcLiftSequence = EplArgHere+          }+  , withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) ->       MkEntryPointCallRes argInfo $ EntryPointCall         { epcName = epName         , epcParamProxy = Proxy@@ -427,7 +444,7 @@  -- | "Parameter" type of implicit account. tyImplicitAccountParam :: ParamNotes 'TUnit-tyImplicitAccountParam = ParamNotesUnsafe starNotes+tyImplicitAccountParam = ParamNotesUnsafe starNotes noAnn  -- Misc ----------------------------------------------------------------------------@@ -436,11 +453,12 @@ -- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how -- duplicate entrypoints are handled. flattenEntryPoints :: SingI t => ParamNotes t -> Map EpName U.Type-flattenEntryPoints (unParamNotes -> notes) = mkEntrypointsMap (mkUType notes)+flattenEntryPoints (pnNotes -> notes) = mkEntrypointsMap (mkUType notes) --- TODO [#35]: We also need to be able to handle field annotation in root--- of parameter's @or@ tree.--- Currently we don't even support field annotation at such position.+-- TODO [#35]: Root annotation is currently support as a dedicated field+-- in 'ParamNotes'. -- -- Also it would be nice to automatically add @%root@ annotation in each parameter -- declaration when compiling Lorentz to Michelson.+-- In addition to this, we should actually use @%root@ annotation in the entrypoint engine+-- and not just store it.
src/Michelson/Typed/Extract.hs view
@@ -15,10 +15,10 @@   , pattern AsUTypeExt   ) where -import Data.Singletons (SingI)+import Data.Singletons (Sing, SingI)  import Michelson.Typed.Annotation (Notes(..), notesSing)-import Michelson.Typed.Sing (Sing(..), fromSingCT, fromSingT, withSomeSingCT)+import Michelson.Typed.Sing (SingT(..), fromSingT) import Michelson.Typed.T (T(..), toUType) import qualified Michelson.Untyped as Un @@ -29,15 +29,23 @@  mkUType :: SingI x => Notes x -> Un.Type mkUType notes = case (notesSing notes, notes) of-  (STc ct, NTc tn)              -> Un.Type (Un.Tc (fromSingCT ct)) tn-  (STKey, NTKey tn)             -> Un.Type Un.TKey tn-  (STUnit, NTUnit tn)           -> Un.Type Un.TUnit tn-  (STSignature, NTSignature tn) -> Un.Type Un.TSignature tn-  (STChainId, NTChainId tn)     -> Un.Type Un.TChainId tn-  (STOption _, NTOption tn n)   -> Un.Type (Un.TOption (mkUType n)) tn-  (STList _, NTList tn n)       -> Un.Type (Un.TList (mkUType n)) tn-  (STSet ct, NTSet tn n)        -> Un.Type (Un.TSet $ mkComp ct n) tn-  (STOperation, NTOperation tn) -> Un.Type Un.TOperation tn+  (STInt, NTInt tn)               -> Un.Type Un.TInt tn+  (STNat, NTNat tn)               -> Un.Type Un.TNat tn+  (STString, NTString tn)         -> Un.Type Un.TString tn+  (STBytes, NTBytes tn)           -> Un.Type Un.TBytes tn+  (STMutez, NTMutez tn)           -> Un.Type Un.TMutez tn+  (STBool, NTBool tn)             -> Un.Type Un.TBool tn+  (STKeyHash, NTKeyHash tn)       -> Un.Type Un.TKeyHash 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+  (STUnit, NTUnit tn)             -> Un.Type Un.TUnit tn+  (STSignature, NTSignature tn)   -> Un.Type Un.TSignature tn+  (STChainId, NTChainId tn)       -> Un.Type Un.TChainId tn+  (STOption _, NTOption tn n)     -> Un.Type (Un.TOption (mkUType n)) tn+  (STList _, NTList tn n)         -> Un.Type (Un.TList (mkUType n)) tn+  (STSet ct, NTSet tn n)          -> Un.Type (Un.TSet $ mkComp ct n) tn+  (STOperation, NTOperation tn)   -> Un.Type Un.TOperation tn   (STContract _, NTContract tn n) ->     Un.Type (Un.TContract (mkUType n)) tn   (STPair _ _, NTPair tn fl fr nl nr) ->@@ -51,7 +59,7 @@   (STBigMap k _, NTBigMap tn nk nv) ->     Un.Type (Un.TBigMap (mkComp k nk) (mkUType nv)) tn  where-  mkComp t a = Un.Comparable (fromSingCT t) a+  mkComp t a = Un.Type (Un.unwrapT $ toUType $ fromSingT t) a  -- | Convert 'Un.Type' to the isomorphic set of information from typed world. withUType@@ -60,9 +68,33 @@   -> r withUType (Un.Type ut tn) cont = case ut of -  Un.Tc tc -> withSomeSingCT tc $-    \(_ :: Sing tc) -> cont @('Tc tc) (NTc tn)+  Un.TInt ->+    cont (NTInt tn) +  Un.TNat ->+    cont (NTNat tn)++  Un.TString ->+    cont (NTString tn)++  Un.TBytes ->+    cont (NTBytes tn)++  Un.TMutez ->+    cont (NTMutez tn)++  Un.TBool ->+    cont (NTBool tn)++  Un.TKeyHash ->+    cont (NTKeyHash tn)++  Un.TTimestamp ->+    cont (NTTimestamp tn)++  Un.TAddress ->+    cont (NTAddress tn)+   Un.TKey ->     cont (NTKey tn) @@ -83,8 +115,8 @@     \(notesListT :: Notes listT) ->       cont (NTList tn notesListT) -  Un.TSet (Un.Comparable sCT nsCT) -> withSomeSingCT sCT $-    \(_ :: Sing sCT) -> cont @('TSet sCT) (NTSet tn nsCT)+  Un.TSet (Un.Type sT nsCT) -> withUType (Un.Type sT Un.noAnn) $+    \(_ :: Notes sCT) -> cont @('TSet sCT) (NTSet tn nsCT)    Un.TOperation ->     cont (NTOperation tn)@@ -108,13 +140,13 @@       withUType rt $ \rn ->         cont (NTLambda tn ln rn) -  Un.TMap (Un.Comparable keyT notesT) valT ->-    withSomeSingCT keyT $ \(_ :: Sing keyT) ->+  Un.TMap (Un.Type keyT notesT) valT ->+    withUType (Un.Type keyT Un.noAnn) $ \(_ :: Notes keyT) ->       withUType valT $ \valN ->         cont @('TMap keyT _) (NTMap tn notesT valN) -  Un.TBigMap (Un.Comparable keyT notesT) valT ->-    withSomeSingCT keyT $ \(_ :: Sing keyT) ->+  Un.TBigMap (Un.Type keyT notesT) valT ->+    withUType (Un.Type keyT Un.noAnn) $ \(_ :: Notes keyT) ->       withUType valT $ \valN ->         cont @('TBigMap keyT _) (NTBigMap tn notesT valN)
src/Michelson/Typed/Haskell/Doc.hs view
@@ -355,7 +355,7 @@   => Proxy t -> WithinParens -> Markdown homomorphicTypeDocMdReference tp _ =   customTypeDocMdReference-    (toText $ showtype tp, DType tp)+    (typeDocName tp, DType tp)     []     (WithinParens False) @@ -607,7 +607,7 @@   typeDocHaskellRep _ = Nothing  instance TypeHasDoc Address where-  typeDocName _ = "Address simplified"+  typeDocName _ = "Address (no entrypoint)"   typeDocMdDescription =     "This is similar to Michelson Address, but does not retain entrypoint name \     \if it refers to a contract."
src/Michelson/Typed/Haskell/Instr/Product.hs view
@@ -15,19 +15,16 @@   ) where  import qualified Data.Kind as Kind-import Data.Type.Bool (If)-import Data.Type.Equality (type (==)) import Data.Vinyl.Core (Rec(..))-import Data.Vinyl.TypeLevel (type (++)) import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) import Named ((:!), (:?), NamedF(..)) +import Michelson.Text import Michelson.Typed.Haskell.Instr.Helpers import Michelson.Typed.Haskell.Value import Michelson.Typed.Instr-import Michelson.Text import Util.Label (Label) import Util.Named (NamedInner) import Util.Type
src/Michelson/Typed/Haskell/Instr/Sum.hs view
@@ -34,13 +34,10 @@   , IsPrimitiveValue   ) where -import Data.Constraint (Dict(..)) import qualified Data.Kind as Kind import Data.Singletons (SingI(..))-import Data.Type.Bool (If, type (||))-import Data.Type.Equality (type (==))+import Data.Type.Bool (type (||)) import Data.Vinyl.Core (Rec(..))-import Data.Vinyl.TypeLevel (type (++)) import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G import GHC.TypeLits (AppendSymbol, ErrorMessage(..), Symbol, TypeError)@@ -48,12 +45,12 @@ import Type.Reflection ((:~:)(Refl)) import Unsafe.Coerce (unsafeCoerce) +import Michelson.Text (MText, mt)+import Michelson.Typed.EntryPoints import Michelson.Typed.Haskell.Instr.Helpers import Michelson.Typed.Haskell.Value import Michelson.Typed.Instr import Michelson.Typed.T-import Michelson.Typed.EntryPoints-import Michelson.Text (MText, mt) import Michelson.Typed.Value import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp)
src/Michelson/Typed/Haskell/LooseSum.hs view
@@ -17,7 +17,7 @@  import qualified Data.Kind as Kind import Data.Singletons (SingI)-import Data.Typeable (TypeRep, Typeable, cast, typeRep)+import Data.Typeable (TypeRep, cast, typeRep) import GHC.Generics ((:*:), (:+:)) import qualified GHC.Generics as G
src/Michelson/Typed/Haskell/Value.hs view
@@ -1,15 +1,19 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | Conversions between haskell types/values and Michelson ones. module Michelson.Typed.Haskell.Value   ( -- * Value conversions-    IsoCValue (..)-  , IsoValue (..)+    IsoValue (..)   , GIsoValue (GValueType)   , ToT'   , SomeIsoValue (..)   , AnyIsoValue (..)-  , IsComparable   , GenericIsoValue+  , WellTyped+  , WellTypedIsoValue+  , WellTypedToT +  , Dict(..) -- * Re-exporting to use in tests.+     -- * Missing Haskell analogies to Michelson values   , EntryPointCall   , SomeEntryPointCall@@ -40,7 +44,6 @@  import Michelson.Text import Michelson.Typed.Aliases-import Michelson.Typed.CValue import Michelson.Typed.EntryPoints import Michelson.Typed.T import Michelson.Typed.Value@@ -50,82 +53,6 @@ import Util.Type  ------------------------------------------------------------------------------- Comparable values isomorphism--------------------------------------------------------------------------------- | Isomorphism between Michelson primitive values and plain Haskell types.-class IsoCValue a where-  -- | Type function that converts a regular Haskell type into a comparable type-  -- (which has kind @CT@).-  type ToCT a :: CT--  -- | Converts a single Haskell value into @CVal@ representation.-  toCVal :: a -> CValue (ToCT a)--  -- | Converts a @CVal@ value into a single Haskell value.-  fromCVal :: CValue (ToCT a) -> a--instance IsoCValue Integer where-  type ToCT Integer = 'CInt-  toCVal = CvInt-  fromCVal (CvInt i) = i--instance IsoCValue Natural where-  type ToCT Natural = 'CNat-  toCVal = CvNat-  fromCVal (CvNat i) = i--instance IsoCValue MText where-  type ToCT MText = 'CString-  toCVal = CvString-  fromCVal (CvString s) = s--instance DoNotUseTextError => IsoCValue Text where-  type ToCT Text = DoNotUseTextError-  toCVal = error "impossible"-  fromCVal _ = error "impossible"--instance IsoCValue Bool where-  type ToCT Bool = 'CBool-  toCVal = CvBool-  fromCVal (CvBool b) = b--instance IsoCValue ByteString where-  type ToCT ByteString = 'CBytes-  toCVal = CvBytes-  fromCVal (CvBytes b) = b--instance IsoCValue Mutez where-  type ToCT Mutez = 'CMutez-  toCVal = CvMutez-  fromCVal (CvMutez m) = m---- | This instance erases reference to contract entrypoint!--- If this is an issue, use `EpAddress` instead.------ Applications which use addresses just as participants identifiers--- should not experience problems with using plain 'Address'.-instance IsoCValue Address where-  type ToCT Address = 'CAddress-  toCVal addr = CvAddress $ EpAddress addr def-  fromCVal (CvAddress a) = eaAddress a--instance IsoCValue EpAddress where-  type ToCT EpAddress = 'CAddress-  toCVal = CvAddress-  fromCVal (CvAddress a) = a--instance IsoCValue KeyHash where-  type ToCT KeyHash = 'CKeyHash-  toCVal = CvKeyHash-  fromCVal (CvKeyHash k) = k--instance IsoCValue Timestamp where-  type ToCT Timestamp = 'CTimestamp-  toCVal = CvTimestamp-  fromCVal (CvTimestamp t) = t------------------------------------------------------------------------------ -- Complex values isomorphism ---------------------------------------------------------------------------- @@ -133,7 +60,7 @@ -- -- Default implementation of this typeclass converts ADTs to Michelson -- "pair"s and "or"s.-class IsoValue a where+class (WellTypedToT a) => IsoValue a where   -- | Type function that converts a regular Haskell type into a @T@ type.   type ToT a :: T   type ToT a = GValueType (G.Rep a)@@ -164,66 +91,63 @@ -- | Any Haskell value which can be converted to Michelson 'Value'. newtype AnyIsoValue = AnyIsoValue (forall a. IsoValue a => a) --- | A useful property which holds for all 'CT' types.-type IsComparable c = ToT c ~ 'Tc (ToCT c)- -- Instances ----------------------------------------------------------------------------  instance IsoValue Integer where-  type ToT Integer = 'Tc (ToCT Integer)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT Integer = 'TInt+  toVal = VInt+  fromVal (VInt x) = x  instance IsoValue Natural where-  type ToT Natural = 'Tc (ToCT Natural)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT Natural = 'TNat+  toVal = VNat+  fromVal (VNat x) = x  instance IsoValue MText where-  type ToT MText = 'Tc (ToCT MText)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT MText = 'TString+  toVal = VString+  fromVal (VString x) = x  instance DoNotUseTextError => IsoValue Text where-  type ToT Text = DoNotUseTextError+  type ToT Text = ToT ()   toVal = error "impossible"   fromVal = error "impossible"  instance IsoValue Bool where-  type ToT Bool = 'Tc (ToCT Bool)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT Bool = 'TBool+  toVal = VBool+  fromVal (VBool x) = x  instance IsoValue ByteString where-  type ToT ByteString = 'Tc (ToCT ByteString)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT ByteString = 'TBytes+  toVal = VBytes+  fromVal (VBytes x) = x  instance IsoValue Mutez where-  type ToT Mutez = 'Tc (ToCT Mutez)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT Mutez = 'TMutez+  toVal = VMutez+  fromVal (VMutez x) = x  instance IsoValue KeyHash where-  type ToT KeyHash = 'Tc (ToCT KeyHash)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT KeyHash = 'TKeyHash+  toVal = VKeyHash+  fromVal (VKeyHash x) = x  instance IsoValue Timestamp where-  type ToT Timestamp = 'Tc (ToCT Timestamp)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT Timestamp = 'TTimestamp+  toVal = VTimestamp+  fromVal (VTimestamp x) = x  instance IsoValue Address where-  type ToT Address = 'Tc (ToCT Address)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT Address = 'TAddress+  toVal addr = VAddress $ EpAddress addr def+  fromVal (VAddress x) = eaAddress x  instance IsoValue EpAddress where-  type ToT EpAddress = 'Tc (ToCT EpAddress)-  toVal = VC . toCVal-  fromVal (VC x) = fromCVal x+  type ToT EpAddress = 'TAddress+  toVal = VAddress+  fromVal (VAddress x) = x  instance IsoValue PublicKey where   type ToT PublicKey = 'TKey@@ -256,22 +180,21 @@  instance (IsoValue a, IsoValue b) => IsoValue (a, b) -instance (Ord c, IsoCValue c) => IsoValue (Set c) where-  type ToT (Set c) = 'TSet (ToCT c)-  toVal = VSet . Set.map toCVal-  fromVal (VSet x) = Set.map fromCVal x+instance (Comparable (ToT c), Ord c, IsoValue c) => IsoValue (Set c) where+  type ToT (Set c) = 'TSet (ToT c)+  toVal = VSet . Set.map toVal+  fromVal (VSet x) = Set.map fromVal x -instance (Ord k, IsoCValue k, IsoValue v) => IsoValue (Map k v) where-  type ToT (Map k v) = 'TMap (ToCT k) (ToT v)-  toVal = VMap . Map.mapKeys toCVal . Map.map toVal-  fromVal (VMap x) = Map.map fromVal $ Map.mapKeys fromCVal x+instance (Comparable (ToT k), Ord k, IsoValue k, IsoValue v) => IsoValue (Map k v) where+  type ToT (Map k v) = 'TMap (ToT k) (ToT v)+  toVal = VMap . Map.mapKeys toVal . Map.map toVal+  fromVal (VMap x) = Map.map fromVal $ Map.mapKeys fromVal x  instance IsoValue Operation where   type ToT Operation = 'TOperation   toVal = VOp   fromVal (VOp x) = x - deriving newtype instance IsoValue a => IsoValue (Identity a) deriving newtype instance IsoValue a => IsoValue (NamedF Identity a name) deriving newtype instance IsoValue a => IsoValue (NamedF Maybe a name)@@ -295,6 +218,9 @@  type SomeEntryPointCall arg = SomeEntryPointCallT (ToT arg) +type WellTypedToT a = WellTyped (ToT a)+type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)+ -- | Since @Contract@ name is used to designate contract code, lets call -- analogy of 'TContract' type as follows. --@@ -307,10 +233,10 @@   , crEntryPoint :: SomeEntryPointCall arg   } deriving stock (Eq, Show) -instance Buildable (ContractRef arg) where+instance (WellTypedToT arg) => Buildable (ContractRef arg) where   build = buildVContract . toVal -instance IsoValue (ContractRef arg) where+instance (WellTypedToT arg) => IsoValue (ContractRef arg) where   type ToT (ContractRef arg) = 'TContract (ToT arg)   toVal ContractRef{..} = VContract crAddress crEntryPoint   fromVal (VContract addr epc) = ContractRef addr epc@@ -326,12 +252,18 @@   deriving stock (Eq, Show)   deriving newtype (Default, Semigroup, Monoid) -instance (Ord k, IsoCValue k, IsoValue v) => IsoValue (BigMap k v) where-  type ToT (BigMap k v) = 'TBigMap (ToCT k) (ToT v)-  toVal = VBigMap . Map.mapKeys toCVal . Map.map toVal . unBigMap-  fromVal (VBigMap x) = BigMap $ Map.map fromVal $ Map.mapKeys fromCVal x+instance+  ( WellTypedToT k, WellTypedToT v, Comparable (ToT k)+  , Ord k, IsoValue k, IsoValue v+  ) => IsoValue (BigMap k v) where+  type ToT (BigMap k v) = 'TBigMap (ToT k) (ToT v)+  toVal = VBigMap . Map.mapKeys toVal . Map.map toVal . unBigMap+  fromVal (VBigMap x) = BigMap $ Map.map fromVal $ Map.mapKeys fromVal x -instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (BigMap k v) where+instance+  ( WellTypedToT k, WellTypedToT v, Comparable (ToT k), Arbitrary k+  , Arbitrary v, Ord k+  ) => Arbitrary (BigMap k v) where   arbitrary = BigMap <$> arbitrary  -- Generic magic@@ -424,3 +356,36 @@   KNil -> Dict   KCons _ (_ :: Proxy a') ->     case totsAppendLemma @a' @b of Dict -> Dict++-- | This class encodes Michelson rules w.r.t where it requires comparable+-- types. Earlier we had a dedicated type for representing comparable types @CT@.+-- But then we integreated those types into @T@. This meant that some of the+-- types that could be formed with various combinations of @T@ would be+-- illegal as per Michelson typing rule. Using this class, we inductively+-- enforce that a type and all types it contains are well typed as per+-- Michelson's rules.+class WellTyped (t :: T) where++instance WellTyped 'TKey where+instance WellTyped 'TUnit where+instance WellTyped 'TSignature where+instance WellTyped 'TChainId where+instance (WellTyped t) => WellTyped ('TOption t) where+instance (WellTyped t) => WellTyped ('TList t) where+instance (Comparable t, WellTyped t) => WellTyped ('TSet t) where+instance WellTyped 'TOperation where+instance (WellTyped t) => WellTyped ('TContract t) where+instance (WellTyped t1, WellTyped t2) => WellTyped ('TPair t1 t2)+instance (WellTyped t1, WellTyped t2) => WellTyped ('TOr t1 t2)+instance (WellTyped t1, WellTyped t2) => WellTyped ('TLambda t1 t2)+instance (Comparable k, WellTyped k, WellTyped v) => WellTyped ('TMap k v)+instance (Comparable k, WellTyped k, WellTyped v) => WellTyped ('TBigMap k v)+instance WellTyped 'TInt+instance WellTyped 'TNat+instance WellTyped 'TString+instance WellTyped 'TBytes+instance WellTyped 'TMutez+instance WellTyped 'TBool+instance WellTyped 'TKeyHash+instance WellTyped 'TTimestamp+instance WellTyped 'TAddress
src/Michelson/Typed/Instr.hs view
@@ -5,13 +5,13 @@ module Michelson.Typed.Instr   ( Instr (..)   , ExtInstr (..)+  , CommentType (..)   , StackRef (..)   , mkStackRef   , PrintComment (..)   , TestAssert (..)   , ContractCode   , FullContract (..)-  , fcParamNotes   , mapFullContractCode   , pattern CAR   , pattern CDR@@ -25,7 +25,7 @@   , ConstraintDUG'   ) where -import Data.Singletons (SingI(..))+import Data.Singletons (Sing) import Fmt (Buildable(..), (+||), (||+)) import qualified GHC.TypeNats as GHC (Nat) import qualified Text.Show@@ -37,8 +37,8 @@ import Michelson.Typed.EntryPoints import Michelson.Typed.Polymorphic import Michelson.Typed.Scope-import Michelson.Typed.T (CT(..), T(..))-import Michelson.Typed.Value (ContractInp, ContractOut, Value'(..))+import Michelson.Typed.T (T(..))+import Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..)) import Michelson.Untyped (Annotation(..), FieldAnn, VarAnn) import Util.Peano import Util.TH@@ -204,26 +204,26 @@     :: Instr (a ': 'TList a ': s) s'     -> Instr s s'     -> Instr ('TList a ': s) s'-  SIZE :: SizeOp c => Instr (c ': s) ('Tc 'CNat ': s)-  EMPTY_SET :: (Typeable e, SingI e) => Instr s ('TSet e ': s)-  EMPTY_MAP :: (Typeable a, Typeable b, SingI a, SingI b) => Instr s ('TMap a b ': s)-  EMPTY_BIG_MAP :: (Typeable a, Typeable b, SingI a, SingI b) => Instr s ('TBigMap a b ': s)+  SIZE :: SizeOp c => Instr (c ': s) ('TNat ': s)+  EMPTY_SET :: (Typeable e, SingI e, Comparable e) => Instr s ('TSet e ': s)+  EMPTY_MAP :: (Typeable a, Typeable b, Comparable a, SingI a, SingI b) => Instr s ('TMap a b ': s)+  EMPTY_BIG_MAP :: (Typeable a, Typeable b, Comparable a, SingI a, SingI b) => Instr s ('TBigMap a b ': s)   MAP :: MapOp c       => Instr (MapOpInp c ': s) (b ': s)       -> Instr (c ': s) (MapOpRes c b ': s)   ITER :: IterOp c => Instr (IterOpEl c ': s) s -> Instr (c ': s) s-  MEM :: MemOp c => Instr ('Tc (MemOpKey c) ': c ': s) ('Tc 'CBool ': s)+  MEM :: MemOp c => Instr (MemOpKey c ': c ': s) ('TBool ': s)   GET     :: GetOp c-    => Instr ('Tc (GetOpKey c) ': c ': s) ('TOption (GetOpVal c) ': s)+    => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s)   UPDATE     :: UpdOp c-    => Instr ('Tc (UpdOpKey c) ': UpdOpParams c ': c ': s) (c ': s)+    => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s)   IF :: Instr s s'      -> Instr s s'-     -> Instr ('Tc 'CBool ': s) s'-  LOOP :: Instr s ('Tc 'CBool ': s)-       -> Instr ('Tc 'CBool ': s) s+     -> Instr ('TBool ': s) s'+  LOOP :: Instr s ('TBool ': s)+       -> Instr ('TBool ': s) s   LOOP_LEFT     :: Instr (a ': s) ('TOr a b ': s)     -> Instr ('TOr a b ': s) (b ': s)@@ -240,74 +240,74 @@   FAILWITH :: (Typeable a, SingI a) => Instr (a ': s) t   CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)   RENAME :: Instr (a ': s) (a ': s)-  PACK :: PackedValScope a => Instr (a ': s) ('Tc 'CBytes ': s)-  UNPACK :: UnpackedValScope a => Instr ('Tc 'CBytes ': s) ('TOption a ': s)+  PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s)+  UNPACK :: UnpackedValScope a => Instr ('TBytes ': s) ('TOption a ': s)   CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s)   CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s)   SLICE     :: SliceOp c-    => Instr ('Tc 'CNat ': 'Tc 'CNat ': c ': s) ('TOption c ': s)-  ISNAT :: Instr ('Tc 'CInt ': s) ('TOption ('Tc 'CNat) ': s)+    => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s)+  ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s)   ADD     :: (ArithOp Add n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Add n m) ': s)+    => Instr (n ': m ': s) (ArithRes Add n m ': s)   SUB     :: (ArithOp Sub n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Sub n m) ': s)+    => Instr (n ': m ': s) (ArithRes Sub n m ': s)   MUL     :: (ArithOp Mul n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Mul n m) ': s)+    => Instr (n ':  m ': s) (ArithRes Mul n m ': s)   EDIV     :: EDivOp n m-    => Instr ('Tc n ': 'Tc m ': s)-                 (('TOption ('TPair ('Tc (EDivOpRes n m))-                                      ('Tc (EModOpRes n m)))) ': s)+    => Instr (n ':  m ': s)+                 (('TOption ('TPair (EDivOpRes n m)+                                      (EModOpRes n m))) ': s)   ABS     :: UnaryArithOp Abs n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Abs n) ': s)+    => Instr (n ': s) (UnaryArithRes Abs n ': s)   NEG     :: UnaryArithOp Neg n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Neg n) ': s)+    => Instr (n ': s) (UnaryArithRes Neg n ': s)   LSL     :: (ArithOp Lsl n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Lsl n m) ': s)+    => Instr (n ': m ': s) (ArithRes Lsl n m ': s)   LSR     :: (ArithOp Lsr n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Lsr n m) ': s)+    => Instr (n ':  m ': s) (ArithRes Lsr n m ': s)   OR     :: (ArithOp Or n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Or n m) ': s)+    => Instr (n ': m ': s) (ArithRes Or n m ': s)   AND     :: (ArithOp And n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes And n m) ': s)+    => Instr (n ': m ': s) (ArithRes And n m ': s)   XOR     :: (ArithOp Xor n m, Typeable n, Typeable m)-    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Xor n m) ': s)+    => Instr (n ': m ': s) (ArithRes Xor n m ': s)   NOT     :: UnaryArithOp Not n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Not n) ': s)+    => Instr (n ': s) (UnaryArithRes Not n ': s)   COMPARE     :: (Comparable n, Typeable n, SingI n)-    => Instr (n ': n ': s) ('Tc 'CInt ': s)+    => Instr (n ': n ': s) ('TInt ': s)   EQ     :: UnaryArithOp Eq' n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Eq' n) ': s)+    => Instr (n ': s) (UnaryArithRes Eq' n ': s)   NEQ     :: UnaryArithOp Neq n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Neq n) ': s)+    => Instr (n ': s) (UnaryArithRes Neq n ': s)   LT     :: UnaryArithOp Lt n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Lt n) ': s)+    => Instr (n ': s) (UnaryArithRes Lt n ': s)   GT     :: UnaryArithOp Gt n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Gt n) ': s)+    => Instr (n ': s) (UnaryArithRes Gt n ': s)   LE     :: UnaryArithOp Le n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Le n) ': s)+    => Instr (n ': s) (UnaryArithRes Le n ': s)   GE     :: UnaryArithOp Ge n-    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Ge n) ': s)-  INT :: Instr ('Tc 'CNat ': s) ('Tc 'CInt ': s)+    => Instr (n ': s) (UnaryArithRes Ge n ': s)+  INT :: Instr ('TNat ': s) ('TInt ': s)   SELF     :: forall (arg :: T) s .        (ParameterScope arg)@@ -317,37 +317,36 @@     :: (ParameterScope p)     => Notes p   -- Store Notes to be able to verify CONTRACT in typechecker     -> EpName-    -> Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)+    -> Instr ('TAddress ': s) ('TOption ('TContract p) ': s)   TRANSFER_TOKENS     :: (ParameterScope p) =>-       Instr (p ': 'Tc 'CMutez ': 'TContract p ': s)+       Instr (p ': 'TMutez ': 'TContract p ': s)                    ('TOperation ': s)   SET_DELEGATE-    :: Instr ('TOption ('Tc 'CKeyHash) ': s) ('TOperation ': s)+    :: Instr ('TOption 'TKeyHash ': s) ('TOperation ': s)    CREATE_CONTRACT     :: (ParameterScope p, StorageScope g)     => FullContract p g-    -> Instr ('TOption ('Tc 'CKeyHash) ':-              'Tc 'CMutez ':+    -> Instr ('TOption 'TKeyHash ':+              'TMutez ':                g ': s)-             ('TOperation ': 'Tc 'CAddress ': s)+             ('TOperation ': 'TAddress ': s)   IMPLICIT_ACCOUNT-    :: Instr ('Tc 'CKeyHash ': s) ('TContract 'TUnit ': s)-  NOW :: Instr s ('Tc 'CTimestamp ': s)-  AMOUNT :: Instr s ('Tc 'CMutez ': s)-  BALANCE :: Instr s ('Tc 'CMutez ': s)+    :: Instr ('TKeyHash ': s) ('TContract 'TUnit ': s)+  NOW :: Instr s ('TTimestamp ': s)+  AMOUNT :: Instr s ('TMutez ': s)+  BALANCE :: Instr s ('TMutez ': s)   CHECK_SIGNATURE-    :: Instr ('TKey ': 'TSignature ': 'Tc 'CBytes ': s)-                   ('Tc 'CBool ': s)-  SHA256 :: Instr ('Tc 'CBytes ': s) ('Tc 'CBytes ': s)-  SHA512 :: Instr ('Tc 'CBytes ': s) ('Tc 'CBytes ': s)-  BLAKE2B :: Instr ('Tc 'CBytes ': s) ('Tc 'CBytes ': s)-  HASH_KEY :: Instr ('TKey ': s) ('Tc 'CKeyHash ': s)-  STEPS_TO_QUOTA :: Instr s ('Tc 'CNat ': s)-  SOURCE :: Instr s ('Tc 'CAddress ': s)-  SENDER :: Instr s ('Tc 'CAddress ': s)-  ADDRESS :: Instr ('TContract a ': s) ('Tc 'CAddress ': s)+    :: Instr ('TKey ': 'TSignature ': 'TBytes ': s)+                   ('TBool ': s)+  SHA256 :: Instr ('TBytes ': s) ('TBytes ': s)+  SHA512 :: Instr ('TBytes ': s) ('TBytes ': s)+  BLAKE2B :: Instr ('TBytes ': s) ('TBytes ': s)+  HASH_KEY :: Instr ('TKey ': s) ('TKeyHash ': s)+  SOURCE :: Instr s ('TAddress ': s)+  SENDER :: Instr s ('TAddress ': s)+  ADDRESS :: Instr ('TContract a ': s) ('TAddress ': s)   CHAIN_ID :: Instr s ('TChainId ': s)  deriving stock instance Show (Instr inp out)@@ -379,7 +378,7 @@     :: (Typeable out)     => Text     -> PrintComment inp-    -> Instr inp ('Tc 'CBool ': out)+    -> Instr inp ('TBool ': out)     -> TestAssert inp  deriving stock instance Show (TestAssert s)@@ -420,10 +419,21 @@ instance IsString (PrintComment st) where   fromString = PrintComment . one . Left . fromString +data CommentType+ = FunctionStarts Text+ | FunctionEnds Text+ | StatementStarts Text+ | StatementEnds Text+ | JustComment Text+ deriving stock (Show, Generic)++instance NFData CommentType+ data ExtInstr s   = TEST_ASSERT (TestAssert s)   | PRINT (PrintComment s)   | DOC_ITEM SomeDocItem+  | COMMENT_ITEM CommentType   deriving stock (Show, Generic)  instance NFData (ExtInstr s)@@ -437,7 +447,7 @@ -- TODO [#12]: rename this to 'Contract' data FullContract cp st = (ParameterScope cp, StorageScope st) => FullContract   { fcCode :: ContractCode cp st-  , fcParamNotesSafe :: ParamNotes cp+  , fcParamNotes :: ParamNotes cp   , fcStoreNotes :: Notes st   } @@ -445,9 +455,6 @@ deriving stock instance Eq (ContractCode cp st) => Eq (FullContract cp st) instance NFData (FullContract cp st) where   rnf (FullContract a b c) = rnf (a, b, c)--fcParamNotes :: FullContract cp st -> Notes cp-fcParamNotes = unParamNotes . fcParamNotesSafe  mapFullContractCode   :: (ContractCode cp st -> ContractCode cp st)
src/Michelson/Typed/Polymorphic.hs view
@@ -18,15 +18,14 @@ import qualified Data.Set as S  import Michelson.Text-import Michelson.Typed.CValue (CValue(..))-import Michelson.Typed.T (CT(..), T(..))+import Michelson.Typed.T (T(..)) import Michelson.Typed.Value (Value'(..))  import Tezos.Core (divModMutez, divModMutezInt)  class MemOp (c :: T) where-  type MemOpKey c :: CT-  evalMem :: CValue (MemOpKey c) -> Value' cp c -> Bool+  type MemOpKey c :: T+  evalMem :: Value' instr (MemOpKey c) -> Value' instr c -> Bool instance MemOp ('TSet e) where   type MemOpKey ('TSet e) = e   evalMem e (VSet s) = e `S.member` s@@ -43,9 +42,9 @@   mapOpToList :: Value' instr c -> [Value' instr (MapOpInp c)]   mapOpFromList :: Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b) instance MapOp ('TMap k v) where-  type MapOpInp ('TMap k v) = 'TPair ('Tc k) v+  type MapOpInp ('TMap k v) = 'TPair k v   type MapOpRes ('TMap k v) = 'TMap k-  mapOpToList (VMap m) = map (\(k, v) -> VPair (VC k, v)) $ M.toAscList m+  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 instance MapOp ('TList e) where@@ -62,9 +61,9 @@   iterOpDetachOne ::     Value' instr c -> (Maybe (Value' instr (IterOpEl c)), Value' instr c) instance IterOp ('TMap k v) where-  type IterOpEl ('TMap k v) = 'TPair ('Tc k) v+  type IterOpEl ('TMap k v) = 'TPair k v   iterOpDetachOne (VMap m) =-    (VPair . first VC <$> M.lookupMin m, VMap $ M.deleteMin m)+    (VPair <$> M.lookupMin m, VMap $ M.deleteMin m) instance IterOp ('TList e) where   type IterOpEl ('TList e) = e   iterOpDetachOne (VList l) =@@ -72,15 +71,15 @@       x : xs -> (Just x, VList xs)       [] -> (Nothing, VList []) instance IterOp ('TSet e) where-  type IterOpEl ('TSet e) = 'Tc e-  iterOpDetachOne (VSet s) = (VC <$> S.lookupMin s, VSet $ S.deleteMin s)+  type IterOpEl ('TSet e) = e+  iterOpDetachOne (VSet s) = (S.lookupMin s, VSet $ S.deleteMin s)  class SizeOp (c :: T) where-  evalSize :: Value' cp c -> Int-instance SizeOp ('Tc 'CString) where-  evalSize (VC (CvString s)) = length s-instance SizeOp ('Tc 'CBytes) where-  evalSize (VC (CvBytes b)) = length b+  evalSize :: Value' instr c -> Int+instance SizeOp 'TString where+  evalSize (VString s) = length s+instance SizeOp ('TBytes) where+  evalSize (VBytes b) = length b instance SizeOp ('TSet a) where   evalSize (VSet s) = S.size s instance SizeOp ('TList a) where@@ -89,11 +88,11 @@   evalSize (VMap m) = M.size m  class UpdOp (c :: T) where-  type UpdOpKey c :: CT+  type UpdOpKey c :: T   type UpdOpParams c :: T   evalUpd-    :: CValue (UpdOpKey c)-    -> Value' cp (UpdOpParams c) -> Value' cp c -> Value' cp c+    :: Value' instr (UpdOpKey c)+    -> Value' instr (UpdOpParams c) -> Value' instr c -> Value' instr c instance UpdOp ('TMap k v) where   type UpdOpKey ('TMap k v) = k   type UpdOpParams ('TMap k v) = 'TOption v@@ -110,16 +109,16 @@       Nothing -> VBigMap $ M.delete k m instance UpdOp ('TSet a) where   type UpdOpKey ('TSet a) = a-  type UpdOpParams ('TSet a) = 'Tc 'CBool-  evalUpd k (VC (CvBool b)) (VSet s) =+  type UpdOpParams ('TSet a) = 'TBool+  evalUpd k (VBool b) (VSet s) =     case b of       True -> VSet $ S.insert k s       False -> VSet $ S.delete k s  class GetOp (c :: T) where-  type GetOpKey c :: CT+  type GetOpKey c :: T   type GetOpVal c :: T-  evalGet :: CValue (GetOpKey c) -> Value' cp c -> Maybe (Value' cp (GetOpVal c))+  evalGet :: Value' instr (GetOpKey c) -> Value' instr c -> Maybe (Value' instr (GetOpVal c)) instance GetOp ('TBigMap k v) where   type GetOpKey ('TBigMap k v) = k   type GetOpVal ('TBigMap k v) = v@@ -130,25 +129,25 @@   evalGet k (VMap m) = k `M.lookup` m  class ConcatOp (c :: T) where-  evalConcat :: Value' cp c -> Value' cp c -> Value' cp c-  evalConcat' :: [Value' cp c] -> Value' cp c-instance ConcatOp ('Tc 'CString) where-  evalConcat (VC (CvString s1)) (VC (CvString s2)) = (VC . CvString) (s1 <> s2)+  evalConcat :: Value' instr c -> Value' instr c -> Value' instr c+  evalConcat' :: [Value' instr c] -> Value' instr c+instance ConcatOp ('TString) where+  evalConcat (VString s1) (VString s2) = (VString) (s1 <> s2)   evalConcat' l =-    (VC . CvString) $ mconcat $ map (\(VC (CvString s)) -> s) l-instance ConcatOp ('Tc 'CBytes) where-  evalConcat (VC (CvBytes b1)) (VC (CvBytes b2)) = (VC . CvBytes) (b1 <> b2)+    (VString) $ mconcat $ map (\(VString s) -> s) l+instance ConcatOp ('TBytes) where+  evalConcat (VBytes b1) (VBytes b2) = VBytes (b1 <> b2)   evalConcat' l =-    (VC . CvBytes) $ foldr ((<>) . (\(VC (CvBytes b)) -> b)) mempty l+    (VBytes) $ foldr ((<>) . (\(VBytes b) -> b)) mempty l  class SliceOp (c :: T) where-  evalSlice :: Natural -> Natural -> Value' cp c -> Maybe (Value' cp c)-instance SliceOp ('Tc 'CString) where-  evalSlice o l (VC (CvString s)) =-    VC . CvString <$> sliceImpl dropMText takeMText o l s-instance SliceOp ('Tc 'CBytes) where-  evalSlice o l (VC (CvBytes b)) =-    VC . CvBytes <$> sliceImpl B.drop B.take o l b+  evalSlice :: Natural -> Natural -> Value' instr c -> Maybe (Value' instr c)+instance SliceOp 'TString where+  evalSlice o l (VString s) =+    VString <$> sliceImpl dropMText takeMText o l s+instance SliceOp 'TBytes where+  evalSlice o l (VBytes b) =+    VBytes <$> sliceImpl B.drop B.take o l b  sliceImpl ::   Container str@@ -165,61 +164,61 @@   -- Drop offset and then take requested number of items.    = Just . takeF (fromIntegral l) . dropF (fromIntegral offset) $ s -class EDivOp (n :: CT) (m :: CT) where-  type EDivOpRes n m :: CT-  type EModOpRes n m :: CT+class EDivOp (n :: T) (m :: T) where+  type EDivOpRes n m :: T+  type EModOpRes n m :: T   evalEDivOp-    :: CValue n-    -> CValue m-    -> Value' instr ('TOption ('TPair ('Tc (EDivOpRes n m))-                                     ('Tc (EModOpRes n m))))+    :: Value' instr n+    -> Value' instr m+    -> Value' instr ('TOption ('TPair (EDivOpRes n m)+                                     (EModOpRes n m))) -instance EDivOp 'CInt 'CInt where-  type EDivOpRes 'CInt 'CInt = 'CInt-  type EModOpRes 'CInt 'CInt = 'CNat-  evalEDivOp (CvInt i) (CvInt j) =+instance EDivOp 'TInt 'TInt where+  type EDivOpRes 'TInt 'TInt = 'TInt+  type EModOpRes 'TInt 'TInt = 'TNat+  evalEDivOp (VInt i) (VInt j) =     if j == 0       then VOption $ Nothing       else VOption $ Just $-        VPair (VC $ CvInt (div i j), VC $ CvNat $ fromInteger (abs $ mod i j))-instance EDivOp 'CInt 'CNat where-  type EDivOpRes 'CInt 'CNat = 'CInt-  type EModOpRes 'CInt 'CNat = 'CNat-  evalEDivOp (CvInt i) (CvNat j) =+        VPair (VInt (div i j), VNat $ fromInteger (abs $ mod i j))+instance EDivOp 'TInt 'TNat where+  type EDivOpRes 'TInt 'TNat = 'TInt+  type EModOpRes 'TInt 'TNat = 'TNat+  evalEDivOp (VInt i) (VNat j) =     if j == 0       then VOption $ Nothing       else VOption $ Just $-        VPair (VC $ CvInt (div i (toInteger j)), VC $ CvNat $ (abs $ mod (fromInteger i) j))-instance EDivOp 'CNat 'CInt where-  type EDivOpRes 'CNat 'CInt = 'CInt-  type EModOpRes 'CNat 'CInt = 'CNat-  evalEDivOp (CvNat i) (CvInt j) =+        VPair (VInt (div i (toInteger j)), VNat $ (abs $ mod (fromInteger i) j))+instance EDivOp 'TNat 'TInt where+  type EDivOpRes 'TNat 'TInt = 'TInt+  type EModOpRes 'TNat 'TInt = 'TNat+  evalEDivOp (VNat i) (VInt j) =     if j == 0       then VOption $ Nothing       else VOption $ Just $-        VPair (VC $ CvInt (div (toInteger i) j), VC $ CvNat $ (abs $ mod i (fromInteger j)))-instance EDivOp 'CNat 'CNat where-  type EDivOpRes 'CNat 'CNat = 'CNat-  type EModOpRes 'CNat 'CNat = 'CNat-  evalEDivOp (CvNat i) (CvNat j) =+        VPair (VInt (div (toInteger i) j), VNat $ (abs $ mod i (fromInteger j)))+instance EDivOp 'TNat 'TNat where+  type EDivOpRes 'TNat 'TNat = 'TNat+  type EModOpRes 'TNat 'TNat = 'TNat+  evalEDivOp (VNat i) (VNat j) =     if j == 0       then VOption $ Nothing       else VOption $ Just $-        VPair (VC $ CvNat (div i j), VC $ CvNat $ (mod i j))-instance EDivOp 'CMutez 'CMutez where-  type EDivOpRes 'CMutez 'CMutez = 'CNat-  type EModOpRes 'CMutez 'CMutez = 'CMutez-  evalEDivOp (CvMutez i) (CvMutez j) =+        VPair (VNat (div i j), VNat $ (mod i j))+instance EDivOp 'TMutez 'TMutez where+  type EDivOpRes 'TMutez 'TMutez = 'TNat+  type EModOpRes 'TMutez 'TMutez = 'TMutez+  evalEDivOp (VMutez i) (VMutez j) =     VOption $     i `divModMutez` j <&> \case       (quotient, remainder) ->-        VPair (VC $ CvNat (fromIntegral quotient), VC $ CvMutez remainder)+        VPair (VNat (fromIntegral quotient), VMutez remainder) -instance EDivOp 'CMutez 'CNat where-  type EDivOpRes 'CMutez 'CNat = 'CMutez-  type EModOpRes 'CMutez 'CNat = 'CMutez-  evalEDivOp (CvMutez i) (CvNat j) =+instance EDivOp 'TMutez 'TNat where+  type EDivOpRes 'TMutez 'TNat = 'TMutez+  type EModOpRes 'TMutez 'TNat = 'TMutez+  evalEDivOp (VMutez i) (VNat j) =     VOption $     i `divModMutezInt` j <&> \case       (quotient, remainder) ->-        VPair (VC $ CvMutez quotient, VC $ CvMutez remainder)+        VPair (VMutez quotient, VMutez remainder)
src/Michelson/Typed/Scope.hs view
@@ -31,13 +31,12 @@  module Michelson.Typed.Scope   ( -- * Scopes-    ComparabilityScope-  , ParameterScope+    ConstantScope   , StorageScope-  , ConstantScope   , PackedValScope-  , UnpackedValScope+  , ParameterScope   , PrintedValScope+  , UnpackedValScope    , ProperParameterBetterErrors   , ProperStorageBetterErrors@@ -45,7 +44,6 @@   , ProperPackedValBetterErrors   , ProperUnpackedValBetterErrors   , ProperPrintedValBetterErrors-  , ProperComparabilityBetterErrors    , properParameterEvi   , properStorageEvi@@ -59,7 +57,6 @@   , CheckScope (..)      -- * Implementation internals-  , Comparable   , HasNoBigMap   , HasNoNestedBigMaps   , HasNoOp@@ -74,15 +71,11 @@   , FailOnBigMapFound   , FailOnNestedBigMapsFound   , FailOnOperationFound-  , ForbidNonComparable -  , Comparability(..)   , OpPresence (..)   , ContractPresence (..)   , BigMapPresence (..)   , NestedBigMapsPresence (..)-  , comparabilityPresence-  , checkComparability   , checkOpPresence   , checkContractTypePresence   , checkBigMapPresence@@ -103,44 +96,38 @@  import Data.Constraint ((:-)(..), Dict(..), withDict, (\\)) import qualified Data.Constraint as C-import Data.Singletons (SingI(..))-import Data.Type.Bool (type (&&), type (||))+import Data.Singletons (Sing, SingI(..))+import Data.Type.Bool (type (||)) import Fmt (Buildable(..)) import GHC.TypeLits (ErrorMessage(..), TypeError) -import Michelson.Typed.Sing (Sing(..))+import Michelson.Typed.Sing (SingT(..)) import Michelson.Typed.T (T(..))  ---------------------------------------------------------------------------- -- Constraints ------------------------------------------------------------------------------type family IsComparable (t :: T) :: Bool where-  IsComparable ('Tc _)      = 'True-  IsComparable ('TPair a b) =  IsComparable a && IsComparable b-  IsComparable _            = 'False- -- | Whether this type contains 'TOperation' type. -- -- In some scopes (constants, parameters, storage) appearing for operation type -- is prohibited. -- Operations in input/output of lambdas are allowed without limits though. type family ContainsOp (t :: T) :: Bool where-  ContainsOp ('Tc _) = 'False   ContainsOp 'TKey = 'False   ContainsOp 'TUnit = 'False   ContainsOp 'TSignature = 'False   ContainsOp 'TChainId = 'False   ContainsOp ('TOption t) = ContainsOp t   ContainsOp ('TList t) = ContainsOp t-  ContainsOp ('TSet _) = 'False+  ContainsOp ('TSet t) = ContainsOp t   ContainsOp 'TOperation = 'True   ContainsOp ('TContract t) = ContainsOp t   ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b   ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b   ContainsOp ('TLambda _ _) = 'False-  ContainsOp ('TMap _ v) = ContainsOp v-  ContainsOp ('TBigMap _ v) = ContainsOp v+  ContainsOp ('TMap k v) = ContainsOp k || ContainsOp v+  ContainsOp ('TBigMap k v) = ContainsOp k || ContainsOp v+  ContainsOp _ = 'False  -- | Whether this type contains 'TContract' type. --@@ -148,7 +135,6 @@ -- is prohibited. -- Contracts in input/output of lambdas are allowed without limits though. type family ContainsContract (t :: T) :: Bool where-  ContainsContract ('Tc _) = 'False   ContainsContract 'TKey = 'False   ContainsContract 'TUnit = 'False   ContainsContract 'TSignature = 'False@@ -163,10 +149,10 @@   ContainsContract ('TLambda _ _) = 'False   ContainsContract ('TMap _ v) = ContainsContract v   ContainsContract ('TBigMap _ v) = ContainsContract v+  ContainsContract _ = 'False  -- | Whether this type contains 'TBigMap' type. type family ContainsBigMap (t :: T) :: Bool where-  ContainsBigMap ('Tc _) = 'False   ContainsBigMap 'TKey = 'False   ContainsBigMap 'TUnit = 'False   ContainsBigMap 'TSignature = 'False@@ -181,6 +167,7 @@   ContainsBigMap ('TLambda _ _) = 'False   ContainsBigMap ('TMap _ v) = ContainsBigMap v   ContainsBigMap ('TBigMap _ _) = 'True+  ContainsBigMap _ = 'False  -- | Whether this type contains a type with nested 'TBigMap's . --@@ -188,7 +175,6 @@ -- prohibited in all contexts. Some context such as PUSH, APPLY, PACK/UNPACK instructions are more -- strict because they doesn't work with big_map at all. type family ContainsNestedBigMaps (t :: T) :: Bool where-  ContainsNestedBigMaps ('Tc _) = 'False   ContainsNestedBigMaps 'TKey = 'False   ContainsNestedBigMaps 'TUnit = 'False   ContainsNestedBigMaps 'TSignature = 'False@@ -203,6 +189,7 @@   ContainsNestedBigMaps ('TLambda _ _) = 'False   ContainsNestedBigMaps ('TMap _ v) = ContainsNestedBigMaps v   ContainsNestedBigMaps ('TBigMap _ v) = ContainsBigMap v+  ContainsNestedBigMaps _ = 'False  -- | Constraint which ensures that operation type does not appear in a given type. --@@ -223,10 +210,6 @@ class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t --- | Constraint which ensures that type is comparable.-class (IsComparable t ~ 'True) => Comparable t-instance (IsComparable t ~ 'True) => Comparable t- -- | Report a human-readable error about 'TOperation' at a wrong place. type family FailOnOperationFound (enabled :: Bool) :: Constraint where   FailOnOperationFound 'True =@@ -251,12 +234,6 @@     TypeError ('Text "Nested BigMaps are not allowed")   FailOnNestedBigMapsFound 'False = () --- | Report a human-readable error that 'TBigMap' contains another 'TBigMap'-type family FailOnNonComparable (isComparable :: Bool) :: Constraint where-  FailOnNonComparable 'False =-    TypeError ('Text "The type is not comparable")-  FailOnNonComparable 'True = ()- -- | This is like 'HasNoOp', it raises a more human-readable error -- when @t@ type is concrete, but GHC cannot make any conclusions -- from such constraint as it can for 'HasNoOp'.@@ -272,8 +249,6 @@  type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t) -type ForbidNonComparable t = FailOnNonComparable (IsComparable t)- -- | Evidence of that 'HasNoOp' is deducable from 'ForbidOp'. forbiddenOpEvi :: forall t. (SingI t, ForbidOp t) :- HasNoOp t forbiddenOpEvi = Sub $@@ -353,31 +328,6 @@   = ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresent   | ContainsNestedBigMaps t ~ 'False => NestedBigMapsAbsent -data Comparability t where-  CanBeCompared :: Comparable t => Comparability t-  CannotBeCompared :: (IsComparable t ~ 'False) => Comparability t--checkComparability :: Sing t -> Comparability t-checkComparability = \case-  STc _ -> CanBeCompared-  STPair a b -> case (checkComparability a, checkComparability b) of-    (CanBeCompared, CanBeCompared) -> CanBeCompared-    (CannotBeCompared, _) -> CannotBeCompared-    (_, CannotBeCompared) -> CannotBeCompared-  STKey -> CannotBeCompared-  STUnit -> CannotBeCompared-  STSignature -> CannotBeCompared-  STChainId -> CannotBeCompared-  STOption _ -> CannotBeCompared-  STList _ -> CannotBeCompared-  STSet _ -> CannotBeCompared-  STOperation -> CannotBeCompared-  STContract _ -> CannotBeCompared-  STOr _ _ -> CannotBeCompared-  STLambda _ _ -> CannotBeCompared-  STMap _ _ -> CannotBeCompared-  STBigMap _ _ -> CannotBeCompared- -- @rvem: IMO, generalization of OpPresence and BigMapPresence to -- TPresence is not worth it, due to the fact that -- it will require more boilerplate in checkTPresence implementation@@ -391,7 +341,6 @@   -- We can't do in a simpler way while requiring only @Sing ty@ / @SingI ty@,   -- and a more complex constraint would be too unpleasant and confusing to   -- propagate everywhere.-  STc _ -> OpAbsent   STKey -> OpAbsent   STSignature -> OpAbsent   STChainId -> OpAbsent@@ -402,7 +351,9 @@   STList t -> case checkOpPresence t of     OpPresent -> OpPresent     OpAbsent -> OpAbsent-  STSet _ -> OpAbsent+  STSet a -> case checkOpPresence a of+    OpPresent -> OpPresent+    OpAbsent -> OpAbsent   STOperation -> OpPresent   STContract t -> case checkOpPresence t of     OpPresent -> OpPresent@@ -416,17 +367,27 @@     (_, OpPresent) -> OpPresent     (OpAbsent, OpAbsent) -> OpAbsent   STLambda _ _ -> OpAbsent-  STMap _ v -> case checkOpPresence v of-    OpPresent -> OpPresent-    OpAbsent -> OpAbsent-  STBigMap _ v -> case checkOpPresence v of-    OpPresent -> OpPresent-    OpAbsent -> OpAbsent+  STMap k v -> case (checkOpPresence k, checkOpPresence v) of+    (OpAbsent, OpAbsent) -> OpAbsent+    (OpPresent, _) -> OpPresent+    (_, OpPresent) -> OpPresent+  STBigMap k v -> case (checkOpPresence k, checkOpPresence v) of+    (OpAbsent, OpAbsent) -> OpAbsent+    (OpPresent, _) -> OpPresent+    (_, OpPresent) -> OpPresent+  STInt -> OpAbsent+  STNat -> OpAbsent+  STString -> OpAbsent+  STBytes -> OpAbsent+  STMutez -> OpAbsent+  STBool -> OpAbsent+  STKeyHash -> OpAbsent+  STTimestamp -> OpAbsent+  STAddress -> OpAbsent  -- | Check at runtime whether the given type contains 'TContract'. checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty checkContractTypePresence = \case-  STc _ -> ContractAbsent   STKey -> ContractAbsent   STSignature -> ContractAbsent   STChainId -> ContractAbsent@@ -455,12 +416,20 @@   STBigMap _ v -> case checkContractTypePresence v of     ContractPresent -> ContractPresent     ContractAbsent -> ContractAbsent+  STInt -> ContractAbsent+  STNat -> ContractAbsent+  STString -> ContractAbsent+  STBytes -> ContractAbsent+  STMutez -> ContractAbsent+  STBool -> ContractAbsent+  STKeyHash -> ContractAbsent+  STTimestamp -> ContractAbsent+  STAddress -> ContractAbsent  -- | Check at runtime whether the given type contains 'TBigMap'. checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty checkBigMapPresence = \case   -- More boilerplate to boilerplate god.-  STc _ -> BigMapAbsent   STKey -> BigMapAbsent   STSignature -> BigMapAbsent   STChainId -> BigMapAbsent@@ -490,12 +459,20 @@     BigMapAbsent -> BigMapAbsent   STBigMap _ _ ->     BigMapPresent+  STInt -> BigMapAbsent+  STNat -> BigMapAbsent+  STString -> BigMapAbsent+  STBytes -> BigMapAbsent+  STMutez -> BigMapAbsent+  STBool -> BigMapAbsent+  STKeyHash -> BigMapAbsent+  STTimestamp -> BigMapAbsent+  STAddress -> BigMapAbsent  -- | Check at runtime whether the given type contains 'TBigMap'. checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty checkNestedBigMapsPresence = \case   -- More boilerplate to boilerplate god.-  STc _ -> NestedBigMapsAbsent   STKey -> NestedBigMapsAbsent   STSignature -> NestedBigMapsAbsent   STChainId -> NestedBigMapsAbsent@@ -526,11 +503,15 @@   STBigMap _ v -> case checkBigMapPresence v of     BigMapPresent -> NestedBigMapsPresent     BigMapAbsent -> NestedBigMapsAbsent--comparabilityPresence :: Sing t -> Maybe (Dict $ Comparable t)-comparabilityPresence s = case checkComparability s of-  CanBeCompared -> Just Dict-  CannotBeCompared -> Nothing+  STInt -> NestedBigMapsAbsent+  STNat -> NestedBigMapsAbsent+  STString -> NestedBigMapsAbsent+  STBytes -> NestedBigMapsAbsent+  STMutez -> NestedBigMapsAbsent+  STBool -> NestedBigMapsAbsent+  STKeyHash -> NestedBigMapsAbsent+  STTimestamp -> NestedBigMapsAbsent+  STAddress -> NestedBigMapsAbsent  -- | Check at runtime that the given type does not contain 'TOperation'. opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)@@ -566,19 +547,17 @@   | BtHasBigMap   | BtHasNestedBigMap   | BtHasContract+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)  instance Buildable BadTypeForScope where   build = \case-    BtNotComparable -> "not comparable"+    BtNotComparable -> "is not comparable"     BtIsOperation -> "has 'operation' type"     BtHasBigMap -> "has 'big_map'"     BtHasNestedBigMap -> "has nested 'big_map'"     BtHasContract -> "has 'contract' type" --- | Alias for comparable types.-type ComparabilityScope t =-  (Typeable t, SingI t, Comparable t)- -- | Alias for constraints which Michelson applies to parameter. type ParameterScope t =   (Typeable t, SingI t, HasNoOp t, HasNoNestedBigMaps t)@@ -614,8 +593,6 @@   -- | Check that constraint hold for a given type.   checkScope :: Either BadTypeForScope (Dict c) -instance SingI t => CheckScope (Comparable t) where-  checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing instance SingI t => CheckScope (HasNoOp t) where   checkScope = maybeToRight BtIsOperation $ opAbsense sing instance SingI t => CheckScope (HasNoBigMap t) where@@ -625,10 +602,6 @@ instance SingI t => CheckScope (HasNoContract t) where   checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing -instance (Typeable t, SingI t) => CheckScope (ComparabilityScope t) where-  checkScope =-    (\Dict -> Dict) <$> checkScope @(Comparable t)- instance (Typeable t, SingI t) => CheckScope (ParameterScope t) where   checkScope =     (\Dict Dict -> Dict)@@ -685,9 +658,6 @@  type ProperPrintedValBetterErrors t =   (SingI t, ForbidOp t)--type ProperComparabilityBetterErrors t =-  (SingI t, ForbidNonComparable t, Comparable t)  properParameterEvi :: forall t. ProperParameterBetterErrors t :- ParameterScope t properParameterEvi = Sub $
src/Michelson/Typed/Sing.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Module, providing singleton boilerplate for--- 'T' and 'CT' data types.+-- 'T' data types. -- -- Some functions from Data.Singletons are provided alternative version here. -- Some instances which are usually generated with TH are manually implemented@@ -9,122 +9,52 @@ -- 'Converge', not provided in instances generated by TH.  module Michelson.Typed.Sing-  ( Sing (..)+  ( SingT (..)   , withSomeSingT-  , withSomeSingCT   , fromSingT-  , fromSingCT   ) where  import Data.Kind (Type)-import Data.Singletons (Sing(..), SingI(..), SingKind(..), SomeSing(..))+import Data.Singletons (Sing, SingI(..), SingKind(..), SomeSing(..)) -import Michelson.Typed.T (CT(..), T(..))+import Michelson.Typed.T (T(..)) --- | Instance of data family 'Sing' for 'CT'.-data instance Sing :: CT -> Type where-  SCInt :: Sing  'CInt-  SCNat :: Sing  'CNat-  SCString :: Sing  'CString-  SCBytes :: Sing  'CBytes-  SCMutez :: Sing  'CMutez-  SCBool :: Sing  'CBool-  SCKeyHash :: Sing  'CKeyHash-  SCTimestamp :: Sing  'CTimestamp-  SCAddress :: Sing  'CAddress  -- | Instance of data family 'Sing' for 'T'. -- Custom instance is implemented in order to inject 'Typeable' -- constraint for some of constructors.-data instance Sing :: T -> Type where-  STc :: (SingI a, Typeable a) => Sing a -> Sing ( 'Tc a)-  STKey :: Sing  'TKey-  STUnit :: Sing  'TUnit-  STSignature :: Sing  'TSignature-  STChainId :: Sing  'TChainId-  STOption :: (SingI a, Typeable a) => Sing a -> Sing ( 'TOption a)-  STList :: (SingI a, Typeable a) => Sing a -> Sing ( 'TList a )-  STSet :: (SingI a, Typeable a) => Sing a -> Sing ( 'TSet a )-  STOperation  :: Sing 'TOperation+data SingT :: T -> Type where+  STKey :: SingT  'TKey+  STUnit :: SingT  'TUnit+  STSignature :: SingT  'TSignature+  STChainId :: SingT  'TChainId+  STOption :: (SingI a, Typeable a) => Sing a -> SingT ( 'TOption a)+  STList :: (SingI a, Typeable a) => Sing a -> SingT ( 'TList a )+  STSet :: (SingI a, Typeable a) => Sing a -> SingT ( 'TSet a )+  STOperation  :: SingT 'TOperation   STContract   :: (SingI a, Typeable a)-                => Sing a -> Sing ( 'TContract a )+                => Sing a -> SingT ( 'TContract a )   STPair       :: (SingI a, SingI b, Typeable a, Typeable b)-                => Sing a -> Sing b -> Sing ('TPair a b)+                => Sing a -> Sing b -> SingT ('TPair a b)   STOr         :: (SingI a, SingI b, Typeable a, Typeable b)-                => Sing a -> Sing b -> Sing ('TOr a b)+                => Sing a -> Sing b -> SingT ('TOr a b)   STLambda     :: (SingI a, SingI b, Typeable a, Typeable b)-                => Sing a -> Sing b -> Sing ('TLambda a b)+                => Sing a -> Sing b -> SingT ('TLambda a b)   STMap        :: (SingI a, SingI b, Typeable a, Typeable b)-                => Sing a -> Sing b -> Sing ('TMap a b)+                => Sing a -> Sing b -> SingT ('TMap a b)   STBigMap    :: (SingI a, SingI b, Typeable a, Typeable b)-                => Sing a -> Sing b -> Sing ('TBigMap a b)-------------------------------------------------- Singleton-related instances for CT-------------------------------------------------- | Version of 'SomeSing' with 'Typeable' constraint,--- specialized for use with 'CT' kind.-data SomeSingCT where-  SomeSingCT :: forall (a :: CT). (SingI a, Typeable a) => Sing a -> SomeSingCT---- | Version of 'withSomeSing' with 'Typeable' constraint--- provided to processing function.------ Required for not to erase this useful constraint when doing--- conversion from value of type 'CT' to its singleton representation.-withSomeSingCT-  :: CT -> (forall (a :: CT). (SingI a, Typeable a) => Sing a -> r) -> r-withSomeSingCT ct f = (\(SomeSingCT s) -> f s) (toSingCT ct)--fromSingCT :: Sing (a :: CT) -> CT-fromSingCT = \case-  SCInt -> CInt-  SCNat -> CNat-  SCString -> CString-  SCBytes -> CBytes-  SCMutez -> CMutez-  SCBool -> CBool-  SCKeyHash -> CKeyHash-  SCTimestamp -> CTimestamp-  SCAddress -> CAddress---- | Version of 'toSing' which creates 'SomeSingCT'.-toSingCT :: CT -> SomeSingCT-toSingCT = \case-  CInt -> SomeSingCT SCInt-  CNat -> SomeSingCT SCNat-  CString -> SomeSingCT SCString-  CBytes -> SomeSingCT SCBytes-  CMutez -> SomeSingCT SCMutez-  CBool -> SomeSingCT SCBool-  CKeyHash -> SomeSingCT SCKeyHash-  CTimestamp -> SomeSingCT SCTimestamp-  CAddress -> SomeSingCT SCAddress--instance SingKind CT where-  type Demote CT = CT-  fromSing  = fromSingCT-  toSing t = case toSingCT t of SomeSingCT s -> SomeSing s+                => Sing a -> Sing b -> SingT ('TBigMap a b)+  STInt :: SingT  'TInt+  STNat :: SingT  'TNat+  STString :: SingT  'TString+  STBytes :: SingT  'TBytes+  STMutez :: SingT  'TMutez+  STBool :: SingT  'TBool+  STKeyHash :: SingT  'TKeyHash+  STTimestamp :: SingT  'TTimestamp+  STAddress :: SingT  'TAddress -instance SingI  'CInt where-  sing = SCInt-instance SingI  'CNat where-  sing = SCNat-instance SingI  'CString where-  sing = SCString-instance SingI  'CBytes where-  sing = SCBytes-instance SingI  'CMutez where-  sing = SCMutez-instance SingI  'CBool where-  sing = SCBool-instance SingI  'CKeyHash where-  sing = SCKeyHash-instance SingI  'CTimestamp where-  sing = SCTimestamp-instance SingI  'CAddress where-  sing = SCAddress+type instance Sing = SingT  --------------------------------------------- -- Singleton-related helpers for T@@ -152,33 +82,40 @@ -- constraint for some of its constructors fromSingT :: Sing (a :: T) -> T fromSingT = \case-  STc t -> Tc (fromSingCT t)   STKey -> TKey   STUnit -> TUnit   STSignature -> TSignature   STChainId -> TChainId   STOption t -> TOption (fromSingT t)   STList t -> TList (fromSingT t)-  STSet t -> TSet (fromSingCT t)+  STSet t -> TSet (fromSingT t)   STOperation -> TOperation   STContract t -> TContract (fromSingT t)   STPair a b -> TPair (fromSingT a) (fromSingT b)   STOr a b -> TOr (fromSingT a) (fromSingT b)   STLambda a b -> TLambda (fromSingT a) (fromSingT b)-  STMap a b -> TMap (fromSingCT a) (fromSingT b)-  STBigMap a b -> TBigMap (fromSingCT a) (fromSingT b)+  STMap a b -> TMap (fromSingT a) (fromSingT b)+  STBigMap a b -> TBigMap (fromSingT a) (fromSingT b)+  STInt -> TInt+  STNat -> TNat+  STString -> TString+  STBytes -> TBytes+  STMutez -> TMutez+  STBool -> TBool+  STKeyHash -> TKeyHash+  STTimestamp -> TTimestamp+  STAddress -> TAddress  -- | Version of 'toSing' which creates 'SomeSingT'. toSingT :: T -> SomeSingT toSingT = \case-  Tc ct -> withSomeSingCT ct $ \ctSing -> SomeSingT $ STc ctSing   TKey -> SomeSingT STKey   TUnit -> SomeSingT STUnit   TSignature -> SomeSingT STSignature   TChainId -> SomeSingT STChainId   TOption t -> withSomeSingT t $ \tSing -> SomeSingT $ STOption tSing   TList t -> withSomeSingT t $ \tSing -> SomeSingT $ STList tSing-  TSet ct -> withSomeSingCT ct $ \ctSing -> SomeSingT $ STSet ctSing+  TSet ct -> withSomeSingT ct $ \ctSing -> SomeSingT $ STSet ctSing   TOperation -> SomeSingT STOperation   TContract t -> withSomeSingT t $ \tSing -> SomeSingT $ STContract tSing   TPair l r ->@@ -194,21 +131,28 @@     withSomeSingT r $ \rSing ->       SomeSingT $ STLambda lSing rSing   TMap l r ->-    withSomeSingCT l $ \lSing ->+    withSomeSingT l $ \lSing ->     withSomeSingT r $ \rSing ->       SomeSingT $ STMap lSing rSing   TBigMap l r ->-    withSomeSingCT l $ \lSing ->+    withSomeSingT l $ \lSing ->     withSomeSingT r $ \rSing ->       SomeSingT $ STBigMap lSing rSing+  TInt -> SomeSingT STInt+  TNat -> SomeSingT STNat+  TString -> SomeSingT STString+  TBytes -> SomeSingT STBytes+  TMutez -> SomeSingT STMutez+  TBool -> SomeSingT STBool+  TKeyHash -> SomeSingT STKeyHash+  TTimestamp -> SomeSingT STTimestamp+  TAddress -> SomeSingT STAddress  instance SingKind T where   type Demote T = T   fromSing  = fromSingT   toSing t = case toSingT t of SomeSingT s -> SomeSing s -instance (SingI t, Typeable t) => SingI ( 'Tc (t :: CT)) where-  sing = STc sing instance SingI  'TKey where   sing = STKey instance SingI  'TUnit where@@ -221,7 +165,7 @@   sing = STOption sing instance (SingI a, Typeable a) => SingI ( 'TList (a :: T)) where   sing = STList sing-instance (SingI a, Typeable a) => SingI ( 'TSet (a :: CT)) where+instance (SingI a, Typeable a) => SingI ( 'TSet (a :: T)) where   sing = STSet sing instance SingI 'TOperation where   sing = STOperation@@ -243,3 +187,21 @@ instance (SingI a, Typeable a, Typeable b, SingI b) =>           SingI ( 'TBigMap a b) where   sing = STBigMap sing sing+instance SingI  'TInt where+  sing = STInt+instance SingI  'TNat where+  sing = STNat+instance SingI  'TString where+  sing = STString+instance SingI  'TBytes where+  sing = STBytes+instance SingI  'TMutez where+  sing = STMutez+instance SingI  'TBool where+  sing = STBool+instance SingI  'TKeyHash where+  sing = STKeyHash+instance SingI  'TTimestamp where+  sing = STTimestamp+instance SingI  'TAddress where+  sing = STAddress
src/Michelson/Typed/T.hs view
@@ -1,36 +1,42 @@ {-# LANGUAGE DataKinds #-} --- | Module, providing 'CT' and 'T' data types, representing Michelson+-- | Module, providing 'T' data type, representing Michelson -- language types without annotations. module Michelson.Typed.T-  ( CT (..)-  , T (..)+  ( T (..)   , toUType   , buildStack   ) where  import Fmt (Buildable(..), Builder, listF) import qualified Michelson.Untyped.Annotation as Un-import Michelson.Untyped.Type (CT) import qualified Michelson.Untyped.Type as Un  -- | Michelson language type with annotations stripped off. data T =-    Tc CT-  | TKey+    TKey   | TUnit   | TSignature   | TChainId   | TOption T   | TList T-  | TSet CT+  | TSet T   | TOperation   | TContract T   | TPair T T   | TOr T T   | TLambda T T-  | TMap CT T-  | TBigMap CT T+  | TMap T T+  | TBigMap T T+  | TInt+  | TNat+  | TString+  | TBytes+  | TMutez+  | TBool+  | TKeyHash+  | TTimestamp+  | TAddress   deriving stock (Eq, Show, Generic)  instance NFData T@@ -40,14 +46,22 @@ toUType t = Un.Type (convert t) Un.noAnn   where     convert :: T -> Un.T-    convert (Tc a) = Un.Tc a-    convert (TKey) = Un.TKey-    convert (TUnit) = Un.TUnit-    convert (TSignature) = Un.TSignature-    convert (TChainId) = Un.TChainId+    convert TInt = Un.TInt+    convert TNat = Un.TNat+    convert TString = Un.TString+    convert TBytes = Un.TBytes+    convert TMutez = Un.TMutez+    convert TBool = Un.TBool+    convert TKeyHash = Un.TKeyHash+    convert TTimestamp = Un.TTimestamp+    convert TAddress = Un.TAddress+    convert TKey = Un.TKey+    convert TUnit = Un.TUnit+    convert TSignature = Un.TSignature+    convert TChainId = Un.TChainId     convert (TOption a) = Un.TOption (toUType a)     convert (TList a) = Un.TList (toUType a)-    convert (TSet a) = Un.TSet $ Un.Comparable a Un.noAnn+    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) =@@ -57,9 +71,9 @@     convert (TLambda a b) =       Un.TLambda (toUType a) (toUType b)     convert (TMap a b) =-      Un.TMap (Un.Comparable a Un.noAnn) (toUType b)+      Un.TMap (Un.Type (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)     convert (TBigMap a b) =-      Un.TBigMap (Un.Comparable a Un.noAnn) (toUType b)+      Un.TBigMap (Un.Type (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)  instance Buildable T where   build = build . toUType
src/Michelson/Typed/Util.hs view
@@ -9,6 +9,7 @@    -- * Changing instruction tree structure   , linearizeLeft+  , linearizeLeftDeep    -- * Value analysis   , isStringValue@@ -179,7 +180,6 @@     SHA512{} -> step i     BLAKE2B{} -> step i     HASH_KEY{} -> step i-    STEPS_TO_QUOTA{} -> step i     SOURCE{} -> step i     SENDER{} -> step i     ADDRESS{} -> step i@@ -346,17 +346,19 @@     i@SHA512 -> RfNormal i     i@BLAKE2B -> RfNormal i     i@HASH_KEY -> RfNormal i-    i@STEPS_TO_QUOTA -> RfNormal i     i@SOURCE -> RfNormal i     i@SENDER -> RfNormal i     i@ADDRESS -> RfNormal i     i@CHAIN_ID -> RfNormal i  -- | 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@.+-- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@. -- This function enforces a particular structure. Specifically, it makes each -- 'Seq' have a single instruction (i. e. not 'Seq') in its second argument. -- This function also erases redundant 'Nop's.+--+-- Please note that this function is not recursive, it does not+-- linearize contents of @IF@ and similar instructions. linearizeLeft :: Instr inp out -> Instr inp out linearizeLeft = linearizeLeftHelper False   where@@ -379,6 +381,11 @@           | otherwise -> Seq (linearizeLeft i1) i2         i -> i +-- | "Deep" version of 'linearizeLeft'. It recursively linearizes+-- instructions stored in other instructions.+linearizeLeftDeep :: Instr inp out -> Instr inp out+linearizeLeftDeep = dfsModifyInstr def linearizeLeft+ ---------------------------------------------------------------------------- -- Value analysis ----------------------------------------------------------------------------@@ -387,14 +394,14 @@ isStringValue :: Value t -> Maybe MText isStringValue =   \case-    VC (CvString str) -> Just str+    VString str -> Just str     _ -> Nothing  -- | If value is a bytestring, return the stored bytestring. isBytesValue :: Value t -> Maybe ByteString isBytesValue =   \case-    VC (CvBytes bytes) -> Just bytes+    VBytes bytes -> Just bytes     _ -> Nothing  -- | Takes a selector which checks whether an atomic value (i. e. that@@ -410,12 +417,12 @@     go :: forall x. Value x -> [a]     go = \case       VList l -> foldMap go l-      VSet s -> foldMap (go . VC) s+      VSet s -> foldMap go s       VPair (l, r) -> go l <> go r       VOr e -> either go go e       VMap m -> goMap m       VBigMap m -> goMap m       v -> maybeToList $ selector v -    goMap :: Map (CValue k) (Value v) -> [a]-    goMap m = foldMap (go . VC) (keys m) <> foldMap go (toList m)+    goMap :: Map (Value k) (Value v) -> [a]+    goMap m = foldMap go (keys m) <> foldMap go (toList m)
src/Michelson/Typed/Value.hs view
@@ -3,38 +3,48 @@ -- | Module, containing data types for Michelson value.  module Michelson.Typed.Value-  ( Value' (..)-  , SomeValue' (..)+  ( SomeValue' (..)   , SomeConstrainedValue' (..)+  , Comparability (..)+  , Comparable+  , ComparabilityScope   , ContractInp1   , ContractInp   , ContractOut1   , ContractOut   , CreateContract (..)-  , CValue (..)   , Operation' (..)   , SetDelegate (..)   , TransferTokens (..)+  , Value' (..)   , RemFail (..)   , rfMerge   , rfAnyInstr   , rfMapAnyInstr   , addressToVContract   , buildVContract+  , checkComparability   , compileEpLiftSequence+  , comparabilityPresence+  , getComparableProofS   , liftCallArg   ) where -import Data.Singletons (SingI)-import Fmt (Buildable(build), (+|), (|+), Builder)+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Data.Constraint (Dict(..))+import Data.Singletons (SingI, Sing, sing)+import Data.Type.Bool (type (&&)) import qualified Data.Kind as Kind+import Fmt (Buildable(build), Builder, (+|), (|+)) -import Michelson.Typed.CValue (CValue(..))+import Michelson.Text (MText) import Michelson.Typed.EntryPoints-import Michelson.Typed.Scope (ParameterScope, StorageScope)+import Michelson.Typed.Sing+import Michelson.Typed.Scope (BadTypeForScope(..), CheckScope(..), ParameterScope, StorageScope) import Michelson.Typed.T (T(..)) import Tezos.Address (Address)-import Tezos.Core (ChainId, Mutez)+import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, PublicKey, Signature) import Util.TH import Util.Typeable@@ -169,35 +179,170 @@   RfNormal i -> RfNormal $ f i   RfAlwaysFails i -> RfAlwaysFails $ f i +getComparableProofS :: Sing (a :: T) -> Maybe (Dict (Comparable a))+getComparableProofS s = case s of+  STPair a b -> do+    Dict <- getComparableProofS a+    Dict <- getComparableProofS b+    pure Dict+  STInt -> Just Dict+  STNat -> Just Dict+  STString -> Just Dict+  STBytes -> Just Dict+  STMutez -> Just Dict+  STBool -> Just Dict+  STKeyHash -> Just Dict+  STTimestamp -> Just Dict+  STAddress -> Just Dict+  STKey -> Nothing+  STUnit -> Nothing+  STSignature -> Nothing+  STChainId -> Nothing+  STOption{} -> Nothing+  STList{} -> Nothing+  STSet{} -> Nothing+  STOperation -> Nothing+  STContract{} -> Nothing+  STOr{} -> Nothing+  STLambda{} -> Nothing+  STMap{} -> Nothing+  STBigMap{} -> Nothing++-- | 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 ('TList _) = 'False+  IsComparable ('TSet _) = 'False+  IsComparable 'TOperation = 'False+  IsComparable ('TContract _) = 'False+  IsComparable ('TOr _ _) = 'False+  IsComparable ('TLambda _ _) = 'False+  IsComparable ('TMap _ _) = 'False+  IsComparable ('TBigMap _ _) = 'False+  IsComparable _            = 'True++class (IsComparable t ~ 'True) => Comparable t where+  tcompare :: (Value' instr t) -> (Value' instr t) -> Ordering++instance (Comparable e1, Comparable e2) => Comparable ('TPair e1 e2) where+  tcompare (VPair a) (VPair b) = compare a b+instance Comparable 'TInt where+  tcompare (VInt a) (VInt b) = compare a b+instance Comparable 'TNat where+  tcompare (VNat a) (VNat b) = compare a b+instance Comparable 'TString where+  tcompare (VString a) (VString b) = compare a b+instance Comparable 'TBytes where+  tcompare (VBytes a) (VBytes b) = compare a b+instance Comparable 'TMutez where+  tcompare (VMutez a) (VMutez b) = compare a b+instance Comparable 'TBool where+  tcompare (VBool a) (VBool b) = compare a b+instance Comparable 'TKeyHash where+  tcompare (VKeyHash a) (VKeyHash b) = compare a b+instance Comparable 'TTimestamp where+  tcompare (VTimestamp a) (VTimestamp b) = compare a b+instance Comparable 'TAddress where+  tcompare (VAddress a) (VAddress b) = compare a b++instance (Comparable e) => Ord (Value' instr e) where+  compare = tcompare @e++-- | Report a human-readable error that 'TBigMap' contains another 'TBigMap'+type family FailOnNonComparable (isComparable :: Bool) :: Constraint where+  FailOnNonComparable 'False =+    TypeError ('Text "The type is not comparable")+  FailOnNonComparable 'True = ()++-- | Alias for comparable types.+type ComparabilityScope t =+  (Typeable t, SingI t, Comparable t)++data Comparability t where+  CanBeCompared :: (Comparable t) => Comparability t+  CannotBeCompared :: (IsComparable t ~ 'False) => Comparability t++checkComparability :: Sing t -> Comparability t+checkComparability = \case+  STPair a b -> case (checkComparability a, checkComparability b) of+    (CanBeCompared, CanBeCompared) -> CanBeCompared+    (CannotBeCompared, _) -> CannotBeCompared+    (_, CannotBeCompared) -> CannotBeCompared+  STKey -> CannotBeCompared+  STUnit -> CannotBeCompared+  STSignature -> CannotBeCompared+  STChainId -> CannotBeCompared+  STOption _ -> CannotBeCompared+  STList _ -> CannotBeCompared+  STSet _ -> CannotBeCompared+  STOperation -> CannotBeCompared+  STContract _ -> CannotBeCompared+  STOr _ _ -> CannotBeCompared+  STLambda _ _ -> CannotBeCompared+  STMap _ _ -> CannotBeCompared+  STBigMap _ _ -> CannotBeCompared+  STInt -> CanBeCompared+  STNat -> CanBeCompared+  STString -> CanBeCompared+  STBytes -> CanBeCompared+  STMutez -> CanBeCompared+  STBool -> CanBeCompared+  STKeyHash -> CanBeCompared+  STTimestamp -> CanBeCompared+  STAddress -> CanBeCompared++comparabilityPresence :: Sing t -> Maybe (Dict $ (Comparable t))+comparabilityPresence s = case checkComparability s of+  CanBeCompared -> Just Dict+  CannotBeCompared -> Nothing++instance SingI t => CheckScope (Comparable t) where+  checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing++instance (Typeable t, SingI t) => CheckScope (ComparabilityScope t) where+  checkScope =+    (\Dict -> Dict) <$> checkScope @(Comparable t)+ -- | Representation of Michelson value. -- -- Type parameter @instr@ stands for Michelson instruction -- type, i.e. data type to represent an instruction of language.  data Value' instr t where-  VC :: CValue t -> Value' instr ('Tc t)   VKey :: PublicKey -> Value' instr 'TKey   VUnit :: Value' instr 'TUnit   VSignature :: Signature -> Value' instr 'TSignature   VChainId :: ChainId -> Value' instr 'TChainId   VOption :: forall t instr. Maybe (Value' instr t) -> Value' instr ('TOption t)   VList :: forall t instr. [Value' instr t] -> Value' instr ('TList t)-  VSet :: forall t instr. Set (CValue t) -> Value' instr ('TSet t)+  VSet :: forall t instr. (Comparable t) => Set (Value' instr t) -> Value' instr ('TSet t)   VOp :: Operation' instr -> Value' instr 'TOperation   VContract :: forall arg instr. Address -> SomeEntryPointCallT arg -> Value' instr ('TContract arg)   VPair :: forall l r instr. (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)   VOr :: forall l r instr. Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)   VLam     :: forall inp out instr.-       ( forall i o.-          ( Show (instr i o)-          , Eq (instr i o)-          , NFData (instr i o)-          )+       ( forall i o. Show (instr i o)+       , forall i o. Eq (instr i o)+       , forall i o. NFData (instr i o)        )     => RemFail instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out)-  VMap :: forall k v instr. Map (CValue k) (Value' instr v) -> Value' instr ('TMap k v)-  VBigMap :: forall k v instr. Map (CValue k) (Value' instr v) -> Value' instr ('TBigMap k v)+  VMap :: forall k v instr. (Comparable k) => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)+  VBigMap :: forall k v instr. (Comparable k) => Map (Value' instr k) (Value' instr v) -> Value' instr ('TBigMap k v)+  VInt       :: Integer ->  Value' instr 'TInt+  VNat       :: Natural -> Value' instr 'TNat+  VString    :: MText -> Value' instr 'TString+  VBytes     :: ByteString -> Value' instr 'TBytes+  VMutez     :: Mutez -> Value' instr 'TMutez+  VBool      :: Bool -> Value' instr 'TBool+  VKeyHash   :: KeyHash -> Value' instr 'TKeyHash+  VTimestamp :: Timestamp -> Value' instr 'TTimestamp+  VAddress   :: EpAddress -> Value' instr 'TAddress  deriving stock instance Show (Value' instr t) deriving stock instance Eq (Value' instr t)@@ -269,4 +414,3 @@  $(deriveGADTNFData ''Operation') $(deriveGADTNFData ''Value')-
src/Michelson/Untyped/Annotation.hs view
@@ -20,6 +20,7 @@   , FieldAnn   , VarAnn   , SomeAnn+  , RootAnn    -- * Creation and conversions   , noAnn@@ -35,7 +36,7 @@   , convAnn   ) where -import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import Data.Char (isAlpha, isAscii, isNumber) import Data.Data (Data(..)) import Data.Default (Default(..))@@ -45,10 +46,11 @@ import Fmt (Buildable(build)) import Instances.TH.Lift () import Language.Haskell.TH.Lift (deriveLift)-import Text.PrettyPrint.Leijen.Text (Doc, (<+>), hsep, textStrict)+import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>)) import qualified Text.Show  import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, printDocS)+import Util.Aeson  -- | Generic Type/Field/Variable Annotation --@@ -91,7 +93,7 @@   { asTypes  :: [TypeAnn]   , asFields :: [FieldAnn]   , asVars   :: [VarAnn]-  } deriving Eq+  } deriving stock Eq  instance Semigroup AnnotationSet where   (AnnotationSet ts1 fs1 vs1) <> (AnnotationSet ts2 fs2 vs2) = AnnotationSet {..}@@ -162,17 +164,26 @@ data VarTag data SomeTag +data RootTag+ type TypeAnn = Annotation TypeTag type FieldAnn = Annotation FieldTag type VarAnn = Annotation VarTag type SomeAnn = Annotation SomeTag +-- | Root annotation was added in the Babylon, it looks the same as+-- field annotation, but has slightly different semantic and can be used+-- only in parameter 'ParameterType'.+type RootAnn = Annotation RootTag+ instance KnownAnnTag FieldTag where   annPrefix = "%" instance KnownAnnTag VarTag where   annPrefix = "@" instance KnownAnnTag TypeTag where   annPrefix = ":"+instance KnownAnnTag RootTag where+  annPrefix = "%"  instance KnownAnnTag tag => RenderDoc (Annotation tag) where   renderDoc _ = renderAnn@@ -288,5 +299,5 @@ pattern WithAnn :: Annotation tag -> Annotation tag pattern WithAnn ann <- ann@(Annotation (toString -> _:_)) -deriveJSON defaultOptions ''Annotation+deriveJSON morleyAesonOptions ''Annotation deriveLift ''Annotation
src/Michelson/Untyped/Contract.hs view
@@ -1,26 +1,25 @@ -- | Michelson contract in untyped model.  module Michelson.Untyped.Contract-  ( Parameter-  , Storage+  ( Storage   , Contract' (..)   ) where -import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import Formatting.Buildable (Buildable(build)) import Text.PrettyPrint.Leijen.Text (nest, semi, (<$$>), (<+>))  import Michelson.Printer.Util   (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList)-import Michelson.Untyped.Type (Type)+import Michelson.Untyped.Type (ParameterType(..), Type(..))+import Util.Aeson -type Parameter = Type type Storage = Type data Contract' op = Contract-  { para :: Parameter-  , stor :: Storage-  , code :: [op]+  { contractParameter :: ParameterType+  , contractStorage :: Storage+  , contractCode :: [op]   } deriving stock (Eq, Show, Functor, Data, Generic)  instance NFData op => NFData (Contract' op)@@ -34,4 +33,4 @@ instance RenderDoc op => Buildable (Contract' op) where   build = buildRenderDoc -deriveJSON defaultOptions ''Contract'+deriveJSON morleyAesonOptions ''Contract'
src/Michelson/Untyped/EntryPoints.hs view
@@ -24,7 +24,7 @@ -- Cannot be equal to "default", the reference implementation forbids that. -- Also, set of allowed characters should be the same as in annotations. newtype EpName = EpNameUnsafe { unEpName :: Text }-  deriving (Show, Eq, Ord, Generic)+  deriving stock (Show, Eq, Ord, Generic)  instance NFData EpName
src/Michelson/Untyped/Ext.hs view
@@ -11,15 +11,16 @@   , stackTypePatternToList   ) where -import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..))-import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T import Fmt (Buildable(build), Builder, genericF, listF)+import Text.PrettyPrint.Leijen.Text (textStrict)  import Michelson.Printer.Util (RenderDoc(..), renderOpsList) import Michelson.Untyped.Type+import Util.Aeson  -- | Implementation-specific instructions embedded in a @NOP@ primitive, which -- mark a specific point during a contract's typechecking or execution.@@ -36,6 +37,7 @@   | FN T.Text StackFn [op]     -- ^ A typed stack function (push and pop a @TcExtFrame@)   | UTEST_ASSERT (TestAssert op)   -- ^ Copy the current stack and run an inline assertion on it   | UPRINT PrintComment         -- ^ Print a comment with optional embedded @StackRef@s+  | UCOMMENT Text        -- ^ A comment in Michelson code   deriving stock (Eq, Show, Data, Generic, Functor)  instance NFData op => NFData (ExtInstrAbstract op)@@ -44,10 +46,12 @@   renderDoc _ =     \case       FN _ _ ops -> renderOpsList False ops+      UCOMMENT t  -> textStrict ("/* " <> t <> " */")       _ -> mempty   isRenderable =     \case       FN {} -> True+      UCOMMENT{} -> True       _ -> False  instance Buildable op => Buildable (ExtInstrAbstract op) where@@ -151,11 +155,11 @@ -- Aeson instances ------------------------------------- -deriveJSON defaultOptions ''ExtInstrAbstract-deriveJSON defaultOptions ''PrintComment-deriveJSON defaultOptions ''StackTypePattern-deriveJSON defaultOptions ''StackRef-deriveJSON defaultOptions ''StackFn-deriveJSON defaultOptions ''Var-deriveJSON defaultOptions ''TyVar-deriveJSON defaultOptions ''TestAssert+deriveJSON morleyAesonOptions ''ExtInstrAbstract+deriveJSON morleyAesonOptions ''PrintComment+deriveJSON morleyAesonOptions ''StackTypePattern+deriveJSON morleyAesonOptions ''StackRef+deriveJSON morleyAesonOptions ''StackFn+deriveJSON morleyAesonOptions ''Var+deriveJSON morleyAesonOptions ''TyVar+deriveJSON morleyAesonOptions ''TestAssert
src/Michelson/Untyped/Instr.hs view
@@ -14,6 +14,7 @@ import Prelude hiding (EQ, GT, LT)  import qualified Data.Aeson as Aeson+import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString.Lazy as BSL import Data.Data (Data(..)) import Fmt (Buildable(build), (+|), (|+))@@ -24,17 +25,17 @@  import Michelson.ErrorPos (InstrCallStack) import Michelson.Printer.Util-  (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, printDocS,-  renderOpsList, spaces)+  (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, printDocS, renderOpsList, spaces) import Michelson.Untyped.Annotation   (Annotation, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, singleAnnSet) import Michelson.Untyped.Contract (Contract'(..)) import Michelson.Untyped.Ext (ExtInstrAbstract)-import Michelson.Untyped.Type (Comparable, Type)+import Michelson.Untyped.Type (Type) import Michelson.Untyped.Value (Value'(..)) import Tezos.Address (Address, mkContractAddressRaw) import Tezos.Core (Mutez) import Tezos.Crypto (KeyHash)+import Util.Aeson  ------------------------------------- -- Types after macroexpander@@ -129,9 +130,9 @@   | CONS              VarAnn -- TODO add TypeNote param   | IF_CONS           [op] [op]   | SIZE              VarAnn-  | EMPTY_SET         TypeAnn VarAnn Comparable-  | EMPTY_MAP         TypeAnn VarAnn Comparable Type-  | EMPTY_BIG_MAP     TypeAnn VarAnn Comparable Type+  | EMPTY_SET         TypeAnn VarAnn Type+  | EMPTY_MAP         TypeAnn VarAnn Type Type+  | EMPTY_BIG_MAP     TypeAnn VarAnn Type Type   | MAP               VarAnn [op]   | ITER              [op]   | MEM               VarAnn@@ -188,7 +189,6 @@   | SHA512            VarAnn   | BLAKE2B           VarAnn   | HASH_KEY          VarAnn-  | STEPS_TO_QUOTA    VarAnn   | SOURCE            VarAnn   | SENDER            VarAnn   | ADDRESS           VarAnn@@ -284,14 +284,13 @@     SHA512 va               -> "SHA512" <+> renderAnnot va     BLAKE2B va              -> "BLAKE2B" <+> renderAnnot va     HASH_KEY va             -> "HASH_KEY" <+> renderAnnot va-    STEPS_TO_QUOTA va       -> "STEPS_TO_QUOTA" <+> renderAnnot va     SOURCE va               -> "SOURCE" <+> renderAnnot va     SENDER va               -> "SENDER" <+> renderAnnot va     ADDRESS va              -> "ADDRESS" <+> renderAnnot va     CHAIN_ID va             -> "CHAIN_ID" <+> renderAnnot va     where       renderTy = renderDoc @Type needsParens-      renderComp = renderDoc @Comparable needsParens+      renderComp = renderDoc @Type needsParens       renderOps = renderOpsList False        renderAnnot :: KnownAnnTag tag => Annotation tag -> Doc@@ -343,9 +342,6 @@ -- JSON serialization ---------------------------------------------------------------------------- -instance Aeson.ToJSON ExpandedOp-instance Aeson.FromJSON ExpandedOp-instance Aeson.ToJSON op => Aeson.ToJSON (InstrAbstract op)-instance Aeson.FromJSON op => Aeson.FromJSON (InstrAbstract op)-instance Aeson.FromJSON OriginationOperation-instance Aeson.ToJSON OriginationOperation+deriveJSON morleyAesonOptions ''ExpandedOp+deriveJSON morleyAesonOptions ''InstrAbstract+deriveJSON morleyAesonOptions ''OriginationOperation
src/Michelson/Untyped/Type.hs view
@@ -2,20 +2,8 @@  module Michelson.Untyped.Type   ( Type (..)-  , Comparable (..)-  , compToType-  , typeToComp   , T (..)-  , CT (..)-  , pattern Tint-  , pattern Tnat-  , pattern Tstring-  , pattern Tbytes-  , pattern Tmutez-  , pattern Tbool-  , pattern Tkey_hash-  , pattern Ttimestamp-  , pattern Taddress+  , ParameterType (..)   , tint   , tnat   , tstring@@ -48,9 +36,11 @@   , isNat   , isInt   , isBytes+  , renderType+  , unwrapT   ) where -import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import Formatting.Buildable (Buildable(build)) import Language.Haskell.TH.Lift (deriveLift)@@ -61,19 +51,19 @@   (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens,   needsParens, wrapInParens) import Michelson.Untyped.Annotation-  (AnnotationSet, FieldAnn, TypeAnn, emptyAnnSet, fullAnnSet, noAnn, singleAnnSet)+  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, convAnn, emptyAnnSet, fullAnnSet, noAnn,+  singleAnnSet)+import Util.Aeson  -- Annotated type data Type   = Type ~T TypeAnn   deriving stock (Eq, Show, Data, Generic) -instance NFData Type+unwrapT :: Type -> T+unwrapT (Type t _) = t -instance RenderDoc Comparable where-  renderDoc np (Comparable ct ta) =-    addParens np $-    renderCT ct <+> renderDoc doesntNeedParens (singleAnnSet ta)+instance NFData Type  instance RenderDoc (Prettier Type) where   renderDoc pn (Prettier w) = case w of@@ -85,6 +75,21 @@ instance RenderDoc T where   renderDoc pn t = renderType t True pn emptyAnnSet +-- | Since Babylon parameter type can have special root annotation.+data ParameterType = ParameterType Type RootAnn+  deriving stock (Eq, Show, Data, Generic)++instance NFData ParameterType++instance RenderDoc (Prettier ParameterType) where+  renderDoc pn (Prettier w) = case w of+    ParameterType (Type t ta) ra ->+      renderType t False pn (fullAnnSet [ta] [convAnn ra] [])++instance RenderDoc ParameterType where+  renderDoc pn (ParameterType (Type t ta) ra) =+    renderType t True pn (fullAnnSet [ta] [convAnn ra] [])+ -- Ordering between different kinds of annotations is not significant, -- but ordering among annotations of the same kind is. Annotations -- of a same kind must be grouped together.@@ -107,7 +112,15 @@         else align $ softbreak <> (d1 <$> d2)   in   case t of-    Tc ct             -> wrapInParens pn $ renderCT ct :| [annDoc]+    TInt              -> wrapInParens pn $ "int" :| [annDoc]+    TNat              -> wrapInParens pn $ "nat" :| [annDoc]+    TString           -> wrapInParens pn $ "string" :| [annDoc]+    TMutez            -> wrapInParens pn $ "mutez" :| [annDoc]+    TBool             -> wrapInParens pn $ "bool" :| [annDoc]+    TKeyHash          -> wrapInParens pn $ "key_hash" :| [annDoc]+    TTimestamp        -> wrapInParens pn $ "timestamp" :| [annDoc]+    TBytes            -> wrapInParens pn $ "bytes" :| [annDoc]+    TAddress          -> wrapInParens pn $ "address" :| [annDoc]     TKey              -> wrapInParens pn $ "key"  :| [annDoc]     TUnit             -> wrapInParens pn $ "unit" :| [annDoc]     TSignature        -> wrapInParens pn $ "signature" :| [annDoc]@@ -122,9 +135,9 @@       addParens pn $       "list" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1) -    TSet (Comparable ct1 ta1) ->+    TSet (Type t1 ta1) ->       addParens pn $-      "set" <+> annDoc <+> recRenderer (Tc ct1) (singleAnnSet ta1)+      "set" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)      TContract (Type t1 ta1)   ->       addParens pn $@@ -151,71 +164,51 @@             (recRenderer t1 $ singleAnnSet ta1)             (recRenderer t2 $ singleAnnSet ta2) -    TMap (Comparable ct1 ta1) (Type t2 ta2) ->+    TMap (Type t1 ta1) (Type t2 ta2) ->       addParens pn $         "map" <+> annDoc <+>           renderBranches-            (recRenderer (Tc ct1) $ singleAnnSet ta1)+            (recRenderer t1 $ singleAnnSet ta1)             (recRenderer t2 $ singleAnnSet ta2) -    TBigMap (Comparable ct1 ta1) (Type t2 ta2) ->+    TBigMap (Type t1 ta1) (Type t2 ta2) ->       addParens pn $         "big_map" <+> annDoc <+>           renderBranches-            (recRenderer (Tc ct1) $ singleAnnSet ta1)+            (recRenderer t1 $ singleAnnSet ta1)             (recRenderer t2 $ singleAnnSet ta2) -renderCT :: CT -> Doc-renderCT = \case-  CInt       -> "int"-  CNat       -> "nat"-  CString    -> "string"-  CMutez     -> "mutez"-  CBool      -> "bool"-  CKeyHash   -> "key_hash"-  CTimestamp -> "timestamp"-  CBytes     -> "bytes"-  CAddress   -> "address"--instance RenderDoc CT where-  renderDoc _ = renderCT- instance Buildable Type where   build = buildRenderDoc --- Annotated Comparable Sub-type-data Comparable = Comparable CT TypeAnn-  deriving stock (Eq, Show, Data, Generic)--instance Buildable Comparable where+instance Buildable ParameterType where   build = buildRenderDoc -instance NFData Comparable--compToType :: Comparable -> Type-compToType (Comparable ct tn) = Type (Tc ct) tn--typeToComp :: Type -> Maybe Comparable-typeToComp (Type (Tc ct) tn) = Just $ Comparable ct tn-typeToComp _ = Nothing- -- Michelson Type data T =-    Tc CT-  | TKey+    TKey   | TUnit   | TSignature   | TChainId   | TOption Type   | TList Type-  | TSet Comparable+  | TSet Type   | TOperation   | TContract Type   | TPair FieldAnn FieldAnn Type Type   | TOr FieldAnn FieldAnn Type Type   | TLambda Type Type-  | TMap Comparable Type-  | TBigMap Comparable Type+  | TMap Type Type+  | TBigMap Type Type+  | TInt+  | TNat+  | TString+  | TBytes+  | TMutez+  | TBool+  | TKeyHash+  | TTimestamp+  | TAddress   deriving stock (Eq, Show, Data, Generic)  instance Buildable T where@@ -223,77 +216,32 @@  instance NFData T --- Comparable Sub-Type-data CT =-    CInt-  | CNat-  | CString-  | CBytes-  | CMutez-  | CBool-  | CKeyHash-  | CTimestamp-  | CAddress-  deriving stock (Eq, Ord, Show, Data, Enum, Bounded, Generic)--instance Buildable CT where-  build = buildRenderDoc--instance NFData CT--pattern Tint :: T-pattern Tint = Tc CInt--pattern Tnat :: T-pattern Tnat = Tc CNat--pattern Tstring :: T-pattern Tstring = Tc CString--pattern Tbytes :: T-pattern Tbytes = Tc CBytes--pattern Tmutez :: T-pattern Tmutez = Tc CMutez--pattern Tbool :: T-pattern Tbool = Tc CBool--pattern Tkey_hash :: T-pattern Tkey_hash = Tc CKeyHash--pattern Ttimestamp :: T-pattern Ttimestamp = Tc CTimestamp--pattern Taddress :: T-pattern Taddress = Tc CAddress- tint :: T-tint = Tc CInt+tint = TInt  tnat :: T-tnat = Tc CNat+tnat = TNat  tstring :: T-tstring = Tc CString+tstring = TString  tbytes :: T-tbytes = Tc CBytes+tbytes = TBytes  tmutez :: T-tmutez = Tc CMutez+tmutez = TMutez  tbool :: T-tbool = Tc CBool+tbool = TBool  tkeyHash :: T-tkeyHash = Tc CKeyHash+tkeyHash = TKeyHash  ttimestamp :: T-ttimestamp = Tc CTimestamp+ttimestamp = TTimestamp  taddress :: T-taddress = Tc CAddress+taddress = TAddress  toption :: Type -> T toption t = TOption t@@ -349,54 +297,61 @@ isOperation _                    = False  isComparable :: Type -> Bool-isComparable (Type (Tc _) _) = True-isComparable _ = False+isComparable (Type t _) = case t of+  TInt -> True+  TNat -> True+  TString -> True+  TBytes -> True+  TMutez -> True+  TBool -> True+  TKeyHash -> True+  TTimestamp -> True+  TAddress -> True+  _ -> False  isMutez :: Type -> Bool-isMutez (Type (Tc CMutez) _) = True+isMutez (Type TMutez _) = True isMutez _ = False  isTimestamp :: Type -> Bool-isTimestamp (Type (Tc CTimestamp) _) = True+isTimestamp (Type TTimestamp _) = True isTimestamp _ = False  isKeyHash :: Type -> Bool-isKeyHash (Type (Tc CKeyHash) _) = True+isKeyHash (Type TKeyHash _) = True isKeyHash _ = False  isBool  :: Type -> Bool-isBool (Type (Tc CBool) _) = True+isBool (Type TBool _) = True isBool _ = False  isString  :: Type -> Bool-isString (Type (Tc CString) _) = True+isString (Type TString _) = True isString _ = False  isInteger :: Type -> Bool isInteger a = isNat a || isInt a || isMutez a || isTimestamp a  isNat  :: Type -> Bool-isNat (Type (Tc CNat) _) = True+isNat (Type TNat _) = True isNat _ = False  isInt  :: Type -> Bool-isInt (Type (Tc CInt) _) = True+isInt (Type TInt _) = True isInt _ = False  isBytes :: Type -> Bool-isBytes (Type (Tc CBytes) _) = True+isBytes (Type TBytes _) = True isBytes _ = False  ---------------------------------------------------------------------------- -- TH derivations ---------------------------------------------------------------------------- -deriveJSON defaultOptions ''Type-deriveJSON defaultOptions ''Comparable-deriveJSON defaultOptions ''T-deriveJSON defaultOptions ''CT+deriveJSON morleyAesonOptions ''Type+deriveJSON morleyAesonOptions ''T+deriveJSON morleyAesonOptions ''ParameterType  deriveLift ''Type-deriveLift ''Comparable deriveLift ''T-deriveLift ''CT+deriveLift ''ParameterType
src/Michelson/Untyped/Value.hs view
@@ -9,7 +9,7 @@   ) where  import Data.Aeson (FromJSON(..), ToJSON(..), withText)-import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import Formatting.Buildable (Buildable(build)) import Text.Hex (decodeHex, encodeHex)@@ -19,6 +19,7 @@ import Michelson.Printer.Util   (RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, renderOps) import Michelson.Text+import Util.Aeson  data Value' op =     ValueInt     Integer@@ -116,5 +117,5 @@         Nothing -> fail "Invalid hex encoding"         Just res -> pure (InternalByteString res) -deriveJSON defaultOptions ''Value'-deriveJSON defaultOptions ''Elt+deriveJSON morleyAesonOptions ''Value'+deriveJSON morleyAesonOptions ''Elt
src/Morley/Micheline.hs view
@@ -5,17 +5,18 @@   , FromExpression (..)   ) where -import Data.Sequence (fromList)+import Data.Sequence (fromList, (|>)) import Data.Singletons (pattern FromSing, Sing, SingI, withSingI) import Tezos.Common.Binary (decode, encode) import Tezos.V005.Micheline-  (Expression(..), MichelinePrimAp(..), MichelinePrimitive(..))+  (Annotation(..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..))  import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT') import Michelson.Interpret.Unpack (unpackInstr', unpackValue') import Michelson.Typed-  (FullContract(..), HasNoOp, Instr(..), Notes(..), T(..), Value, unParamNotes)+  (FullContract(..), HasNoOp, Instr(..), Notes(..), T(..), Value, pnNotes, pnRootAnn) import Michelson.Typed.Scope (UnpackedValScope)+import Michelson.Untyped.Annotation (Annotation(..), RootAnn) import Michelson.Untyped.Instr (ExpandedOp)  -- | Type class that provides an ability to convert@@ -40,7 +41,9 @@   toExpression FullContract{..} = Expression_Seq $ fromList     [ Expression_Prim $       MichelinePrimAp (MichelinePrimitive "parameter")-      (fromList [toExpression $ unParamNotes $ fcParamNotesSafe])+      (fromList [ addRootAnnToExpression (pnRootAnn fcParamNotes) $+                  toExpression $ pnNotes fcParamNotes+                ])       (fromList [])     , Expression_Prim $       MichelinePrimAp (MichelinePrimitive "storage")@@ -51,6 +54,14 @@       (fromList [toExpression fcCode])       (fromList [])     ]+    where+      addRootAnnToExpression :: RootAnn -> Expression -> Expression+      addRootAnnToExpression rootAnn = \case+        Expression_Prim p -> Expression_Prim+          p{ _michelinePrimAps_annots = _michelinePrimAps_annots p |>+             (Annotation_Field $ unAnnotation $ rootAnn)+           }+        x -> x  -- | Type class that provides the ability to convert -- something from a Micheline Expression.
src/Tezos/Core.hs view
@@ -41,7 +41,7 @@  import Data.Aeson (FromJSON(..), ToJSON(..)) import qualified Data.Aeson as Aeson-import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString as BS import Data.Data (Data(..)) import qualified Data.Text as T@@ -59,6 +59,7 @@  import Michelson.Text import Tezos.Crypto+import Util.Aeson import Util.CLI  ----------------------------------------------------------------------------@@ -332,8 +333,8 @@ -- JSON ---------------------------------------------------------------------------- -deriveJSON defaultOptions ''Mutez-deriveJSON defaultOptions ''Timestamp+deriveJSON morleyAesonOptions ''Mutez+deriveJSON morleyAesonOptions ''Timestamp  instance ToJSON ChainId where   toJSON = Aeson.String . formatChainId
+ src/Util/Aeson.hs view
@@ -0,0 +1,13 @@+-- | Utilities related to the @aeson@ package.++module Util.Aeson+  ( morleyAesonOptions+  ) where++import Data.Aeson.Casing (aesonPrefix, camelCase)+import Data.Aeson.TH (Options)++-- | Options that we use in @morley@-based packages (including+-- @morley@) by default.+morleyAesonOptions :: Options+morleyAesonOptions = aesonPrefix camelCase
src/Util/Instances.hs view
@@ -4,7 +4,6 @@ module Util.Instances () where  import Data.Default (Default(..))-import Data.Functor.Identity (Identity(..)) import Fmt (Buildable(..))  instance Default Natural where
src/Util/Label.hs view
@@ -11,8 +11,7 @@   ) where  import Fmt (Buildable(..), pretty)-import GHC.OverloadedLabels (IsLabel(..))-import Text.Show(Show(..))+import Text.Show (Show(..))  import Util.TypeLits @@ -24,7 +23,7 @@ data Label (name :: Symbol) where   Label :: KnownSymbol name => Label name -deriving instance Eq (Label name)+deriving stock instance Eq (Label name)  instance Show (Label name) where   show label = "Label " <> pretty label
src/Util/Peano.hs view
@@ -22,7 +22,7 @@   , ToPeano   , FromPeano   , KnownPeano (..)-  , Sing (SZ, SS)+  , SingNat (SZ, SS)   , peanoVal'   , peanoValSing @@ -45,7 +45,7 @@   , requireLongerOrSameLength   ) where -import Data.Constraint (Dict (..))+import Data.Constraint (Dict(..)) import Data.Singletons (Sing, SingI(..)) import Data.Type.Bool (If) import Data.Vinyl (Rec(..))@@ -87,16 +87,18 @@ peanoValSing :: forall n. KnownPeano n => Sing n -> Natural peanoValSing _ = peanoVal' @n -data instance Sing (_ :: Nat) where-  SZ :: Sing 'Z-  SS :: (SingI n, KnownPeano n) => Sing n -> Sing ('S n)+data SingNat (n :: Nat) where+  SZ :: SingNat 'Z+  SS :: (SingI n, KnownPeano n) => SingNat n -> SingNat ('S n) -deriving stock instance Show (Sing (n :: Nat))-deriving stock instance Eq (Sing (n :: Nat))-instance NFData (Sing (n :: Nat)) where+deriving stock instance Show (SingNat (n :: Nat))+deriving stock instance Eq (SingNat (n :: Nat))+instance NFData (SingNat (n :: Nat)) where   rnf SZ = ()   rnf (SS n) = rnf n +type instance Sing = SingNat+ instance SingI 'Z where   sing = SZ instance (SingI n, KnownPeano n) => SingI ('S n) where@@ -202,7 +204,7 @@  class (RequireLongerThan' l a, LongerThan l a) =>   RequireLongerThan (l :: [k]) (a :: Peano)-instance RequireLongerThan' l a => LongerThan l a =>+instance (RequireLongerThan' l a, LongerThan l a) =>   RequireLongerThan l a  -- | 'IsLongerOrSameLength' in form of constraint that produces@@ -229,7 +231,7 @@ -- Y (using multiple `=>`s) then X will always be evaluated first. class (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>   RequireLongerOrSameLength (l :: [k]) (a :: Peano)-instance RequireLongerOrSameLength' l a => LongerOrSameLength l a =>+instance (RequireLongerOrSameLength' l a, LongerOrSameLength l a) =>   RequireLongerOrSameLength l a  ----------------------------------------------------------------------------
src/Util/Test/Arbitrary.hs view
@@ -7,7 +7,7 @@ import Prelude hiding (EQ, GT, LT)  import Test.QuickCheck-  (Arbitrary(..), Gen, choose, elements, frequency, oneof, resize, suchThatMap, vector)+  (Arbitrary(..), Gen, choose, frequency, oneof, resize, suchThatMap, vector) import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..)) import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Instances.ByteString ()@@ -19,9 +19,9 @@ import Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..)) import Michelson.Test () import Michelson.Untyped-  (Annotation, CT(..), Comparable(..), Contract'(..), Elt(..), ExpandedExtInstr, ExpandedOp(..),-  ExtInstrAbstract(..), InstrAbstract(..), InternalByteString(..), StackTypePattern(..), T(..),-  TyVar(..), Type(..), Value'(..), Var(..), mkAnnotation)+  (Annotation, Contract'(..), Elt(..), ExpandedExtInstr, ExpandedOp(..),+  ExtInstrAbstract(..), InstrAbstract(..), InternalByteString(..), ParameterType(..),+  StackTypePattern(..), T(..), TyVar(..), Type(..), Value'(..), Var(..), mkAnnotation) import Tezos.Core (Mutez(..))  instance Arbitrary InternalByteString where@@ -160,7 +160,6 @@       , SHA512 <$> arbitrary       , BLAKE2B <$> arbitrary       , HASH_KEY <$> arbitrary-      , STEPS_TO_QUOTA <$> arbitrary       , SOURCE <$> arbitrary       , SENDER <$> arbitrary       , ADDRESS <$> arbitrary@@ -195,6 +194,10 @@ instance Arbitrary Type where   arbitrary = Type <$> arbitrary <*> arbitrary +instance ToADTArbitrary ParameterType+instance Arbitrary ParameterType where+  arbitrary = ParameterType <$> arbitrary <*> arbitrary+ -- | @getRareT k@ generates 'T' producing anything big once per @1 / (k + 1)@ -- invocation. genRareType :: Word -> Gen Type@@ -204,8 +207,7 @@ instance Arbitrary T where   arbitrary =     oneof-      [ Tc <$> arbitrary-      , pure TKey+      [ pure TKey       , pure TUnit       , pure TSignature       , TOption <$> arbitrary@@ -226,14 +228,6 @@ -- Useful to avoid exponensial growth. genRareT :: Word -> Gen T genRareT k = frequency [(1, arbitrary), (fromIntegral k, pure TUnit)]--instance ToADTArbitrary CT-instance Arbitrary CT where-  arbitrary = elements [minBound .. maxBound]--instance ToADTArbitrary Comparable-instance Arbitrary Comparable where-  arbitrary = Comparable <$> arbitrary <*> arbitrary  -- | Run given generator deterministically. runGen :: Int -> Gen a -> a
src/Util/Type.hs view
@@ -27,6 +27,9 @@   , recordToSomeList    , reifyTypeEquality++  , ConcatListOfTypesAssociativity+  , listOfTypesConcatAssociativityAxiom   ) where  import Data.Constraint ((:-)(..), Dict(..))@@ -155,3 +158,14 @@  recordToSomeList :: Rec f l -> [Some1 f] recordToSomeList = recordToList . rmap (Vinyl.Const . Some1)++type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))++-- | GHC can't deduce this itself because+-- in general a type family might be not associative,+-- what brings extra difficulties and redundant constraints,+-- especially if you have complex types.+-- But (++) type family is associative, so let's define this small hack.+listOfTypesConcatAssociativityAxiom :: forall a b c . Dict (ConcatListOfTypesAssociativity a b c)+listOfTypesConcatAssociativityAxiom =+  unsafeCoerce $ Dict @(ConcatListOfTypesAssociativity '[] '[] '[])
src/Util/Typeable.hs view
@@ -17,10 +17,10 @@   , eqT   ) where -import Data.Typeable ((:~:)(..), Typeable, eqT, gcast, typeRep)-import qualified Type.Reflection as Refl import Data.Coerce (coerce)+import Data.Typeable ((:~:)(..), eqT, gcast, typeRep) import Fmt ((+||), (||+))+import qualified Type.Reflection as Refl  -- | Like 'gcast', casts some container's elements, -- producing informative error on mismatch.
test/Test/Analyzer.hs view
@@ -13,7 +13,6 @@ import Michelson.Text import qualified Michelson.Typed as T import Michelson.Typed.Instr-import Michelson.Untyped (CT(..))  unit_Sample_analyze :: Assertion unit_Sample_analyze = analyze sample @?= expectedRes@@ -30,7 +29,7 @@ str3 :: MText str3 = [mt|bb|] -sample :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString)+sample :: T.ContractCode 'T.TString 'T.TString sample =   CAR `Seq` DUP `Seq`   pushStr str3 `Seq`@@ -42,12 +41,12 @@   pushTrue `Seq`   IF (pushStr str1 `Seq` FAILWITH)      pushTrue `Seq`-  IF (pushStr str1 `Seq` PAIR `Seq` FAILWITH)+  IF (Seq NOW $ Seq DROP $ pushStr str1 `Seq` (PAIR `Seq` FAILWITH))      Nop `Seq`-  PUSH (T.VPair (T.VC $ T.CvString str3, T.VUnit)) `Seq` FAILWITH+  PUSH (T.VPair (T.VString str3, T.VUnit)) `Seq` FAILWITH   where-    pushStr :: forall s. MText -> Instr s ('T.Tc 'CString ': s)-    pushStr str = PUSH (T.VC $ T.CvString str)+    pushStr :: forall s. MText -> Instr s ('T.TString ': s)+    pushStr str = PUSH (T.VString str) -    pushTrue :: forall s. Instr s ('T.Tc 'CBool ': s)-    pushTrue = PUSH (T.VC $ T.CvBool True)+    pushTrue :: forall s. Instr s ('T.TBool ': s)+    pushTrue = PUSH (T.VBool True)
− test/Test/CValConversion.hs 
@@ -1,34 +0,0 @@--- | Testing of toCVal / fromCVal conversions--module Test.CValConversion-  ( unit_toCVal-  , unit_fromCVal-  , test_Roundtrip-  ) where--import Test.Hspec.Expectations (Expectation, shouldBe)-import Test.Tasty (TestTree)-import Test.Tasty.QuickCheck (testProperty, (===))--import Michelson.Typed (CValue(..), fromCVal, toCVal)-import Michelson.Text--unit_toCVal :: Expectation-unit_toCVal = do-  toCVal @Integer 10 `shouldBe` CvInt 10-  toCVal @Integer (-10) `shouldBe` CvInt (-10)-  toCVal @Natural 10 `shouldBe` CvNat 10-  toCVal [mt|abc|] `shouldBe` CvString [mt|abc|]-  toCVal True `shouldBe` CvBool True--unit_fromCVal :: Expectation-unit_fromCVal = do-  fromCVal (CvInt 10) `shouldBe` (10 :: Integer)-  fromCVal (CvString [mt|abc|]) `shouldBe` [mt|abc|]-  fromCVal (CvBool True) `shouldBe` True--test_Roundtrip :: [TestTree]-test_Roundtrip =-  [ testProperty "Integer" $ \v -> fromCVal (toCVal @Integer v) === v-  , testProperty "Bool" $ \v -> fromCVal (toCVal @Bool v) === v-  ]
test/Test/EntryPoints.hs view
@@ -49,29 +49,29 @@ test_ParamNotes =   [ testGroup "Duplications are handled" $     [ testCase "One duplicated entrypoint" $-        mkParamNotes (or "a" "a" prim prim)+        mkParamNotes (or "a" "a" prim prim) noAnn           @?= Left (ParamEpDuplicatedNames (EpNameUnsafe "a" :| []))     , testCase "Several duplicated entrypoint" $-        mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim))+        mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn           @?= Left (ParamEpDuplicatedNames (EpNameUnsafe "a" :| [EpNameUnsafe "b"]))     , testCase "Duplicated default entrypoint" $-        mkParamNotes (or "default" "default" prim prim)+        mkParamNotes (or "default" "default" prim prim) noAnn           @?= Left (ParamEpDuplicatedNames (DefEpName :| []))     ]    , testGroup "All entrypoints callable check" $     [ testCase "Non-callable entrypoint is detected in simple case" $-        mkParamNotes (or "default" "" prim (or "" "q" prim prim))+        mkParamNotes (or "default" "" prim (or "" "q" prim prim)) noAnn           @?= Left (ParamEpUncallableArm [AcRight, AcLeft])     , testCase "Non-callable entrypoint is detected in complex case" $-        mkParamNotes (or "a" "" prim (or "" "default" (or "b" "" prim prim) prim))+        mkParamNotes (or "a" "" prim (or "" "default" (or "b" "" prim prim) prim)) noAnn           @?= Left (ParamEpUncallableArm [AcRight, AcLeft, AcRight])      , testCase "Having all leaves named is enough for callability" $-        mkParamNotes (or "default" "" prim (or "q" "" prim (or "a" "b" prim prim)))+        mkParamNotes (or "default" "" prim (or "q" "" prim (or "a" "b" prim prim))) noAnn           & assertBool "All arms should've considered callable" . isRight     , testCase "Having all leaves named is enough for callability" $-        mkParamNotes (or "default" "a" prim (or "" "" prim (or "" "" prim prim)))+        mkParamNotes (or "default" "a" prim (or "" "" prim (or "" "" prim prim))) noAnn           & assertBool "All arms should've considered callable" . isRight     ]   ]
test/Test/Ext.hs view
@@ -12,12 +12,12 @@ import Michelson.Interpret (InterpreterState(..), MorleyLogs(..), interpret) import Michelson.Test (concatTestTrees, testTreesWithTypedContract) import Michelson.Test.Dummy (dummyContractEnv)-import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheck, typeCheckExt, typeCheckList)-import Michelson.Typed (pattern AsUType, CValue(..), epcPrimitive)+import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheck, typeCheckExt, typeCheckList, getWTP)+import Michelson.Typed (pattern AsUType, epcPrimitive) import qualified Michelson.Typed as T import Michelson.Untyped-  (CT(..), ExpandedExtInstr, ExtInstrAbstract(..), StackTypePattern(..), T(..), TyVar(..),-  Type(..), ann, noAnn)+  (ExpandedExtInstr, ExtInstrAbstract(..), StackTypePattern(..), ParameterType(..),+  T(..), TyVar(..), Type(..), ann, noAnn)  import Test.Util.Contracts @@ -39,9 +39,9 @@       ]      runTest corr contract x y = do-      let x' = T.VC $ T.CvInt x :: T.Value ('T.Tc 'T.CInt)-      let y' = T.VC $ T.CvInt y :: T.Value ('T.Tc 'T.CInt)-      let area' = T.VC $ CvInt $ x * y :: T.Value ('T.Tc 'T.CInt)+      let x' = T.VInt x :: T.Value 'T.TInt+      let y' = T.VInt y :: T.Value 'T.TInt+      let area' = T.VInt $ x * y :: T.Value 'T.TInt       let check (a, InterpreterState s _) =             if corr then isRight a && s == MorleyLogs ["Area is " <> show area']             else isLeft a && s == MorleyLogs ["Sides are " <> show x' <> " x " <> show y']@@ -77,16 +77,18 @@      t1 = Type (TOption (Type TKey (ann "key"))) (ann "opt")     t2 = Type (TPair (ann "f") (ann "s") (Type TUnit "x") (Type TSignature "s")) noAnn-    t3 = Type (Tc CInt) (ann "tint")+    t3 = Type TInt (ann "tint")      convertToHST :: [Type] -> SomeHST     convertToHST [] = SomeHST SNil-    convertToHST (AsUType nt : ts) =+    convertToHST (AsUType (nt :: T.Notes t1) : ts) =       case convertToHST ts of-        SomeHST is -> SomeHST ((nt, noAnn) ::& is)+        SomeHST is -> case getWTP @t1 of+          Just T.Dict -> SomeHST ((nt, T.Dict, noAnn) ::& is)+          Nothing -> error "Type is not well typed"      nh (ni, si) =-      runTypeCheck (Type TKey noAnn) mempty $ usingReaderT def $ typeCheckExt typeCheckList ni si+      runTypeCheck (ParameterType (Type TKey noAnn) noAnn) mempty $ usingReaderT def $ typeCheckExt typeCheckList ni si      runExtTest :: (ExpandedExtInstr, SomeHST) -> Bool -> Assertion     runExtTest (ui, SomeHST hst) correct = case (nh (ui, hst), correct) of
test/Test/Integrational.hs view
@@ -17,7 +17,7 @@       let code = DROP `Seq` CHAIN_ID `Seq` NIL `Seq` PAIR       let contract = FullContract             { fcCode = code-            , fcParamNotesSafe = ParamNotesUnsafe (starNotes @'TUnit)+            , fcParamNotes = starParamNotes @'TUnit             , fcStoreNotes = starNotes             }       let chainId = mkChainIdUnsafe "aaaa"
test/Test/Interpreter.hs view
@@ -8,7 +8,6 @@   , test_lsl   , test_lsr   , test_FAILWITH-  , test_STEPS_TO_QUOTA   , test_gas_exhaustion   , test_add1_list   , test_Sum_types@@ -21,23 +20,20 @@   ) where  import Fmt (pretty)-import System.FilePath ((</>))-import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy)+import Test.Hspec.Expectations (Expectation, shouldSatisfy) import Test.HUnit (assertFailure) import Test.QuickCheck (Property, label, (.&&.), (===)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Test.Tasty.QuickCheck (testProperty) -import Michelson.Interpret-  (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps, interpret)-import Michelson.Test-  (ContractPropValidator, concatTestTrees, contractProp, testTreesWithTypedContract, validateStorageIs)+import Michelson.Interpret (MichelsonFailed(..), interpret)+import Michelson.Test (concatTestTrees, testTreesWithTypedContract) import Michelson.Test.Dummy (dummyContractEnv)-import Michelson.Test.Util (failedProp) import Michelson.Test.Unit+import Michelson.Test.Util (failedProp) import Michelson.Text-import Michelson.Typed (CT(..), CValue(..), IsoValue(..), T(..), epcPrimitive)+import Michelson.Typed (IsoValue(..), T(..), epcPrimitive) import qualified Michelson.Typed as T import Tezos.Address import Tezos.Crypto@@ -149,22 +145,6 @@     ]   ] -test_STEPS_TO_QUOTA :: IO [TestTree]-test_STEPS_TO_QUOTA = concatTestTrees-  [ testTreesWithTypedContract (contractsDir </> "deprecated/steps_to_quota_test1.tz") $ \contract ->-    pure-    [ testCase "Amount of steps should decrease (1)" $ do-      validateStepsToQuotaTest-        (interpretSimple contract () (0 :: Natural)) 4-    ]-  , testTreesWithTypedContract (contractsDir </> "deprecated/steps_to_quota_test2.tz") $ \contract ->-    pure-    [ testCase "Amount of steps should decrease (2)" $ do-      validateStepsToQuotaTest-        (interpretSimple contract () (0 :: Natural)) 8-    ]-  ]- test_gas_exhaustion :: IO [TestTree] test_gas_exhaustion =   testTreesWithTypedContract (contractsDir </> "gas_exhaustion.tz") $ \contract -> pure@@ -335,17 +315,9 @@ ----------------------------------------------------------------------------  validateBasic1-  :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property+  :: [Integer] -> ContractPropValidator ('TList 'TInt) Property validateBasic1 input (Right (ops, res), _) =     (fromVal res === [sum input + 12, 100])     .&&.     (label "returned no ops" $ null ops) validateBasic1 _ (Left e, _) = failedProp $ show e--validateStepsToQuotaTest ::-  ContractReturn ('Tc 'CNat) -> RemainingSteps -> Expectation-validateStepsToQuotaTest res numOfSteps =-  case fst res of-    Right ([], T.VC (CvNat x)) ->-      (fromInteger . toInteger) x `shouldBe` ceMaxSteps dummyContractEnv - numOfSteps-    _ -> expectationFailure "unexpected contract result"
test/Test/Interpreter/Apply.hs view
@@ -22,7 +22,7 @@    contractPropVal     applyContract (validateStorageIs @Integer 2)-    dummyContractEnv (VLam $ RfNormal lam) (VC $ CvInt 0)+    dummyContractEnv (VLam $ RfNormal lam) (VInt 0)  unit_Partially_applied_lambda_packed :: Assertion unit_Partially_applied_lambda_packed = do
test/Test/Interpreter/Auction.hs view
@@ -17,7 +17,7 @@   (ContractPropValidator, contractProp, midTimestamp, testTreesWithTypedContract) import Michelson.Test.Dummy import Michelson.Test.Util (failedProp)-import Michelson.Typed (CValue(..), Operation'(..), ToT, TransferTokens(..))+import Michelson.Typed (Operation'(..), ToT, TransferTokens(..)) import qualified Michelson.Typed as T import Tezos.Address (Address(..)) import Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, unMutez, unsafeMkMutez, unsafeSubMutez)@@ -109,15 +109,15 @@   | Left e <- resE       = failedProp $ "Unexpected script fail: " <> show e -  | Right (_, (T.VPair ( T.VC (CvTimestamp endOfAuction'), _))) <- resE+  | Right (_, (T.VPair ( T.VTimestamp endOfAuction', _))) <- resE   , endOfAuction /= endOfAuction'       = failedProp "End of auction timestamp of contract changed" -  | Right (_, (T.VPair (_, T.VPair (T.VC (CvMutez amount'), _)))) <- resE+  | Right (_, (T.VPair (_, T.VPair (T.VMutez amount', _)))) <- resE   , amount' /= ceAmount env       = failedProp $ "Storage updated to wrong value: new amount"                       <> " is not equal to amount of transaction"-  | Right (_, (T.VPair (_, T.VPair (_, T.VC (CvKeyHash keyHash'))))) <- resE+  | Right (_, (T.VPair (_, T.VPair (_, T.VKeyHash keyHash')))) <- resE   , keyHash' /= newKeyHash       = failedProp $ "Storage updated to wrong value: new key hash"                       <> " is not equal to contract's parameter"
test/Test/Interpreter/CallSelf.hs view
@@ -52,8 +52,8 @@     minGas = 0     maxGas = gasForOneExecution * maxCalls -type Parameter = 'Tc 'CInt-type Storage = 'Tc 'CNat+type Parameter = 'TInt+type Storage = 'TNat  testImpl ::      (U.Contract, FullContract Parameter Storage)
+ test/Test/Interpreter/ComparableSet.hs view
@@ -0,0 +1,58 @@+-- | Module, containing spec to test compare.tz contract.+module Test.Interpreter.ComparableSet+  ( test_comparable_set+  ) where++import Data.Set as Set (fromList, toList)+import Test.QuickCheck (Property, (===))+import Test.QuickCheck.Property (withMaxSuccess)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty)++import Michelson.Interpret (InterpreterState, MichelsonFailed)+import Michelson.Test (contractProp, testTreesWithTypedContract)+import Michelson.Test.Dummy+import Michelson.Test.Util (failedProp)+import Michelson.Typed (ToT, fromVal)+import qualified Michelson.Typed as T++import Test.Util.Contracts++type Param = Set (Integer, Integer)+type HContractStorage = Maybe (Integer, Integer)+type ContractStorage = T.Value (ToT HContractStorage)+type ContractResult x+   = ( Either MichelsonFailed ([x], ContractStorage)+     , InterpreterState)++-- | Spec to test comparable_set.tz contract.+test_comparable_set :: IO [TestTree]+test_comparable_set =+  testTreesWithTypedContract (inContractsDir "comparable_set.tz") $ \contract ->+    let+      contractProp' inputParam =+        contractProp contract (validate (mkExpected inputParam))+        dummyContractEnv inputParam initStorage+    in pure+    [ testProperty "success test" $+        contractProp'+          (fromList  [ (10, 11) , (10, 12)])+        , testProperty "Random check" $+        withMaxSuccess 200 contractProp'+    ]+  where+    initStorage :: HContractStorage+    initStorage = Nothing++    mkExpected :: Param -> HContractStorage+    mkExpected x = case Set.toList x of+      [] -> Nothing+      _ -> Just $ maximum x++    validate+      :: HContractStorage+      -> ContractResult x+      -> Property+    validate e (Right ([], fromVal -> l), _) = l === e+    validate _ (Left _, _) = failedProp "Unexpected fail of script."+    validate _ _ = failedProp "Invalid result got."
test/Test/Interpreter/Conditionals.hs view
@@ -14,13 +14,12 @@ import Michelson.Test.Dummy (dummyContractEnv) import Michelson.Test.Util (failedProp, qcIsLeft, qcIsRight) import Michelson.Text-import Michelson.Typed (CValue(..), ToT) import qualified Michelson.Typed as T  import Test.Util.Contracts  type Param = Either MText (Maybe Integer)-type ContractStorage = T.Value (ToT MText)+type ContractStorage = T.Value (T.ToT MText) type ContractResult x    = ( Either MichelsonFailed ([x], ContractStorage)      , InterpreterState)@@ -45,7 +44,7 @@       => Param       -> ContractResult x       -> Property-    validate (Left a) (Right ([], T.VC (CvString b)), _) = a === b+    validate (Left a) (Right ([], T.VString b), _) = a === b     validate (Right Nothing) r = qcIsLeft $ fst r     validate (Right (Just a)) r       | a < 0 = qcIsLeft $ fst r
test/Test/Interpreter/ContractOp.hs view
@@ -4,6 +4,7 @@   ) where  import qualified Data.Map as M+import Fmt (pretty) import Test.QuickCheck (Property, (===)) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperty)@@ -11,32 +12,43 @@ import Michelson.Interpret (ContractEnv(..), ContractReturn) import Michelson.Test (contractProp, dummyContractEnv, failedProp, testTreesWithTypedContract) import Michelson.Typed (FullContract, ToT, fromVal)-import Michelson.Untyped (CT(..), T(..), Type(..), noAnn)+import Michelson.Untyped (ParameterType(..), T(..), Type(..), noAnn) import Tezos.Address  import Test.Util.Contracts --- | Spec to test compare.tz contract.+-- | Spec to test @contract_op.tz@ contract.+--+-- Test results are confirmed by the reference implementation. test_contract_op :: IO [TestTree] test_contract_op =-  testTreesWithTypedContract (inContractsDir "contract_op.tz") $ \contract -> pure+  testTreesWithTypedContract (inContractsDir "contract_op.tz") $ \contract -> pure $   [ testProperty "contract not found" $       contractProp' False [] contract-  , testProperty "contract found, expected parameter is int :q, actual is int :q" $-      contractProp' True [(addr, intQ)] contract-  , testProperty "contract found, expected parameter int :q, actual int" $-      contractProp' True [(addr, int)] contract-  , testProperty "contract found, but expected parameter is int :p, actual is int :q" $-      contractProp' False [(addr, intP)] contract-  , testProperty "contract found, but expected parameter is int :p, actual is string" $-      contractProp' False [(addr, string)] contract+  ] <>+  map (\(res, paramType) ->+          testProperty (msg res paramType) $+          contractProp' res [(addr, paramType)] contract+      )+  [ (True, ParameterType intQ "root")+  , (True, ParameterType int "root")+  , (False, ParameterType intQ noAnn)+  , (False, ParameterType int noAnn)+  , (False, ParameterType intP noAnn)+  , (False, ParameterType string noAnn)+  , (False, ParameterType intP "root")+  , (False, ParameterType intQ "another_root")   ]   where-    intQ = Type (Tc CInt) "q"-    int = Type (Tc CInt) noAnn-    intP = Type (Tc CInt) "p"-    string = Type (Tc CString) noAnn+    msg isGood paramType =+      "parameter in environment is '" <> pretty paramType <> "', " <>+      bool "" "but "  isGood <> "contract expects '%root int :q'" +    intQ = Type TInt "q"+    int = Type TInt noAnn+    intP = Type TInt "p"+    string = Type TString noAnn+     addr = unsafeParseContractHash "KT1WsLzQ61xtMNJHfwgCHh2RnALGgFAzeSx9"      validate@@ -47,7 +59,9 @@     validate _ (Left _, _) = failedProp "Unexpected fail in interepreter"     validate _ _ = failedProp "Unexpected result of script execution" -    contractProp' :: Bool -> [(ContractHash, Type)] -> FullContract (ToT Address) (ToT Bool) -> Property+    contractProp'+      :: Bool -> [(ContractHash, ParameterType)] -> FullContract (ToT Address) (ToT Bool)+      -> Property     contractProp' res ctrs contract =       contractProp         contract
test/Test/Interpreter/EnvironmentSpec.hs view
@@ -25,7 +25,7 @@  test_environment :: IO [TestTree] test_environment =-  testTreesWithContract (inContractsDir "deprecated/environment.tz") $+  testTreesWithContract (inContractsDir "environment.tz") $   \contract -> pure     [ testImpl contract     , testCase ("Default balance") $@@ -58,15 +58,8 @@     , fAmount fixture < unsafeMkMutez 15     ] -shouldReturn :: Fixture -> U.Value-shouldReturn fixture-  | fMaxSteps fixture - consumedGas > 1000 = U.ValueTrue-  | otherwise = U.ValueFalse-  where-    consumedGas = 19- testImpl ::-    (U.Contract, T.FullContract ('Tc 'CAddress) ('Tc 'CBool))+    (U.Contract, T.FullContract 'TAddress 'TUnit)   -> TestTree testImpl (uEnvironment, _environment)  = do   testProperty description $@@ -87,7 +80,7 @@    -- Then let's originated the 'environment.tz' contract   environmentAddress <--    originate contract "environment" U.ValueFalse (fBalance fixture)+    originate contract "environment" U.ValueUnit (fBalance fixture)    -- And transfer tokens to it   let@@ -110,7 +103,7 @@       | shouldExpectFailed fixture =         Left $ expectMichelsonFailed (const True) environmentAddress       | otherwise =-        Right $ expectStorageConst environmentAddress $ shouldReturn fixture+        Right $ expectAnySuccess   validate validator  testDefaultBalance :: IntegrationalScenario
test/Test/Interpreter/StackRef.hs view
@@ -24,7 +24,7 @@     fullContract = FullContract       { fcCode = contractCode       , fcStoreNotes = starNotes-      , fcParamNotesSafe = starParamNotes+      , fcParamNotes = starParamNotes       }      contractCode :: ContractCode 'TUnit 'TUnit
test/Test/Interpreter/StringCaller.hs view
@@ -32,8 +32,8 @@       pure $ testImpl stringCaller failOrStoreAndTransfer  testImpl ::-     (U.Contract, T.FullContract ('Tc 'CString) ('Tc 'CAddress))-  -> (U.Contract, T.FullContract ('Tc 'CString) ('Tc 'CString))+     (U.Contract, T.FullContract 'TString 'TAddress)+  -> (U.Contract, T.FullContract 'TString 'TString)   -> [TestTree] testImpl (uStringCaller, _stringCaller) (uFailOrStore, _failOrStoreAndTransfer) =   let scenario = integrationalScenario uStringCaller uFailOrStore
test/Test/Michelson/Runtime.hs view
@@ -185,9 +185,9 @@   where     contract :: Contract     contract = Contract-      { para = Type tstring noAnn-      , stor = Type tbool noAnn-      , code =+      { contractParameter = ParameterType (Type tstring noAnn) noAnn+      , contractStorage = Type tbool noAnn+      , contractCode =         [ WithSrcEx (ics 0) $ PrimEx (CDR noAnn noAnn)         , WithSrcEx (ics 1) $ PrimEx (NIL noAnn noAnn $ Type TOperation noAnn)         , WithSrcEx (ics 2) $ PrimEx (PAIR noAnn noAnn noAnn noAnn)@@ -197,7 +197,7 @@ contractAux2 :: ContractAux contractAux2 = contractAux1   { caContract = (caContract contractAux1)-    { code =+    { contractCode =       [ WithSrcEx (ics 0) $ PrimEx (CDR noAnn noAnn)       , WithSrcEx (ics 1) $ PrimEx (NOT noAnn)       , WithSrcEx (ics 2) $ PrimEx (NIL noAnn noAnn $ Type TOperation noAnn)
test/Test/OpSize.hs view
@@ -249,6 +249,11 @@                     \{ parameter unit; \                     \  storage (or int nat); \                     \  code { DROP; PUSH (or int nat) (Right 2); NIL operation; PAIR } }" 70+  , instrTestCase "PUSH (or %root int nat) (Left 5); PUSH mutez 5; NONE key_hash; \+                  \CREATE_CONTRACT \+                    \{ parameter unit; \+                    \  storage (or int nat); \+                    \  code { DROP; PUSH (or int nat) (Right 2); NIL operation; PAIR } }" 70   ]   where   customInstrTestCase instr gas =
test/Test/Optimizer.hs view
@@ -24,16 +24,15 @@ import Michelson.Text import qualified Michelson.Typed as T import Michelson.Typed.Instr-import Michelson.Untyped (CT(..))-import Util.Peano (Sing(..))+import Util.Peano (SingNat(..))  -- Sample stacks of length 0, 1… type Stack0 = '[ ] type Stack1 = '[ 'T.TUnit ]-type Stack1Int = '[ 'T.Tc 'CInt ]+type Stack1Int = '[ 'T.TInt ] type Stack1Pair = '[ 'T.TPair 'T.TUnit 'T.TUnit ] type Stack2 = '[ 'T.TUnit, 'T.TUnit ]-type Stack2UnitInt = '[ 'T.TUnit, 'T.Tc 'CInt ]+type Stack2UnitInt = '[ 'T.TUnit, 'T.TInt ]  unit_Optimizer_Tree_Independence :: Assertion unit_Optimizer_Tree_Independence = do@@ -81,18 +80,18 @@  unit_Specific_PUSH :: Assertion unit_Specific_PUSH = do-  optimize (PUSH (T.VMap @'CInt @'T.TUnit mempty)) @?= EMPTY_MAP-  optimize (PUSH (T.VSet @'CInt mempty) `Seq` NOW) @?= (EMPTY_SET `Seq` NOW)+  optimize (PUSH (T.VMap @'T.TInt @'T.TUnit mempty)) @?= EMPTY_MAP+  optimize (PUSH (T.VSet @'T.TInt mempty) `Seq` NOW) @?= (EMPTY_SET `Seq` NOW)   optimize (PUSH T.VUnit) @?= UNIT  unit_Optimize_PUSH_PACK :: Assertion unit_Optimize_PUSH_PACK =   optimize'     (PUSH strValue `Seq` PACK `Seq` DUP) @?=-    (PUSH (T.VC $ T.CvBytes $ packValue' strValue) `Seq` DUP)+    (PUSH (T.VBytes $ packValue' strValue) `Seq` DUP)   where     optimize' =-      optimizeWithConf @Stack0 @'[ 'T.Tc 'CBytes, 'T.Tc 'CBytes ]+      optimizeWithConf @Stack0 @'[ 'T.TBytes, 'T.TBytes ]       (def {ruleset = defaultRulesAndPushPack})  unit_Sample_optimize :: Assertion@@ -107,10 +106,10 @@ str :: MText str = [mt|aa|] -strValue :: T.Value ('T.Tc 'CString)-strValue = T.VC $ T.CvString str+strValue :: T.Value 'T.TString+strValue = T.VString str -nonOptimal :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString)+nonOptimal :: T.ContractCode 'T.TString 'T.TString nonOptimal =   CAR `Seq`   -- `PUSH; DROP` is erased@@ -122,11 +121,11 @@   -- `DUP; DROP` is also erased   DIP (DUP `Seq` DUP `Seq` DROP) `Seq`   -- `SWAP; SWAP` is erased, along with surrounding redundant instructions and outer `DIP`-  DIP (PUSH (T.VC $ T.CvBool False) `Seq` IF (Nop) (SWAP `Seq` SWAP)) `Seq`+  DIP (PUSH (T.VBool False) `Seq` IF (Nop) (SWAP `Seq` SWAP)) `Seq`   CONCAT `Seq`   Nested (SIZE `Seq`   -- `COMPARE` with 0 is redundant-  (PUSH (T.VC $ T.CvNat 0) `Seq` COMPARE) `Seq` EQ `Seq`+  (PUSH (T.VNat 0) `Seq` COMPARE) `Seq` EQ `Seq`   -- Here both bodys of `IF` can be erased and then `IF` can be replaced with `DROP`   IF (DUP `Seq` DROP) (UNIT `Seq` DROP) `Seq`   -- `LEFT` followed by `IF_LEFT` can be optimized@@ -147,7 +146,7 @@ infixr 1 #<#  -- Expected output of the optimizer.-expectedOptimized :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString)+expectedOptimized :: T.ContractCode 'T.TString 'T.TString expectedOptimized =   CAR #<#   DUP #<#
test/Test/Parser.hs view
@@ -22,8 +22,7 @@ import qualified Data.List.NonEmpty as NE import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy) import Text.Megaparsec (parse)-import Text.Megaparsec.Error-  (ErrorFancy(ErrorCustom), ParseError(FancyError), bundleErrors, errorBundlePretty)+import Text.Megaparsec.Error (ErrorFancy(ErrorCustom), ParseError(FancyError), bundleErrors)  import Michelson.ErrorPos (srcPos) import Michelson.Macro as Mo@@ -61,7 +60,7 @@     Right Mo.ValueNil   P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe`     (Right . ValueLambda $ NE.fromList-      [Mo.Prim (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]+      [Mo.Prim (Mo.PUSH noAnn (Mo.Type Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]     )   P.parseNoEnv P.value "" "{1; 2}" `shouldBe`     (Right . Mo.ValueSeq $ NE.fromList@@ -77,7 +76,7 @@   P.parseNoEnv P.value "" "{{ }; {}; {PUSH int 5; DROP}}" `shouldBe`     Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1)             :| [ Mo.Seq [] (srcPos 0 6)-               , Mo.Seq [Mo.Prim (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5)) (srcPos 0 11)+               , Mo.Seq [Mo.Prim (Mo.PUSH noAnn (Mo.Type Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)                         , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)                ]            ))@@ -196,11 +195,16 @@ unit_set_type :: Expectation unit_set_type = do   P.parseNoEnv P.type_ "" "set int" `shouldBe` Right intSet+  P.parseNoEnv P.type_ "" "set (pair int int)" `shouldBe` Right intPairSet   P.parseNoEnv P.type_ "" "{int}" `shouldBe` Right intSet+  P.parseNoEnv P.type_ "" "{(pair int int)}" `shouldBe` Right intPairSet   where     intSet :: Mo.Type     intSet =-      Mo.Type (Mo.TSet (Mo.Comparable Mo.CInt noAnn)) noAnn+      Mo.Type (Mo.TSet (Mo.Type Mo.TInt noAnn)) noAnn+    intPairSet :: Mo.Type+    intPairSet =+      Mo.Type (Mo.TSet (Mo.Type (Mo.TPair noAnn noAnn (Mo.Type Mo.TInt noAnn) (Mo.Type Mo.TInt Mo.noAnn)) noAnn)) noAnn  unit_Pair_constructor :: Expectation unit_Pair_constructor = do
test/Test/Preprocess.hs view
@@ -12,47 +12,45 @@ import Michelson.Text import qualified Michelson.Typed as T import Michelson.Typed.Instr-import Michelson.Untyped (CT(..))  unit_Sample_preprocess :: Assertion-unit_Sample_preprocess = transformStrings False f sample @?= expected+unit_Sample_preprocess = do+  transformStrings False (f (mkMTextUnsafe . toText)) (sample (T.VString . mkMTextUnsafe)) @?= (expected (T.VString . mkMTextUnsafe))+  transformBytes False (f fromString) (sample T.VBytes) @?= (expected T.VBytes)   where-    f s-      | s == str1 = str5-      | s == str2 = str4-      | s == str4 = str2-      | s == str5 = str1+    f :: (Eq a) => (String -> a) -> a -> a+    f fn s+      | s == (fn str1) = (fn str5)+      | s == (fn str2) = (fn str4)+      | s == (fn str4) = (fn str2)+      | s == (fn str5) = (fn str1)       | otherwise = s -str1, str2, str3, str4, str5 :: MText-str1 = [mt|aa|]-str2 = [mt|ls|]-str3 = [mt|gulya|]-str4 = [mt|naiks|]-str5 = [mt|eek|]--sample :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString)-sample =+sample :: (IsString i, T.ConstantScope o, Typeable o) => (i -> T.Value o) -> T.ContractCode o o+sample fn =   CAR `Seq`-  PUSH (toStr str1) `Seq`-  DIP (PUSH (toStr str2)) `Seq`-  LEFT @('T.TKey) `Seq` IF_LEFT Nop (PUSH (toStr str4)  `Seq` FAILWITH) `Seq`-  DIP (DIP (PUSH (toStr str5))) `Seq`-  PUSH (toStr str3) `Seq`+  PUSH (fn str1) `Seq`+  DIP (PUSH (fn str2)) `Seq`+  LEFT @('T.TKey) `Seq` IF_LEFT Nop (PUSH (fn str4)  `Seq` FAILWITH) `Seq`+  DIP (DIP (PUSH (fn str5))) `Seq`+  PUSH (fn str3) `Seq`   DROP `Seq` DROP `Seq` DROP `Seq` DROP `Seq`   NIL `Seq` PAIR-  where-    toStr = T.VC . T.CvString -expected :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString)-expected =+expected :: (IsString i, T.ConstantScope o, Typeable o) => (i -> T.Value o) -> T.ContractCode o o+expected fn =   CAR `Seq`-  PUSH (toStr str5) `Seq`-  DIP (PUSH (toStr str4)) `Seq`-  LEFT @('T.TKey) `Seq` IF_LEFT Nop (PUSH (toStr str2)  `Seq` FAILWITH) `Seq`-  DIP (DIP (PUSH (toStr str1))) `Seq`-  PUSH (toStr str3) `Seq`+  PUSH (fn str5) `Seq`+  DIP (PUSH (fn str4)) `Seq`+  LEFT @('T.TKey) `Seq` IF_LEFT Nop (PUSH (fn str2)  `Seq` FAILWITH) `Seq`+  DIP (DIP (PUSH (fn str1))) `Seq`+  PUSH (fn str3) `Seq`   DROP `Seq` DROP `Seq` DROP `Seq` DROP `Seq`   NIL `Seq` PAIR-  where-    toStr = T.VC . T.CvString++str1, str2, str3, str4, str5 :: (IsString a) => a+str1 = "aa"+str2 = "ls"+str3 = "gulya"+str4 = "naiks"+str5 = "eek"
test/Test/Printer/Michelson.hs view
@@ -104,7 +104,7 @@ unit_let_macro = do   let filePath = inContractsDir "ill-typed/letblock_trivial.mtz"   contract <- printAndParse filePath =<< importUntypedContract filePath-  let ops = concatMap U.flattenExpandedOp (U.code contract)+  let ops = concatMap U.flattenExpandedOp (U.contractCode contract)   ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP]  printAndParse :: FilePath -> U.Contract -> IO U.Contract
test/Test/Serialization/Michelson.hs view
@@ -6,9 +6,8 @@  import Prelude hiding (Ordering(..)) -import Data.Singletons (SingI(..)) import qualified Data.Text as T-import Data.Typeable ((:~:)(..), Typeable, eqT, typeRep)+import Data.Typeable ((:~:)(..), eqT, typeRep) import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy) import Text.Hex (decodeHex, encodeHex) @@ -19,12 +18,12 @@ import qualified Michelson.Parser as Parser import Michelson.Test.Util import Michelson.Text-import Michelson.TypeCheck (HST(..), SomeInstr(..), SomeInstrOut(..), typeCheckList)+import Michelson.TypeCheck (HST(..), SomeInstr(..), SomeInstrOut(..), typeCheckList, getWTP) import Michelson.Typed import Michelson.Untyped (noAnn) import Test.Util.Parser import Tezos.Address (Address(..), unsafeParseAddress)-import Tezos.Core (ChainId (..), Mutez, Timestamp, parseChainId, timestampFromSeconds, unsafeMkMutez)+import Tezos.Core (ChainId(..), Mutez, Timestamp, parseChainId, timestampFromSeconds, unsafeMkMutez) import Tezos.Crypto (KeyHash(..), parseKeyHash, parsePublicKey, parseSignature)  spec_Packing :: Spec@@ -168,7 +167,9 @@       | length s < 60 = s       | otherwise = take 60 s <> " ..."     initTypeCheckST = error "Type check state is not defined"-    initStack = (starNotes @inp, noAnn) ::& SNil+    initStack = case getWTP @inp of+      Just Dict -> (starNotes @inp, Dict, noAnn) ::& SNil+      Nothing -> error "Type is not well typed"  unpackNegSpec   :: forall (t :: T).@@ -421,12 +422,12 @@         ~: "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b"     ] -  packSpecManual "non-unit contract" packTestMethods (addressToVContract @('Tc 'CInt)) $ parseAddrs+  packSpecManual "non-unit contract" packTestMethods (addressToVContract @'TInt) $ parseAddrs     [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"         ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200"     ] -  packSpecManual "contract with entrypoint" packTestMethods (mkEpVContract @('Tc 'CInt)) $ parseEpAddrs+  packSpecManual "contract with entrypoint" packTestMethods (mkEpVContract @'TInt) $ parseEpAddrs     [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB%"         ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200"     , "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB%abacaba"@@ -487,7 +488,7 @@   -- Values we compare against are produced with command   -- ./alphanet.sh client hash data "{ $instrs }" of type 'lambda int int' -  parsePackSpec @('Tc 'CInt) @('Tc 'CInt) "instr"+  parsePackSpec @'TInt @'TInt "instr"     [ ""        ~: "0x050200000000"     , "PUSH int 1; DROP"@@ -632,8 +633,6 @@     , "PUSH bytes 0x; BLAKE2B; DROP"       ~: "0x05020000000d074303690a00000000030e0320"       -- HASH_KEY goes below-    , "STEPS_TO_QUOTA; DROP"-      ~: "0x050200000004034a0320"     , "SOURCE; DROP"       ~: "0x05020000000403470320"     , "SENDER; DROP"@@ -687,7 +686,7 @@        ~: "0x05020000000a0743035b000103280320"     ] -  parsePackSpec @('Tc 'CAddress) @'TUnit "instrs address-related"+  parsePackSpec @'TAddress @'TUnit "instrs address-related"     [ "CONTRACT unit; DROP; PUSH unit Unit"        ~: "0x05020000000c0555036c03200743036c030b"     , "CONTRACT %entrypnt unit; DROP; PUSH unit Unit"@@ -701,7 +700,7 @@        ~: "0x05020000000a035403200743036c030b"     ] -  parsePackSpec @('Tc 'CKeyHash) @'TUnit "instrs key-hash-related"+  parsePackSpec @'TKeyHash @'TUnit "instrs key-hash-related"     [ "SOME; SET_DELEGATE; DROP; PUSH unit Unit"        ~: "0x05020000000c0346034e03200743036c030b"     , "SOME; DIP{ PUSH unit Unit; PUSH mutez 5; }; \@@ -726,16 +725,27 @@        ~: "0x05020000004f0346051f020000000c0743035b00010743036a0005051d020000\           \00290500045b000000023a700501045b000000023a730502020000000e03200743\           \035b000a053d036d0342032003200743036c030b"+    , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \+       \ CREATE_CONTRACT{ \+       \   parameter (int %root :p); \+       \   storage (int :s); \+       \   code { DROP; PUSH int 10; NIL operation; PAIR } \+       \  }; \+       \ DROP; DROP; PUSH unit Unit \+       \"+       ~: "0502000000550346051f020000000c0743035b00010743036a0005051d020000002\+          \f0500045b000000083a702025726f6f740501045b000000023a730502020000000e\+          \03200743035b000a053d036d0342032003200743036c030b"     , "IMPLICIT_ACCOUNT; DROP; PUSH unit Unit"        ~: "0x05020000000a031e03200743036c030b"     ] -  parsePackSpec @'TKey @('Tc 'CKeyHash) "instrs public-key-related"+  parsePackSpec @'TKey @'TKeyHash "instrs public-key-related"     [ "HASH_KEY"        ~: "0x050200000002032b"     ] -  parsePackSpec @('TPair 'TSignature 'TKey) @('Tc 'CBool) "instrs public-key-related"+  parsePackSpec @('TPair 'TSignature 'TKey) @'TBool "instrs public-key-related"     [ "DIP{ PUSH bytes 0x }; DUP; DIP {CAR}; CDR; CHECK_SIGNATURE"        ~: "0x05020000001f051f0200000009074303690a000000000321051f020000\           \0002031603170318"@@ -825,17 +835,17 @@ unpackNegTest :: Spec unpackNegTest = do   describe "Bad entries order" $ do-    unpackNegSpec @('TSet 'CInt) "Unordered set elements"+    unpackNegSpec @('TSet 'TInt) "Unordered set elements"       "0x050200000006000300020001"  -- { 3; 2; 1 }-    unpackNegSpec @('TMap 'CInt $ 'Tc 'CInt) "Unordered map elements"+    unpackNegSpec @('TMap 'TInt $ 'TInt) "Unordered map elements"       "0x05020000000c070400020006070400010007"  -- { Elt 2 6; Elt 1 7 }    describe "Wrong length specified" $ do-    unpackNegSpec @('TList $ 'Tc 'CInt) "Too few list length"+    unpackNegSpec @('TList $ 'TInt) "Too few list length"       "0x05020000000300010002"  -- { 1; 2 }-    unpackNegSpec @('TList $ 'Tc 'CInt) "Too big list length"+    unpackNegSpec @('TList $ 'TInt) "Too big list length"       "0x05020000000500010002"  -- { 1; 2 }-    unpackNegSpec @('TList $ 'Tc 'CInt) "Wrong bytes length"+    unpackNegSpec @('TList $ 'TInt) "Wrong bytes length"       "0x050b000000021234"  -- 0x1234    describe "Type check failures" $ do@@ -849,20 +859,20 @@       "0x0502000000020320"  -- {DROP}    describe "Invalid annotations specified" $ do-    unpackNegSpec @('TLambda ('TPair ('Tc 'CInt) ('Tc 'CInt)) ('Tc 'CInt))+    unpackNegSpec @('TLambda ('TPair 'TInt 'TInt) 'TInt)       "Space char `20` in the middle of an annotation"       "0x050200000009041600000003252061"-    unpackNegSpec @('TLambda ('TPair ('Tc 'CInt) ('Tc 'CInt)) ('Tc 'CInt))+    unpackNegSpec @('TLambda ('TPair 'TInt 'TInt) 'TInt)       "Char from invalid range `00-1F` as part of an annotation"       "0x050200000009041600000003251A61"-    unpackNegSpec @('TLambda ('TPair ('Tc 'CInt) ('Tc 'CInt)) ('Tc 'CInt))+    unpackNegSpec @('TLambda ('TPair 'TInt 'TInt) 'TInt)       "Char from invalid range `A0-FF` as part of an annotation"       "0x05020000000904160000000325A361"  unpackVarAnnTest :: Spec unpackVarAnnTest = do   describe "Unpack instructions with Variable Annotations" $ do-    parseUnpackOnlySpec @('Tc 'CInt) @('Tc 'CInt) "VarAnn instr"+    parseUnpackOnlySpec @'TInt @'TInt "VarAnn instr"       [ "DUP @dp; SWAP; DROP"          ~: "0x05020000000d042100000003406470034c0320"       , "UNIT @un; DROP"@@ -947,8 +957,6 @@          ~: "0x05020000000a04150000000240620320"       , "PUSH bytes 0x; BLAKE2B @b2b; DROP"          ~: "0x050200000015074303690a00000000040e00000004406232620320"-      , "STEPS_TO_QUOTA @sq; DROP"-         ~: "0x05020000000b044a000000034073710320"       , "SOURCE @src; DROP"          ~: "0x05020000000c044700000004407372630320"       , "SENDER @s; DROP"@@ -961,7 +969,7 @@          ~: "0x0502000000080458000000024072"       ] -    parseUnpackOnlySpec @('Tc 'CAddress) @'TUnit "VarAnn instrs address-related"+    parseUnpackOnlySpec @'TAddress @'TUnit "VarAnn instrs address-related"       [ "CONTRACT @c unit; DROP; PUSH unit Unit"          ~: "0x0502000000120655036c00000002406303200743036c030b"       ]@@ -971,7 +979,7 @@          ~: "0x050200000010045400000002406103200743036c030b"       ] -    parseUnpackOnlySpec @('Tc 'CKeyHash) @'TUnit "VarAnn instrs key-hash-related"+    parseUnpackOnlySpec @'TKeyHash @'TUnit "VarAnn instrs key-hash-related"       [ "SOME; SET_DELEGATE @d; DROP; PUSH unit Unit"          ~: "0x0502000000120346044e00000002406403200743036c030b"       , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \@@ -1000,12 +1008,12 @@          ~: "0x050200000010041e00000002406903200743036c030b"       ] -    parseUnpackOnlySpec @'TKey @('Tc 'CKeyHash) "VarAnn instrs public-key-related"+    parseUnpackOnlySpec @'TKey @'TKeyHash "VarAnn instrs public-key-related"       [ "HASH_KEY @h"          ~: "0x050200000008042b000000024068"       ] -    parseUnpackOnlySpec @('TPair 'TSignature 'TKey) @('Tc 'CBool) "VarAnn instrs public-key-related"+    parseUnpackOnlySpec @('TPair 'TSignature 'TKey) @'TBool "VarAnn instrs public-key-related"       [ "DIP{ PUSH bytes 0x }; DUP; DIP {CAR}; CDR; CHECK_SIGNATURE @c"          ~: "0x050200000025051f0200000009074303690a000000000321051f0200000002\             \031603170418000000024063"@@ -1016,7 +1024,7 @@ readableUnpackTest = do   describe "Unpack crypto primitives from Readable representation" $ do     -- ./tezos-client hash data '"tz1akcPmG1Kyz2jXpS4RvVJ8uWr7tsiT9i6A"' of type 'string'-    unpackReadableSpec @('Tc 'CAddress) "Unpack readable address"+    unpackReadableSpec @'TAddress "Unpack readable address"       "0x050100000024747a31666173774354446369527a45346f4a396a6e32566\       \d3264766a6579413966557a55"     -- ./tezos-client hash data '"edpktezaD1wnUa5pT2pvj1JGHNey18WGhPc9fk9bbppD33KNQ2vH8R"'
test/Test/Typecheck.hs view
@@ -35,7 +35,7 @@ import Michelson.Test.Import (ImportContractError(..), readContract) import Michelson.TypeCheck import qualified Michelson.Typed as T-import Michelson.Untyped (Type(..), noAnn)+import Michelson.Untyped (ParameterType(..), noAnn) import qualified Michelson.Untyped as Un import Tezos.Address (Address(..), ContractHash, mkContractHashRaw) import Tezos.Core (Timestamp)@@ -56,11 +56,11 @@ test_srcPosition =   [ testProperty "Verify instruction position in a typecheck error" $ do       checkIllFile (inContractsDir "ill-typed/basic3.tz") $ \case-          TCFailedOnInstr (Un.CONS _) _ _ (IsSrcPos 4 6) (Just (AnnError _)) -> True+          TCFailedOnInstr (Un.CONS _) _ (IsSrcPos 4 6) _ (Just (AnnError _)) -> True           _ -> False        checkIllFile (inContractsDir "ill-typed/testassert_invalid_stack3.mtz") $ \case-          TCFailedOnInstr Un.DROP _ _ (IsSrcPos 6 17) Nothing -> True+          TCFailedOnInstr Un.DROP _ (IsSrcPos 6 17) _ Nothing -> True           _ -> False        checkIllFile (inContractsDir "ill-typed/testassert_invalid_stack2.mtz") $ \case@@ -68,7 +68,7 @@           _ -> False        checkIllFile (inContractsDir "ill-typed/macro_in_let_fail.mtz") $ \case-          TCFailedOnInstr (Un.COMPARE _) _ _ (InstrCallStack [LetName "cmpLet"] (SrcPos (Pos 3) (Pos 6)))+          TCFailedOnInstr (Un.COMPARE _) _ (InstrCallStack [LetName "cmpLet"] (SrcPos (Pos 3) (Pos 6))) _                                               (Just (TypeEqError _ _)) -> True           _ -> False       checkIllFile (inContractsDir "ill-typed/compare_annotation_mismatch.tz") $ \case@@ -83,7 +83,7 @@  checkFile   :: HasCallStack-  => [(ContractHash, Type)]+  => [(ContractHash, ParameterType)]   -> Bool   -> FilePath   -> (TCError -> Expectation)@@ -161,7 +161,7 @@   ]   where     printStRef i = Un.EXT . Un.UPRINT $ Un.PrintComment [Right (Un.StackRef i)]-    stackEl = (T.starNotes @'T.TUnit, noAnn)+    stackEl = (T.starNotes @'T.TUnit, T.Dict, noAnn)  test_TCTypeError_display :: [TestTree] test_TCTypeError_display =@@ -174,12 +174,12 @@       @?= "Types not equal: unit /= key"    , testCase "StackEqError" $-      build (StackEqError [T.TUnit, T.Tc T.CBytes] [])+      build (StackEqError [T.TUnit, T.TBytes] [])       @?= "Stacks not equal: [unit, bytes] /= []"    , testCase "UnsupportedTypes" $-      build (UnsupportedTypes [T.TUnit])-      @?= "Unsupported types: [unit]"+      build (UnsupportedTypeForScope (T.TBigMap T.TInt T.TInt) T.BtHasBigMap)+      @?= "Type 'big_map int int' is unsupported here because it has 'big_map'"    , testCase "InvalidValueType" $       build (InvalidValueType T.TUnit)@@ -191,7 +191,7 @@   forAll @(NonEmpty Integer) arbitrary $ \l ->   let     untypedValue = Un.ValueSeq $ Un.ValueInt <$> l-    typedValue = T.VList $ (T.VC . T.CvInt) <$> toList l+    typedValue = T.VList $ T.VInt <$> toList l     runTypeCheckInstr = runTypeCheckIsolated . usingReaderT def   in runTypeCheckInstr (typeCheckValue untypedValue) == Right typedValue @@ -224,7 +224,7 @@         res -> assertFailure $ "Unexpected result: " <> show res    , testCase "Correct contract value" $-      case doTypeCheckVal @('T.TContract ('T.Tc 'T.CInt)) env1 addrUVal2 of+      case doTypeCheckVal @('T.TContract 'T.TInt) env1 addrUVal2 of         Right _ -> pass         res -> assertFailure $ "Unexpected result: " <> show res   ]@@ -236,9 +236,7 @@     addrUVal2 = Un.ValueString $ T.mformatEpAddress addr2      env1 = M.fromList-      [ ( addr1'-        , [utypeQ| ( nat %s | int %q ) |]-        )+      [ ( addr1', ParameterType [utypeQ| ( nat %s | int %q ) |] noAnn)       ]      doTypeCheckVal
test/Test/Util/Contracts.hs view
@@ -59,8 +59,7 @@   contractsDir :   map ((contractsDir </> "tezos_examples") </>)     [ "attic"-    -- , "entrypoints"-    -- ^ TODO: uncomment once https://gitlab.com/morley-framework/morley/issues/35 is resolved+    , "entrypoints"     , "macros"     , "mini_scenarios"     , "opcodes"
test/Test/ValConversion.hs view
@@ -9,7 +9,8 @@ import Test.QuickCheck (Arbitrary) import Test.Tasty (TestTree) -import Michelson.Typed (CValue(..), IsoValue(..), ToT, Value, Value'(..))+import Michelson.Text+import Michelson.Typed (IsoValue(..), ToT, Value, Value'(..))  import Test.Util.QuickCheck (roundtripTest) @@ -37,19 +38,24 @@ unit_toVal :: Assertion unit_toVal = do   check () $ (\case VUnit -> True;)-  check (10 :: Integer) $ (\case (VC (CvInt 10)) -> True; _ -> False)-  check ("abc" :: ByteString) $ (\case (VC (CvBytes "abc")) -> True; _ -> False)+  check (10 :: Integer) $ (\case (VInt 10) -> True; _ -> False)+  check ("abc" :: ByteString) $ (\case (VBytes "abc") -> True; _ -> False)   check (Just "abc" :: Maybe ByteString)-    $ (\case (VOption (Just (VC (CvBytes "abc")))) -> True; _ -> False)+    $ (\case (VOption (Just (VBytes "abc"))) -> True; _ -> False)   check (Left "abc" :: Either ByteString ByteString)-    $ (\case (VOr (Left (VC (CvBytes "abc")))) -> True; _ -> False)+    $ (\case (VOr (Left (VBytes "abc"))) -> True; _ -> False)   check (Left "abc" :: Either ByteString Integer)-    $ (\case (VOr (Left (VC (CvBytes "abc")))) -> True; _ -> False)+    $ (\case (VOr (Left (VBytes "abc"))) -> True; _ -> False)   check ((10, "abc") :: (Integer, ByteString))-    $ (\case (VPair (VC (CvInt 10), VC (CvBytes "abc"))) -> True; _ -> False)+    $ (\case (VPair ((VInt 10), VBytes "abc")) -> True; _ -> False)   check (["abc", "cde"] :: [ByteString])-    $ (\case (VList [ VC (CvBytes "abc")-                    , VC (CvBytes "cde")]) -> True; _ -> False)+    $ (\case (VList [ VBytes "abc"+                    , VBytes "cde"]) -> True; _ -> False)+  check @Integer 10 (\case (VInt 10) -> True; _ -> False)+  check @Integer (-10) (\case (VInt -10) -> True; _ -> False)+  check @Natural 10 (\case (VNat 10) -> True; _ -> False)+  check [mt|abc|] (\case (VString [mt|abc|]) -> True; _ -> False)+  check True (\case (VBool True) -> True; _ -> False)   where     check :: IsoValue a => a -> (Value (ToT a) -> Bool) -> Assertion     check v p = p (toVal v) @? "toVal returned unexpected result"