diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,12 +1,41 @@ - - Unreleased ========== + +1.4.0 +===== +* [!446](https://gitlab.com/morley-framework/morley/-/merge_requests/446) + Include source locations and let-binding stacks into typecheck errors. +* [!449](https://gitlab.com/morley-framework/morley/-/merge_requests/449) + + Improve `Michelson.Test.Integrational` interface. + + Remove `IntegrationalValidator`, `SuccessValidator`, `validate`, + `composeValidators`, `composeValidatorsList`, `expectAnySuccess`. + + Add `unexpectedInterpreterError`, `attempt`, `catchExpectedError`. + + Change type of `expect*`/`tExpect*` functions. + They now return `IntegrationalScenario` instead of `SuccessValidator` / `Bool`. + + Rename `ValidationError` to `TestError` + + Replace `TestError`'s `UnexpectedExecutorError` constructor with + `InterpreterError` and `UnexpectedInterpreterError`. +* [!441](https://gitlab.com/morley-framework/morley/merge_requests/441) + Remove `tezos-bake-monitor-lib dependency`, and define value to json conversion + using binary round trip locally instead. +* [!448](https://gitlab.com/morley-framework/morley/merge_requests/448) + Remove `base-noprelude` dependency and use mixins to hide `Prelude` instead. +* [!367](https://gitlab.com/morley-framework/morley/merge_requests/367) + Values and instructions now carry some extra constraints in order to avoid + construction of illegally typed values from within Haskell. + `WellTyped` now also requires `Typeable` and `SingI` constraints. +* [!409](https://gitlab.com/morley-framework/morley/-/merge_requests/409) + + Add hedgehog support +* [!438](https://gitlab.com/morley-framework/morley/-/merge_requests/438) + + Fixed parsing bug: support semicolons after block comments. + +* [!424](https://gitlab.com/morley-framework/morley/-/merge_requests/424) Changed + contract address computation logic in the interpreter to match the + reference implementation a bit more closely by including a global counter and + an origination index (nonce) to contract's hash. Specifically, now the same + contract may be originated several times, leading to different addresses, + just like in Tezos. 1.3.0 ===== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,3 @@ - - # Morley: Developer tools for the Michelson Language [![Hackage](https://img.shields.io/hackage/v/morley.svg)](https://hackage.haskell.org/package/morley) diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 71cfcdcc615797d3a54aa8f14a7cc29b27deb7ba4b9c6c464091aec8fdd56a45 +-- hash: 6cecee7b4a0dcb06694b15ff8be6902535e2f0b301c8c28cc603468df87e3153 name: morley -version: 1.3.0 +version: 1.4.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 @@ -110,6 +110,10 @@ Michelson.Untyped.Value Morley.CLI Morley.Micheline + Morley.Micheline.Binary + Morley.Micheline.Class + Morley.Micheline.Expression + Morley.Micheline.Json Tezos.Address Tezos.Core Tezos.Crypto @@ -120,6 +124,7 @@ Tezos.Crypto.Util Util.Aeson Util.Alternative + Util.Binary Util.ByteString Util.CLI Util.Default @@ -136,6 +141,7 @@ Util.Peano Util.Positive Util.Test.Arbitrary + Util.Test.Gen Util.Test.Ingredients Util.Text Util.TH @@ -150,7 +156,7 @@ 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 MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns + default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude build-depends: HUnit @@ -158,13 +164,14 @@ , aeson , aeson-casing , aeson-pretty - , base-noprelude >=4.7 && <5 + , base >=4.7 && <5 , base16-bytestring , base58-bytestring , binary , bytestring , constraints >=0.11 , containers + , criterion , cryptonite , data-default , first-class-families >=0.5.0.0 @@ -172,6 +179,7 @@ , formatting , ghc-prim , gitrev + , hedgehog , hex-text , hspec , hspec-expectations @@ -182,20 +190,23 @@ , morley-prelude >=0.3.0 , mtl , named + , o-clock , optparse-applicative , parser-combinators >=1.0.0 , quickcheck-arbitrary-adt , quickcheck-instances + , semigroups >=0.19.1 , show-type , singletons + , statistics , syb , tasty , tasty-ant-xml + , tasty-hedgehog , tasty-hunit-compat , tasty-quickcheck , template-haskell , text - , tezos-bake-monitor-lib , th-lift , th-lift-instances , time @@ -205,6 +216,8 @@ , vector , vinyl , wl-pprint-text + mixins: + base hiding (Prelude) default-language: Haskell2010 executable morley @@ -215,16 +228,18 @@ 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 MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns + default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude build-depends: - base-noprelude >=4.7 && <5 + base >=4.7 && <5 , fmt , morley , morley-prelude , named , optparse-applicative , pretty-simple + mixins: + base hiding (Prelude) default-language: Haskell2010 test-suite morley-test @@ -252,6 +267,8 @@ Test.Michelson.Runtime Test.Michelson.Text Test.Michelson.Typed.Util + Test.Michelson.Typed.Value + Test.Morley.Expression Test.OpSize Test.Optimizer Test.Parser @@ -267,23 +284,22 @@ Test.Typecheck Test.Untyped.Instr Test.Util.Contracts + Test.Util.Hedgehog Test.Util.HUnit Test.Util.Parser - Test.Util.QuickCheck Test.ValConversion Tree 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 MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns DerivingStrategies - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -with-rtsopts=-N + default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns DerivingStrategies + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m" build-tool-depends: tasty-discover:tasty-discover build-depends: HUnit - , QuickCheck , aeson - , base-noprelude >=4.7 && <5 + , base >=4.7 && <5 , bytestring , containers , data-default @@ -291,6 +307,7 @@ , filepath , fmt , formatting + , hedgehog , hex-text , hspec , hspec-expectations @@ -298,16 +315,16 @@ , megaparsec >=7.0.0 , morley , morley-prelude - , quickcheck-arbitrary-adt - , quickcheck-instances , singletons , syb , tasty + , tasty-hedgehog , tasty-hspec , tasty-hunit-compat - , tasty-quickcheck , text , unordered-containers + mixins: + base hiding (Prelude) default-language: Haskell2010 benchmark morley-bench @@ -317,13 +334,15 @@ 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 MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns + default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude build-depends: - base-noprelude >=4.7 && <5 + base >=4.7 && <5 , containers , gauge , megaparsec >=7.0.0 , morley , morley-prelude + mixins: + base hiding (Prelude) default-language: Haskell2010 diff --git a/src/Michelson/Doc.hs b/src/Michelson/Doc.hs --- a/src/Michelson/Doc.hs +++ b/src/Michelson/Doc.hs @@ -216,6 +216,9 @@ DocItemRef :: DocItemId -> DocItemRef 'DocItemInDefinitions DocItemNoRef :: DocItemRef 'DocItemInlined +instance ToAnchor (DocItemRef 'DocItemInDefinitions) where + toAnchor (DocItemRef ref) = toAnchor ref + -- | How to render section name. data DocSectionNameStyle = DocSectionNameBig diff --git a/src/Michelson/ErrorPos.hs b/src/Michelson/ErrorPos.hs --- a/src/Michelson/ErrorPos.hs +++ b/src/Michelson/ErrorPos.hs @@ -16,6 +16,7 @@ import Data.Data (Data(..)) import Data.Default (Default(..)) import qualified Data.Text as T +import Fmt (Buildable) import Util.Aeson @@ -39,6 +40,7 @@ newtype LetName = LetName T.Text deriving stock (Eq, Ord, Show, Data, Generic) + deriving newtype Buildable instance NFData LetName diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs --- a/src/Michelson/Interpret.hs +++ b/src/Michelson/Interpret.hs @@ -52,7 +52,7 @@ import Michelson.Typed import qualified Michelson.Typed as T import qualified Michelson.Untyped as U -import Tezos.Address (Address(..)) +import Tezos.Address (Address(..), OriginationIndex(..), mkContractAddress) import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512) import Util.Peano (LongerThan, Peano, SingNat(SS, SZ)) @@ -81,12 +81,15 @@ -- ^ Amount of the current transaction. , ceChainId :: ChainId -- ^ Identifier of the current chain. + , ceOperationHash :: Maybe U.OperationHash + -- ^ Hash of the currently executed operation, required for + -- correct contract address computation in 'CREATE_CONTRACT' instruction. } -- | Represents `[FAILED]` state of a Michelson program. Contains -- value that was on top of the stack when `FAILWITH` was called. data MichelsonFailed where - MichelsonFailedWith :: (Typeable t, SingI t) => T.Value t -> MichelsonFailed + MichelsonFailedWith :: (KnownT t) => T.Value t -> MichelsonFailed MichelsonArithError :: (Typeable n, Typeable m, Typeable instr) => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed @@ -243,7 +246,7 @@ interpret' instr epc param initSt env (initInterpreterState env) initInterpreterState :: ContractEnv -> InterpreterState -initInterpreterState env = InterpreterState def (ceMaxSteps env) +initInterpreterState env = InterpreterState def (ceMaxSteps env) (OriginationIndex 0) -- | Interpret an instruction in vacuum, putting no extra contraints on -- its execution. @@ -259,7 +262,11 @@ runEvalOp (runInstr instr inpSt) env - InterpreterState{ isMorleyLogs = MorleyLogs [], isRemainingSteps = 9999999999 } + InterpreterState + { isMorleyLogs = MorleyLogs [] + , isRemainingSteps = 9999999999 + , isOriginationNonce = OriginationIndex 0 + } data SomeItStack where SomeItStack :: T.ExtInstr inp -> Rec T.Value inp -> SomeItStack @@ -271,8 +278,9 @@ instance NFData RemainingSteps data InterpreterState = InterpreterState - { isMorleyLogs :: MorleyLogs + { isMorleyLogs :: MorleyLogs , isRemainingSteps :: RemainingSteps + , isOriginationNonce :: OriginationIndex } deriving stock (Show, Generic) instance NFData InterpreterState @@ -365,8 +373,10 @@ go = \case (SZ, stack) -> stack (SS s', a :& b :& r) -> b :& go (s', a :& r) +runInstrImpl _ SOME (a :& r) = + withValueTypeSanity a $ + pure $ VOption (Just a) :& r runInstrImpl _ (PUSH v) r = pure $ v :& r -runInstrImpl _ SOME (a :& r) = pure $ VOption (Just a) :& r runInstrImpl _ NONE r = pure $ VOption Nothing :& r runInstrImpl _ UNIT r = pure $ VUnit :& r runInstrImpl runner (IF_NONE _bNone bJust) (VOption (Just a) :& r) = runner bJust (a :& r) @@ -374,8 +384,12 @@ runInstrImpl _ PAIR (a :& b :& r) = pure $ VPair (a, b) :& r runInstrImpl _ (AnnCAR _) (VPair (a, _b) :& r) = pure $ a :& r runInstrImpl _ (AnnCDR _) (VPair (_a, b) :& r) = pure $ b :& r -runInstrImpl _ LEFT (a :& r) = pure $ (VOr $ Left a) :& r -runInstrImpl _ RIGHT (b :& r) = pure $ (VOr $ Right b) :& r +runInstrImpl _ LEFT (a :& r) = + withValueTypeSanity a $ + pure $ (VOr $ Left a) :& r +runInstrImpl _ RIGHT (b :& r) = + withValueTypeSanity b $ + pure $ (VOr $ Right b) :& r runInstrImpl runner (IF_LEFT bLeft _) (VOr (Left a) :& r) = runner bLeft (a :& r) runInstrImpl runner (IF_LEFT _ bRight) (VOr (Right a) :& r) = runner bRight (a :& r) -- More here @@ -518,8 +532,22 @@ runInstrImpl _ (CREATE_CONTRACT contract) (VOption mbKeyHash :& VMutez m :& g :& r) = do originator <- ceSelf <$> ask + + originationNonce <- isOriginationNonce <$> get + opHash <- ceOperationHash <$> ask + modify $ \iState -> + iState { isOriginationNonce = OriginationIndex $ (unOriginationIndex $ isOriginationNonce iState) + 1 } let ops = cCode contract - let resAddr = U.mkContractAddress $ createOrigOp originator mbKeyHash m ops g + let resAddr = + case opHash of + Just hash -> mkContractAddress hash originationNonce + Nothing -> + mkContractAddress + (U.mkOriginationOperationHash (createOrigOp originator mbKeyHash m ops g) (U.GlobalCounter 0)) + -- If opHash is Nothing it means that interpreter is running in some kind of test + -- context, therefore we generate dummy contract address with its own origination + -- operation and counter set to 0. + originationNonce let resEpAddr = EpAddress resAddr def let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops pure $ VOp (OpCreateContract resOp) @@ -629,4 +657,4 @@ (e :& _, SZ) -> cont e (_ :& es, SS n) -> loop (es, n) -$(deriveGADTNFData ''MichelsonFailed) +(deriveGADTNFData ''MichelsonFailed) diff --git a/src/Michelson/Interpret/Unpack.hs b/src/Michelson/Interpret/Unpack.hs --- a/src/Michelson/Interpret/Unpack.hs +++ b/src/Michelson/Interpret/Unpack.hs @@ -40,17 +40,17 @@ import qualified Data.Set as Set import Data.Singletons (Sing, SingI(..)) import Data.Typeable ((:~:)(..)) -import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+)) -import Text.Hex (encodeHex) +import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (|+)) import Michelson.Parser (Parser, ParserException(..), parseNoEnv) import qualified Michelson.Parser.Annotations as PA import Michelson.Text import Michelson.TypeCheck - (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..), TypeContext(..), withWTPm) + (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..), + TypeContext(..), withWTPm) import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1) import Michelson.TypeCheck.Instr (typeCheckList) -import Michelson.Typed (RemFail(..), SingT(..), starNotes) +import Michelson.Typed (KnownT, RemFail(..), SingT(..), starNotes) import qualified Michelson.Typed as T import Michelson.Typed.EntryPoints import Michelson.Typed.Scope (UnpackedValScope) @@ -63,21 +63,12 @@ import qualified Tezos.Crypto.Ed25519 as Ed25519 import qualified Tezos.Crypto.P256 as P256 import qualified Tezos.Crypto.Secp256k1 as Secp256k1 +import Util.Binary (UnpackError (..), ensureEnd, launchGet) ---------------------------------------------------------------------------- -- Helpers ---------------------------------------------------------------------------- --- | Any decoding error. -newtype UnpackError = UnpackError { unUnpackError :: Text } - deriving stock (Show, Eq) - -instance Buildable UnpackError where - build (UnpackError msg) = build msg - -instance Exception UnpackError where - displayException = pretty - -- | Alias for label attaching. (?) :: Get a -> String -> Get a (?) = flip Get.label @@ -141,14 +132,6 @@ -- @PACK@, neither @UNPACK@ seem to expect them, so for now we pretend -- that annotations do not exist. -ensureEnd :: Get () -ensureEnd = - unlessM Get.isEmpty $ do - remainder <- Get.getRemainingLazyByteString - fail $ "Expected end of entry, unconsumed bytes \ - \(" +| length remainder |+ "): " - +|| encodeHex (LBS.toStrict remainder) ||+ "" - -- | Like 'many', but doesn't backtrack if next entry failed to parse -- yet there are some bytes to consume ahead. -- @@ -183,12 +166,6 @@ Nothing -> unknownTag what tag Just TaggedDecoder{..} -> tdDecoder -launchGet :: Get a -> LByteString -> Either UnpackError a -launchGet decoder bs = - case Get.runGetOrFail decoder bs of - Left (_remainder, _offset, err) -> Left . UnpackError $ toText err - Right (_remainder, _offset, res) -> Right res - ---------------------------------------------------------------------------- -- Michelson serialisation ---------------------------------------------------------------------------- @@ -329,7 +306,7 @@ T.VAddress <$> decodeEpAddress withUnpackedValueScope - :: forall a v m. (Typeable a, SingI a, MonadFail m) + :: forall a v m. (KnownT a, MonadFail m) => (T.UnpackedValScope a => m v) -> m v withUnpackedValueScope act = case T.checkScope @(T.UnpackedValScope a) of @@ -490,7 +467,7 @@ -- | Type check instruction occured from a lambda. decodeTypeCheckLam :: forall inp out m. - (Typeable inp, SingI inp, T.WellTyped inp, SingI out, Typeable out, T.WellTyped out, MonadFail m) + (T.WellTyped inp, T.WellTyped out, MonadFail m) => [ExpandedOp] -> m (RemFail T.Instr '[inp] '[out]) decodeTypeCheckLam uinstr = diff --git a/src/Michelson/Parser/Lexer.hs b/src/Michelson/Parser/Lexer.hs --- a/src/Michelson/Parser/Lexer.hs +++ b/src/Michelson/Parser/Lexer.hs @@ -22,7 +22,7 @@ import Data.Char (isDigit, isLower, toLower) import qualified Data.Text as T import Text.Megaparsec (MonadParsec, Tokens, between, satisfy) -import Text.Megaparsec.Char (lowerChar, space1, string) +import Text.Megaparsec.Char (lowerChar, space, space1, string) import qualified Text.Megaparsec.Char.Lexer as L import Michelson.Parser.Types (Parser) @@ -33,7 +33,10 @@ lexeme = L.lexeme mSpace mSpace :: Parser () -mSpace = L.space space1 (L.skipLineComment "#") (L.skipBlockComment "/*" "*/") +mSpace = L.space space1 + (L.skipLineComment "#") + (L.skipBlockComment "/*" "*/" >> space >> void (optional semicolon)) + symbol :: Tokens Text -> Parser () symbol = void . L.symbol mSpace diff --git a/src/Michelson/Runtime.hs b/src/Michelson/Runtime.hs --- a/src/Michelson/Runtime.hs +++ b/src/Michelson/Runtime.hs @@ -28,15 +28,29 @@ , ExecutorRes (..) , ExecutorError' (..) , ExecutorError - , executorPure + , ExecutorM + , runExecutorM + , runExecutorMWithDB + , withGlobalOperation + , executeGlobalOperations + , executeOrigination + , executeTransfer -- * To avoid warnings (can't generate lenses only for some fields) , erInterpretResults , erUpdates + , erGState + , erRemainingSteps + , elInterpreterResults + , elUpdates ) where -import Control.Lens (at, makeLenses, (%=)) -import Control.Monad.Except (Except, runExcept, throwError) +import Control.Lens (at, makeLenses, (+=), (.=), (<>=)) +import Control.Monad.Except (Except, liftEither, runExcept, throwError) +import qualified Data.Aeson as Aeson +import Data.Binary.Put (putWord64be, runPut) +import qualified Data.ByteString.Lazy as BSL +import Data.Semigroup.Generic import Data.Text.IO (getContents) import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+)) import Named ((:!), (:?), arg, argDef, defaults, (!)) @@ -55,11 +69,13 @@ (CreateContract(..), EpName, Operation'(..), SomeValue'(..), TransferTokens(..), convertContractCode, untypeValue) import qualified Michelson.Typed as T -import Michelson.Untyped (Contract, OriginationOperation(..), mkContractAddress) +import Michelson.Untyped + (Contract, GlobalCounter(..), OperationHash(..), OriginationOperation(..), + mkOriginationOperationHash) import qualified Michelson.Untyped as U -import Tezos.Address (Address(..)) +import Tezos.Address (Address(..), OriginationIndex(..), mkContractAddress) import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, toMutez, unsafeAddMutez, unsafeSubMutez) -import Tezos.Crypto (parseKeyHash) +import Tezos.Crypto (blake2b, parseKeyHash) import Util.IO (readFileUtf8) ---------------------------------------------------------------------------- @@ -85,37 +101,46 @@ data ExecutorRes = ExecutorRes { _erGState :: GState -- ^ New 'GState'. - , _erOperations :: [ExecutorOp] - -- ^ List of operations to be added to the operations queue. , _erUpdates :: [GStateUpdate] -- ^ Updates applied to 'GState'. , _erInterpretResults :: [(Address, InterpretResult)] -- ^ During execution a contract can print logs and in the end it returns -- a pair. All logs and returned values are kept until all called contracts -- are executed. In the end they are printed. - , _erSourceAddress :: Maybe Address - -- ^ As soon as transfer operation is encountered, this address is - -- set to its input. , _erRemainingSteps :: RemainingSteps -- ^ Now much gas all remaining executions can consume. } deriving stock (Show) -makeLenses ''ExecutorRes +data ExecutorEnv = ExecutorEnv + { _eeOperationHash :: ~OperationHash + , _eeNow :: Timestamp + } + deriving stock (Show, Generic) --- Note that it's not commutative. --- It applies to the case when we have some ExecutorRes already --- and get a new one after performing some operations. -instance Semigroup ExecutorRes where - a <> b = - b - { _erUpdates = _erUpdates a <> _erUpdates b - , _erInterpretResults = _erInterpretResults a <> _erInterpretResults b - , _erSourceAddress = _erSourceAddress a <|> _erSourceAddress b - } +data ExecutorState = ExecutorState + { _esGState :: GState + , _esRemainingSteps :: RemainingSteps + , _esOriginationNonce :: Int32 + , _esSourceAddress :: Maybe Address + , _esLog :: ExecutorLog + } + deriving stock (Show, Generic) +data ExecutorLog = ExecutorLog + { _elUpdates :: [GStateUpdate] + , _elInterpreterResults :: [(Address, InterpretResult)] + } + deriving stock (Show, Generic) + deriving (Semigroup, Monoid) via GenericSemigroupMonoid ExecutorLog + +makeLenses ''ExecutorRes +makeLenses ''ExecutorEnv +makeLenses ''ExecutorState +makeLenses ''ExecutorLog + -- | Errors that can happen during contract interpreting. -- Type parameter @a@ determines how contracts will be represented --- in these errors, e.g. @Address@ +-- in these errors, e.g. 'Address'. data ExecutorError' a = EEUnknownContract !a -- ^ The interpreted contract hasn't been originated. @@ -143,7 +168,7 @@ -- ^ Contract parameter is ill-typed. | EEUnknownEntrypoint EpName -- ^ Specified entrypoint to run is not found. - deriving stock (Show) + deriving stock (Show, Functor) instance (Buildable a) => Buildable (ExecutorError' a) where build = @@ -209,9 +234,9 @@ originateContract dbPath origination verbose = -- pass 100500 as maxSteps, because it doesn't matter for origination, -- as well as 'now' - mkContractAddress origination <$ - executor Nothing 100500 dbPath [OriginateOp origination] verbose - ! defaults + fmap snd $ runExecutorMWithDB Nothing dbPath 100500 verbose ! defaults $ do + withGlobalOperation (OriginateOp origination) + $ executeOrigination origination -- | Run a contract. The contract is originated first (if it's not -- already) and then we pretend that we send a transaction to it. @@ -227,8 +252,14 @@ -> "dryRun" :! Bool -> IO () runContract maybeNow maxSteps initBalance dbPath storageValue contract txData - verbose (arg #dryRun -> dryRun) = - executor maybeNow maxSteps dbPath operations verbose ! #dryRun dryRun + verbose (arg #dryRun -> dryRun) = do + void $ runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do + -- Here we are safe to bypass executeGlobalOperations for origination, + -- since origination can't generate more operations. + addr <- withGlobalOperation (OriginateOp origination) + $ executeOrigination origination + let transferOp = TransferOp addr txData + executeGlobalOperations [transferOp] where -- We hardcode some random key hash here as delegate to make sure that: -- 1. Contract's address won't clash with already originated one (because @@ -245,11 +276,6 @@ , ooStorage = storageValue , ooContract = contract } - addr = mkContractAddress origination - operations = - [ OriginateOp origination - , TransferOp addr txData - ] -- | Send a transaction to given address with given parameters. transfer :: @@ -258,146 +284,186 @@ -> FilePath -> Address -> TxData - -> "verbose" :! Bool -> "dryRun" :? Bool -> IO () -transfer maybeNow maxSteps dbPath destination txData = - executor maybeNow maxSteps dbPath [TransferOp destination txData] + -> "verbose" :! Bool + -> "dryRun" :? Bool + -> IO () +transfer maybeNow maxSteps dbPath destination txData verbose dryRun = do + void $ runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose dryRun $ + executeGlobalOperations [TransferOp destination txData] ---------------------------------------------------------------------------- -- Executor ---------------------------------------------------------------------------- --- | Execute a contract on some global state (read from file) and --- transaction data (passed explicitly). -executor :: - Maybe Timestamp - -> Word64 +-- | A monad in which contract executor runs. +type ExecutorM = + ReaderT ExecutorEnv + (StateT ExecutorState + (Except ExecutorError) + ) + +-- | Run some executor action, returning its result and final executor state in 'ExecutorRes'. +-- +-- The action has access to the hash of currently executed global operation, in order to construct +-- addresses of originated contracts. It is expected that the action uses 'withGlobalOperation' +-- to specify this hash. Otherwise it is initialized with 'error'. +runExecutorM + :: Timestamp + -> RemainingSteps + -> GState + -> ExecutorM a + -> Either ExecutorError (ExecutorRes, a) +runExecutorM now remainingSteps gState action = + fmap preResToRes + $ runExcept + $ runStateT (runReaderT action $ ExecutorEnv initialOpHash now) + initialState + where + initialOpHash = error "Initial OperationHash touched" + + initialState = ExecutorState + { _esGState = gState + , _esRemainingSteps = remainingSteps + , _esOriginationNonce = 0 + , _esSourceAddress = Nothing + , _esLog = mempty + } + + preResToRes :: (a, ExecutorState) -> (ExecutorRes, a) + preResToRes (r, ExecutorState{..}) = + ( ExecutorRes + { _erGState = _esGState + , _erUpdates = _esLog ^. elUpdates + , _erInterpretResults = _esLog ^. elInterpreterResults + , _erRemainingSteps = _esRemainingSteps + } + , r + ) + +-- | Run some executor action, reading state from the DB on disk. +-- +-- Unless @dryRun@ is @False@, the final state is written back to the disk. +-- +-- If the executor fails with 'ExecutorError' it will be thrown as an exception. +runExecutorMWithDB + :: Maybe Timestamp -> FilePath - -> [ExecutorOp] - -> "verbose" :! Bool -> "dryRun" :? Bool -> IO () -executor maybeNow maxSteps dbPath operations + -> RemainingSteps + -> "verbose" :! Bool + -> "dryRun" :? Bool + -> ExecutorM a + -> IO (ExecutorRes, a) +runExecutorMWithDB maybeNow dbPath remainingSteps (arg #verbose -> verbose) (argDef #dryRun False -> dryRun) - = do - now <- maybe getCurrentTime pure maybeNow + action = do gState <- readGState dbPath - let eitherRes = - executorPure now (RemainingSteps maxSteps) gState operations - ExecutorRes {..} <- either throwM pure eitherRes - mapM_ printInterpretResult _erInterpretResults - when (verbose && not (null _erUpdates)) $ do - fmtLn $ nameF "Updates:" (blockListF _erUpdates) - putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps + now <- maybe getCurrentTime pure maybeNow + (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now remainingSteps gState action + unless dryRun $ writeGState dbPath _erGState + + mapM_ printInterpretResult _erInterpretResults + when (verbose && not (null _erUpdates)) $ do + fmtLn $ nameF "Updates" (blockListF _erUpdates) + putTextLn $ "Remaining gas: " <> pretty _erRemainingSteps <> "." + + return (res, a) where printInterpretResult :: (Address, InterpretResult) -> IO () printInterpretResult (addr, InterpretResult {..}) = do putTextLn $ "Executed contract " <> pretty addr case iurOps of - [] -> putTextLn "It didn't return any operations" - _ -> fmt $ nameF "It returned operations:" (blockListF iurOps) + [] -> putTextLn "It didn't return any operations." + _ -> fmt $ nameF "It returned operations" (blockListF iurOps) putTextLn $ - "It returned storage: " <> pretty (untypeValue iurNewStorage) + "It returned storage: " <> pretty (untypeValue iurNewStorage) <> "." let MorleyLogs logs = isMorleyLogs iurNewState unless (null logs) $ mapM_ putTextLn logs putTextLn "" -- extra break line to separate logs from two sequence contracts --- | Implementation of executor outside 'IO'. It reads operations, --- executes them one by one and updates state accordingly. --- Each operation from the passed list is fully executed before --- the next one is considered. -executorPure :: - Timestamp -> RemainingSteps -> GState -> [ExecutorOp] -> Either ExecutorError ExecutorRes -executorPure now maxSteps gState = - foldM step initialState - where - -- Note that we can't just put all operations into '_erOperations' - -- and call 'statefulExecutor' once, because in this case the - -- order of operations will be wrong. We need to consider - -- top-level operations (passed to this function) and operations returned by contracts separatety. - -- Specifically, suppose that we want to interpreter two 'TransferOp's: [t1, t2]. - -- If t1 returns an operation, it should be performed before t2, but if we just - -- pass [t1, t2] as '_erOperations' then 't2' will done immediately after 't1'. - initialState = ExecutorRes - { _erGState = gState - , _erOperations = [] - , _erUpdates = mempty - , _erInterpretResults = [] - , _erSourceAddress = Nothing - , _erRemainingSteps = maxSteps - } - - step :: ExecutorRes -> ExecutorOp -> Either ExecutorError ExecutorRes - step currentRes op = - let start = currentRes { _erOperations = [op] - , _erUpdates = [] - , _erInterpretResults = [] - } - in (currentRes <>) <$> runExcept (execStateT (statefulExecutor now) start) +-- | Run some executor action in a context of global operation. +-- +-- Use this function to execute one global operation, potentially with its internal +-- suboperations. +withGlobalOperation + :: ExecutorOp + -> ExecutorM a + -> ExecutorM a +withGlobalOperation op action = do + counter <- use $ esGState . gsCounterL + -- Reset nonce and source address before executing a global operation. + esOriginationNonce .= 0 + esSourceAddress .= Nothing + local (set eeOperationHash $ mkExecutorOpHash op $ GlobalCounter counter) + $ action -statefulExecutor - :: Timestamp - -> StateT ExecutorRes (Except ExecutorError) () -statefulExecutor now = do - curGState <- use erGState - mSourceAddr <- use erSourceAddress - remainingSteps <- use erRemainingSteps - use erOperations >>= \case - [] -> pass - (op:opsTail) -> - either throwError (processIntRes opsTail) $ - executeOneOp now remainingSteps mSourceAddr curGState op +-- | Execute a list of global operation, discarding their results. +-- +-- Uses 'withGlobalOperation' internally. +executeGlobalOperations + :: [ExecutorOp] + -> ExecutorM () +executeGlobalOperations = mapM_ $ \op -> + withGlobalOperation op $ executeMany [op] where - processIntRes opsTail ir = do - -- Not using `<>=` because it requires `Monoid` for no reason. - id %= (<> ir) - erOperations %= (opsTail <>) - statefulExecutor now + -- | Execute a list of operations and additional operations they return, until there are none. + executeMany :: [ExecutorOp] -> ExecutorM () + executeMany = \case + [] -> pass + (op:opsTail) -> do + case op of + OriginateOp origination -> void $ executeOrigination origination + TransferOp addr txData -> do + moreOps <- executeTransfer addr txData + -- TODO why does opsTail go before moreOps? + executeMany $ opsTail <> moreOps --- | Execute only one operation and update 'GState' accordingly. -executeOneOp - :: Timestamp - -> RemainingSteps - -> Maybe Address - -> GState - -> ExecutorOp - -> Either ExecutorError ExecutorRes -executeOneOp _ remainingSteps _ gs (OriginateOp origination) = do - typedContract <- first EEIllTypedContract $ +-- | Execute an origination operation. +executeOrigination + :: OriginationOperation + -> ExecutorM Address +executeOrigination origination = do + opHash <- view eeOperationHash + gs <- use esGState + originationNonce <- use esOriginationNonce + + typedContract <- liftEither $ first EEIllTypedContract $ typeCheckContract (extractAllContracts gs) (ooContract origination) - typedStorage <- first EEIllTypedStorage $ + typedStorage <- liftEither $ first EEIllTypedStorage $ typeCheckTopLevelType (extractAllContracts gs) (U.contractStorage $ ooContract origination) (ooStorage origination) let originatorAddress = ooOriginator origination - originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of - Nothing -> Left (EEUnknownManager originatorAddress) + originatorBalance <- case gsAddresses gs ^. at originatorAddress of + Nothing -> throwError (EEUnknownManager originatorAddress) Just (asBalance -> oldBalance) | oldBalance < ooBalance origination -> - Left (EENotEnoughFunds originatorAddress oldBalance) + throwError $ EENotEnoughFunds originatorAddress oldBalance | otherwise -> -- Subtraction is safe because we have checked its -- precondition in guard. - Right (oldBalance `unsafeSubMutez` ooBalance origination) + return $ oldBalance `unsafeSubMutez` ooBalance origination let + address = mkContractAddress opHash $ OriginationIndex originationNonce updates = [ GSAddAddress address (ASContract $ mkContractState typedContract typedStorage) , GSSetBalance originatorAddress originatorBalance + , GSIncrementCounter ] case applyUpdates updates gs of Left _ -> - Left (EEAlreadyOriginated address $ mkContractState typedContract typedStorage) - Right newGS -> Right $ - ExecutorRes - { _erGState = newGS - , _erOperations = mempty - , _erUpdates = updates - , _erInterpretResults = [] - , _erSourceAddress = Nothing - , _erRemainingSteps = remainingSteps - } + throwError $ EEAlreadyOriginated address $ mkContractState typedContract typedStorage + Right newGS -> do + esGState .= newGS + esOriginationNonce += 1 + + esLog <>= ExecutorLog updates [] + + return address where mkContractState typedContract typedStorage = ContractState { csBalance = ooBalance origination @@ -406,8 +472,20 @@ , csTypedContract = Just typedContract , csTypedStorage = Just typedStorage } - address = mkContractAddress origination -executeOneOp now remainingSteps mSourceAddr gs (TransferOp addr txData) = do + +-- | Execute a transfer operation. +executeTransfer + :: Address + -> TxData + -> ExecutorM [ExecutorOp] +executeTransfer addr txData = do + now <- view eeNow + gs <- use esGState + remainingSteps <- use esRemainingSteps + mSourceAddr <- use esSourceAddress + + opHash <- view eeOperationHash + let addresses = gsAddresses gs let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr let senderAddr = tdSenderAddress txData let isKeyAddress (KeyAddress _) = True @@ -416,23 +494,22 @@ -- Transferring 0 XTZ to a key address is prohibited. when (isZeroTransfer && isKeyAddress addr) $ - Left (EEZeroTransaction addr) - + throwError $ EEZeroTransaction addr mDecreaseSenderBalance <- case (isZeroTransfer, addresses ^. at senderAddr) of (True, _) -> pure Nothing - (False, Nothing) -> Left (EEUnknownSender senderAddr) + (False, Nothing) -> throwError $ EEUnknownSender senderAddr (False, Just (asBalance -> balance)) | balance < tdAmount txData -> - Left (EENotEnoughFunds senderAddr balance) + throwError $ EENotEnoughFunds senderAddr balance | otherwise -> -- Subtraction is safe because we have checked its -- precondition in guard. - Right (Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)) - let onlyUpdates updates = Right (updates, [], Nothing, remainingSteps) - (otherUpdates, sideEffects, maybeInterpretRes, newRemSteps) + return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData) + let onlyUpdates updates = return (updates, [], Nothing, remainingSteps) + (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps) <- case (addresses ^. at addr, addr) of (Nothing, ContractAddress _) -> - Left (EEUnknownContract addr) + throwError $ EEUnknownContract addr (Nothing, KeyAddress _) -> do let transferAmount = tdAmount txData @@ -462,22 +539,23 @@ , ceSender = senderAddr , ceAmount = tdAmount txData , ceChainId = gsChainId gs + , ceOperationHash = Just opHash } epName = tdEntrypoint txData SomeContractAndStorage typedContract typedStorage - <- getTypedContractAndStorage EEIllTypedContract EEIllTypedStorage gs cs + <- liftEither $ getTypedContractAndStorage EEIllTypedContract EEIllTypedStorage gs cs T.MkEntryPointCallRes _ epc <- T.mkEntryPointCall epName (T.cParamNotes typedContract) & maybe (throwError $ EEUnknownEntrypoint epName) pure - typedParameter <- first EEIllTypedParameter $ + typedParameter <- liftEither $ first EEIllTypedParameter $ typeVerifyTopLevelType existingContracts (tdParameter txData) iur@InterpretResult { iurOps = sideEffects , iurNewStorage = newValue - , iurNewState = InterpreterState _ newRemainingSteps + , iurNewState = InterpreterState _ newRemainingSteps _ } - <- first (EEInterpreterFailed addr) $ + <- liftEither $ first (EEInterpreterFailed addr) $ handleContractReturn $ interpret (T.cCode typedContract) epc typedParameter typedStorage contractEnv @@ -493,28 +571,26 @@ [ updBalance , updStorage ] - Right (updates, sideEffects, Just iur, newRemainingSteps) + return (updates, sideEffects, Just iur, newRemainingSteps) let - updates = maybe id (:) mDecreaseSenderBalance otherUpdates + -- According to the reference implementation, counter is incremented for transfers as well. + updates = (maybe id (:) mDecreaseSenderBalance otherUpdates) ++ [GSIncrementCounter] - newGState <- first EEFailedToApplyUpdates $ applyUpdates updates gs + newGState <- liftEither $ first EEFailedToApplyUpdates $ applyUpdates updates gs - return ExecutorRes - { _erGState = newGState - , _erOperations = mapMaybe (convertOp addr) sideEffects - , _erUpdates = updates - , _erInterpretResults = maybe mempty (one . (addr,)) maybeInterpretRes - , _erSourceAddress = Just sourceAddr - , _erRemainingSteps = newRemSteps - } - where - addresses :: Map Address AddressState - addresses = gsAddresses gs + esGState .= newGState + esRemainingSteps .= newRemSteps + esSourceAddress .= Just sourceAddr + esLog <>= ExecutorLog updates (maybe mempty (one . (addr, )) maybeInterpretRes) + + return $ mapMaybe (convertOp addr) sideEffects + ---------------------------------------------------------------------------- -- TypeCheck ---------------------------------------------------------------------------- + typeCheckWithDb :: FilePath -> U.Contract @@ -526,6 +602,18 @@ ---------------------------------------------------------------------------- -- Simple helpers ---------------------------------------------------------------------------- + +mkExecutorOpHash :: ExecutorOp -> GlobalCounter -> OperationHash +mkExecutorOpHash (OriginateOp op) counter = mkOriginationOperationHash op counter +mkExecutorOpHash (TransferOp addr txData) counter = mkTransferOperationHash addr txData counter + +-- TODO [#235] replace JSON-based encoding of transfer operation hash with +-- one more close to reference Tezos implementation. +mkTransferOperationHash :: Address -> TxData -> GlobalCounter -> OperationHash +mkTransferOperationHash addr txData (GlobalCounter counter) = + OperationHash $ blake2b + $ BSL.toStrict + $ Aeson.encode addr <> Aeson.encode txData <> runPut (putWord64be counter) -- The argument is the address of the contract that generation this operation. convertOp :: Address -> T.Operation -> Maybe ExecutorOp diff --git a/src/Michelson/Runtime/GState.hs b/src/Michelson/Runtime/GState.hs --- a/src/Michelson/Runtime/GState.hs +++ b/src/Michelson/Runtime/GState.hs @@ -19,6 +19,7 @@ , GState (..) , gsChainIdL , gsAddressesL + , gsCounterL , genesisAddresses , genesisKeyHashes , genesisAddress @@ -151,6 +152,8 @@ -- ^ Identifier of chain. , gsAddresses :: Map Address AddressState -- ^ All known addresses and their state. + , gsCounter :: Word64 + -- ^ Ever increasing operation counter. } deriving stock (Show) makeLensesWith postfixLFields ''GState @@ -243,6 +246,7 @@ ?: error "Number of genesis addresses is 0" , genesis <- toList genesisAddresses ] + , gsCounter = 0 } data GStateParseError = @@ -280,6 +284,7 @@ = GSAddAddress Address AddressState | GSSetStorageValue Address Value SomeValue | GSSetBalance Address Mutez + | GSIncrementCounter deriving stock (Show) instance Buildable GStateUpdate where @@ -291,6 +296,8 @@ "Set storage value of address " +| addr |+ " to " +| val |+ "" GSSetBalance addr balance -> "Set balance of address " +| addr |+ " to " +| balance |+ "" + GSIncrementCounter -> + "Increment internal counter after operation" data GStateUpdateError = GStateAddressExists Address @@ -314,6 +321,7 @@ GSSetStorageValue addr newValue newTypedValue -> setStorageValue addr newValue newTypedValue GSSetBalance addr newBalance -> setBalance addr newBalance + GSIncrementCounter -> Right . over gsCounterL (+1) -- | Apply a list of 'GStateUpdate's to 'GState'. applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState diff --git a/src/Michelson/Runtime/TxData.hs b/src/Michelson/Runtime/TxData.hs --- a/src/Michelson/Runtime/TxData.hs +++ b/src/Michelson/Runtime/TxData.hs @@ -13,10 +13,12 @@ ) where import Control.Lens (makeLensesWith) +import Data.Aeson.TH (deriveJSON) import Michelson.Untyped (EpName, Value) import Tezos.Address (Address) import Tezos.Core (Mutez) +import Util.Aeson (morleyAesonOptions) import Util.Lens (postfixLFields) -- | Data associated with a particular transaction. @@ -28,3 +30,4 @@ } deriving stock (Show, Eq) makeLensesWith postfixLFields ''TxData +deriveJSON morleyAesonOptions ''TxData diff --git a/src/Michelson/Test.hs b/src/Michelson/Test.hs --- a/src/Michelson/Test.hs +++ b/src/Michelson/Test.hs @@ -29,18 +29,16 @@ -- * Integrational testing -- ** Testing engine - , IntegrationalValidator - , SuccessValidator , IntegrationalScenario , IntegrationalScenarioM , integrationalTestExpectation - , integrationalTestProperty + , integrationalTestProp , originate , tOriginate , transfer , tTransfer - , validate , integrationalFail + , unexpectedInterpreterError , setMaxSteps , setNow , rewindTime @@ -50,9 +48,6 @@ , (?-) -- ** Validators - , composeValidators - , composeValidatorsList - , expectAnySuccess , expectNoUpdates , expectNoStorageUpdates , expectStorageUpdate @@ -61,6 +56,11 @@ , expectStorage , expectStorageConst , tExpectStorageConst + + -- ** Errors + , attempt + , expectError + , catchExpectedError , expectGasExhaustion , expectMichelsonFailed @@ -69,11 +69,20 @@ , genesisAddress -- * General utilities - , failedProp - , succeededProp - , qcIsLeft - , qcIsRight + , failedTest + , succeededTest + , eitherIsLeft + , eitherIsRight + , total + , meanTimeUpperBoundProp + , meanTimeUpperBoundPropNF + -- * Re-exports + -- + -- | These functions from "Time" are re-exported here to make it convenient to call + -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'. + , mcs, ms, sec, minute + -- * Autodoc testing , runDocTests , testDocBasic @@ -86,6 +95,13 @@ , minTimestamp , maxTimestamp , midTimestamp + + -- * Deprecated + , integrationalTestProperty + , failedProp + , succeededProp + , qcIsLeft + , qcIsRight ) where import Michelson.Doc.Test diff --git a/src/Michelson/Test/Dummy.hs b/src/Michelson/Test/Dummy.hs --- a/src/Michelson/Test/Dummy.hs +++ b/src/Michelson/Test/Dummy.hs @@ -43,6 +43,7 @@ , ceSender = genesisAddress , ceAmount = unsafeMkMutez 100 , ceChainId = dummyChainId + , ceOperationHash = Nothing } -- | 'OriginationOperation' with most data hardcoded to some diff --git a/src/Michelson/Test/Gen.hs b/src/Michelson/Test/Gen.hs --- a/src/Michelson/Test/Gen.hs +++ b/src/Michelson/Test/Gen.hs @@ -5,22 +5,41 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- | Utilities for arbitrary data generation in property tests. +-- +-- == Deprecation Notice +-- +-- At the moment, this module exposes both Hedgehog generators and QuickCheck `Arbitrary` +-- instances for convenience. +-- However, `Arbitrary` instances should be considered deprecated and will eventually be removed. module Michelson.Test.Gen ( minTimestamp , maxTimestamp , midTimestamp + , genMutez + , genTimestamp + , genValueKeyHash + , genValueMutez + , genValueInt + , genValueList + , genValueUnit + , genValuePair + , genValueTimestamp ) where import Data.Time.Calendar (Day, addDays, diffDays) import Data.Time.Clock (UTCTime(..)) import Data.Time.Format (defaultTimeLocale, parseTimeM) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary(..), choose) -import Michelson.Typed (T(..), Value'(..)) +import Michelson.Typed (KnownT, T(..), Value'(..)) import Tezos.Core (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds, unsafeMkMutez) +import Tezos.Crypto (genKeyHash) instance Arbitrary (Value' instr 'TKeyHash) where arbitrary = VKeyHash <$> arbitrary @@ -28,7 +47,8 @@ arbitrary = VMutez <$> arbitrary instance Arbitrary (Value' instr 'TInt) where arbitrary = VInt <$> arbitrary -instance Arbitrary (Value' instr a) => Arbitrary (Value' instr ('TList a)) where +instance (KnownT a, Arbitrary (Value' instr a)) => + Arbitrary (Value' instr ('TList a)) where arbitrary = VList <$> arbitrary instance Arbitrary (Value' instr 'TUnit) where arbitrary = pure VUnit @@ -36,6 +56,25 @@ => Arbitrary (Value' instr ('TPair a b)) where arbitrary = VPair ... (,) <$> arbitrary <*> arbitrary +genValueKeyHash :: MonadGen m => m (Value' instr 'TKeyHash) +genValueKeyHash = VKeyHash <$> genKeyHash + +genValueMutez :: MonadGen m => m (Value' instr 'TMutez) +genValueMutez = VMutez <$> genMutez + +genValueInt :: MonadGen m => m (Value' instr 'TInt) +genValueInt = VInt <$> Gen.integral (Range.linearFrom 0 -1000 1000) + +genValueList :: (MonadGen m, KnownT a) => m (Value' instr a) -> m (Value' instr ('TList a)) +genValueList genA = VList <$> Gen.list (Range.linear 0 100) genA + +genValueUnit :: Applicative m => m (Value' instr 'TUnit) +genValueUnit = pure VUnit + +genValuePair :: MonadGen m => m (Value' instr a) -> m (Value' instr b) -> m (Value' instr ('TPair a b)) +genValuePair genA genB = VPair ... (,) <$> genA <*> genB + + minDay :: Day minDay = fromMaybe (error "failed to parse day 2008-11-01") $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01" @@ -76,3 +115,14 @@ arbitrary = timestampFromSeconds <$> choose (timestampToSeconds minTimestamp, timestampToSeconds maxTimestamp) + +genValueTimestamp :: MonadGen m => m (Value' instr 'TTimestamp) +genValueTimestamp = VTimestamp <$> genTimestamp + +genMutez :: MonadGen m => m Mutez +genMutez = unsafeMkMutez <$> Gen.word64 (Range.linear (unMutez minBound) (unMutez maxBound)) + +genTimestamp :: MonadGen m => m Timestamp +genTimestamp = + timestampFromSeconds <$> Gen.integral + (Range.linear (timestampToSeconds minTimestamp) (timestampToSeconds maxTimestamp)) diff --git a/src/Michelson/Test/Import.hs b/src/Michelson/Test/Import.hs --- a/src/Michelson/Test/Import.hs +++ b/src/Michelson/Test/Import.hs @@ -25,7 +25,7 @@ ) where import Control.Exception (IOException) -import Data.Singletons (SingI, demote) +import Data.Singletons (demote) import Data.Typeable ((:~:)(..), eqT) import Fmt (Buildable(build), pretty, (+|), (|+)) import Test.Hspec (Spec, describe, expectationFailure, it, runIO) @@ -36,7 +36,7 @@ import Michelson.Parser.Error (ParserException(..)) import Michelson.Runtime (parseExpandContract, prepareContract) import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract) -import Michelson.Typed (Contract(..), toUType) +import Michelson.Typed (Contract(..), KnownT, toUType) import qualified Michelson.Untyped as U import Util.IO @@ -51,7 +51,7 @@ -- (so test tree will likely be generated unexceptionally, but a failing -- result will notify about problem). testTreesWithContract - :: (Each [Typeable, SingI] [cp, st], HasCallStack) + :: (Each '[KnownT] [cp, st], HasCallStack) => FilePath -> ((U.Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree] testTreesWithContract = testTreesWithContractImpl importContract @@ -64,7 +64,7 @@ -- | Like 'testTreesWithContract' but supplies only typed contract. testTreesWithTypedContract - :: (Each [Typeable, SingI] [cp, st], HasCallStack) + :: (Each '[KnownT] [cp, st], HasCallStack) => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree] testTreesWithTypedContract = testTreesWithContractImpl (fmap snd . importContract) @@ -97,14 +97,14 @@ -- will be generated (so tests will likely run unexceptionally, but a failing -- result will notify about problem). specWithContract - :: (Each [Typeable, SingI] [cp, st], HasCallStack) + :: (Each '[KnownT] [cp, st], HasCallStack) => FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec specWithContract = specWithContractImpl importContract -- | A version of 'specWithContract' which passes only the typed -- representation of the contract. specWithTypedContract - :: (Each [Typeable, SingI] [cp, st], HasCallStack) + :: (Each '[KnownT] [cp, st], HasCallStack) => FilePath -> (Contract cp st -> Spec) -> Spec specWithTypedContract = specWithContractImpl (fmap snd . importContract) @@ -138,7 +138,7 @@ readContract :: forall cp st . - Each [Typeable, SingI] [cp, st] + Each '[KnownT] [cp, st] => FilePath -> Text -> Either ImportContractError (U.Contract, Contract cp st) @@ -161,7 +161,7 @@ -- This function may throw 'IOException' and 'ImportContractError'. importContract :: forall cp st . - Each [Typeable, SingI] [cp, st] + Each '[KnownT] [cp, st] => FilePath -> IO (U.Contract, Contract cp st) importContract file = either throwM pure =<< readContract file <$> readFileUtf8 file diff --git a/src/Michelson/Test/Integrational.hs b/src/Michelson/Test/Integrational.hs --- a/src/Michelson/Test/Integrational.hs +++ b/src/Michelson/Test/Integrational.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- SPDX-FileCopyrightText: 2020 Tocqueville Group -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ @@ -19,19 +21,17 @@ , genesisAddress6 -- * Testing engine - , IntegrationalValidator - , SuccessValidator , IntegrationalScenarioM , IntegrationalScenario - , ValidationError (..) + , TestError (..) , integrationalTestExpectation - , integrationalTestProperty + , integrationalTestProp , originate , tOriginate , transfer , tTransfer - , validate , integrationalFail + , unexpectedInterpreterError , setMaxSteps , modifyNow , setNow @@ -43,9 +43,6 @@ , offshoot -- * Validators - , composeValidators - , composeValidatorsList - , expectAnySuccess , expectNoUpdates , expectNoStorageUpdates , expectStorageUpdate @@ -54,33 +51,43 @@ , expectStorage , expectStorageConst , tExpectStorageConst + + -- * Errors + , attempt + , expectError + , catchExpectedError , expectGasExhaustion , expectMichelsonFailed -- * Lenses , isGState + + -- * Deprecated + , integrationalTestProperty ) where import Control.Lens (assign, at, makeLenses, makeLensesFor, modifying, (%=), (.=), (<>=), (?=)) -import Control.Monad.Except (Except, runExcept, throwError, withExcept) +import Control.Monad.Except (Except, catchError, runExcept, throwError, withExcept) import qualified Data.List as List import Data.Map as Map (empty, insert, lookup) import Fmt (Buildable(..), blockListF, listF, pretty, (+|), (|+)) +import Hedgehog (MonadTest) import Named ((:!), arg) import Test.Hspec (Expectation, expectationFailure) -import Test.QuickCheck (Property) +import qualified Test.QuickCheck as QC import Michelson.Interpret (InterpretError(..), MichelsonFailed(..), RemainingSteps) import Michelson.Runtime - (ExecutorError, ExecutorError'(..), ExecutorOp(..), ExecutorRes(..), executorPure) + (ExecutorError, ExecutorError'(..), ExecutorM, ExecutorOp(..), ExecutorRes(..), + executeGlobalOperations, executeOrigination, runExecutorM, withGlobalOperation) import Michelson.Runtime.GState import Michelson.Runtime.TxData import Michelson.Test.Dummy -import Michelson.Test.Util (failedProp, succeededProp) +import Michelson.Test.Util (failedProp, failedTest, succeededProp, succeededTest) import Michelson.TypeCheck (TCError) import qualified Michelson.Typed as Typed import Michelson.Typed.Scope (ParameterScope, StorageScope, properParameterEvi, withDict) -import Michelson.Untyped (Contract, EpName, OriginationOperation(..), Value, mkContractAddress) +import Michelson.Untyped (Contract, EpName, OriginationOperation(..), Value) import Tezos.Address (Address) import Tezos.Core (ChainId, Mutez, Timestamp, timestampPlusSeconds, unsafeMkMutez) @@ -89,15 +96,16 @@ ---------------------------------------------------------------------------- -- | A result of an executed operation. -type ExecutorResOrError = Either ExecutorError ExecutorRes +type ExecutorResOrError a = Either ExecutorError (ExecutorRes, a) +type ExecutorResOrError' = Either ExecutorError ExecutorRes data InternalState = InternalState { _isMaxSteps :: RemainingSteps , _isNow :: Timestamp , _isGState :: GState - , _isInterpreterLog :: [ExecutorResOrError] + , _isInterpreterLog :: [ExecutorResOrError'] -- ^ Store result of interpreted operations as they added. - , _isExecutorResult :: Maybe ExecutorResOrError + , _isExecutorResult :: Maybe ExecutorRes -- ^ Store the most recent result of interpreted operations. , _isContractsNames :: Map Address Text -- ^ Map from contracts addresses to humanreadable names. @@ -119,23 +127,11 @@ -- Interface ---------------------------------------------------------------------------- --- | Validator for integrational testing. --- If an error is expected, it should be 'Left' with validator for errors. --- Otherwise it should check final global state and its updates. -type IntegrationalValidator = Either (ExecutorError -> Bool) SuccessValidator - --- | Validator for integrational testing that expects successful execution. -type SuccessValidator = InternalState -> GState -> [GStateUpdate] -> Either ValidationError () - -- | A monad inside which integrational tests can be described using -- do-notation. type IntegrationalScenarioM = StateT InternalState (Except ScenarioError) --- | A dummy data type that ensures that `validate` is called in the --- end of each scenario. It is intentionally not exported. -data Validated = Validated - -type IntegrationalScenario = IntegrationalScenarioM Validated +type IntegrationalScenario = IntegrationalScenarioM () newtype ExpectedStorage = ExpectedStorage Value deriving stock (Show) newtype ExpectedBalance = ExpectedBalance Mutez deriving stock (Show) @@ -146,28 +142,35 @@ addrToAddrName addr iState = AddressName (lookup addr (iState ^. isContractsNames)) addr +addrNameToAddr :: AddressName -> Address +addrNameToAddr (AddressName _ addr) = addr + instance Buildable AddressName where build (AddressName mbName addr) = build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName type IntegrationalExecutorError = ExecutorError' AddressName -data ValidationError - = UnexpectedExecutorError IntegrationalExecutorError +data TestError + = InterpreterError IntegrationalExecutorError + | UnexpectedInterpreterError Text IntegrationalExecutorError | UnexpectedTypeCheckError TCError | ExpectingInterpreterToFail - | IncorrectUpdates ValidationError [GStateUpdate] + | IncorrectUpdates TestError [GStateUpdate] | IncorrectStorageUpdate AddressName Text | InvalidStorage AddressName ExpectedStorage Text | StoragePredicateMismatch AddressName Text | InvalidBalance AddressName ExpectedBalance Text | UnexpectedUpdates (NonEmpty GStateUpdate) - | CustomValidationError Text + | ValidatingEmptyScenario + | CustomTestError Text deriving stock (Show) -instance Buildable ValidationError where - build (UnexpectedExecutorError iErr) = - "Unexpected interpreter error. Reason: " +| iErr |+ "" +instance Buildable TestError where + build (InterpreterError iErr) = + "Interpreter failed: " +| iErr |+ "" + build (UnexpectedInterpreterError reason iErr) = + "Unexpected interpreter error. Reason: " +| reason |+ ". Got: " +| iErr |+ "" build (UnexpectedTypeCheckError tcErr) = "Unexpected type check error. Reason: " +| tcErr |+ "" build ExpectingInterpreterToFail = @@ -185,15 +188,17 @@ "Expected " +| addr |+ " to have balance " +| expected |+ ", but " +| msg |+ "" build (UnexpectedUpdates updates) = "Did not expect certain updates, but there are some: " +| listF updates |+ "" - build (CustomValidationError msg) = pretty msg + build ValidatingEmptyScenario = + "Validating empty scenario" + build (CustomTestError msg) = pretty msg -instance Exception ValidationError where +instance Exception TestError where displayException = pretty -- | Overall information about test scenario error. data ScenarioError = ScenarioError { _seBranch :: ScenarioBranchName - , _seError :: ValidationError + , _seError :: TestError } makeLensesFor [("_seBranch", "seBranch")] ''ScenarioError @@ -206,8 +211,7 @@ in builtBranch <> build err -- | Integrational test that executes given operations and validates --- them using given validator. It can fail using 'Expectation' --- capability. +-- them. It can fail using 'Expectation' capability. -- It starts with 'initGState' and some reasonable dummy values for -- gas limit and current timestamp. You can update blockchain state -- by performing some operations. @@ -218,41 +222,53 @@ integrationalTest (maybe pass (expectationFailure . pretty)) -- | Integrational test similar to 'integrationalTestExpectation'. --- It can fail using 'Property' capability. +-- It can fail using 'QC.Property' capability. -- It can be used with QuickCheck's @forAll@ to make a -- property-based test with arbitrary data. -integrationalTestProperty :: IntegrationalScenario -> Property +integrationalTestProperty :: IntegrationalScenario -> QC.Property integrationalTestProperty = integrationalTest (maybe succeededProp (failedProp . pretty)) +{-# DEPRECATED integrationalTestProperty "Use 'integrationalTestProp' instead." #-} +-- | Integrational test similar to 'integrationalTestExpectation'. +-- It can fail using 'Property' capability. +-- It can be used with Hedgehog's @forAll@ to make a +-- property-based test with arbitrary data. +integrationalTestProp :: MonadTest m => IntegrationalScenario -> m () +integrationalTestProp scenario = + integrationalTest (maybe succeededTest (failedTest . pretty)) scenario + -- | Helper function which provides the results of the given operations. -interpret :: [ExecutorOp] -> IntegrationalScenarioM ExecutorResOrError -interpret ops = do +interpret :: ExecutorM a -> IntegrationalScenarioM (ExecutorResOrError a) +interpret action = do now <- use isNow maxSteps <- use isMaxSteps gState <- use isGState - let interpretedResult = executorPure now maxSteps gState ops - whenRight interpretedResult $ \result -> isGState .= _erGState result + let interpretedResult = runExecutorM now maxSteps gState action + whenRight interpretedResult $ \(result, _) -> isGState .= _erGState result return interpretedResult --- | Interprets provided list of operations only if previous interpretation --- succeeded which allows for engine return the earliest error possible. -registerInterpretationIfNeeded :: [ExecutorOp] -> IntegrationalScenarioM () -registerInterpretationIfNeeded ops = do - previousResult <- use isExecutorResult - case previousResult of - Just (Left _) -> pass - _ -> interpret ops >>= putResult +-- | Interprets provided list of operations. +registerInterpretation :: [ExecutorOp] -> IntegrationalScenarioM () +registerInterpretation ops = + interpret (executeGlobalOperations ops) <&> fmap fst >>= putResult -- | Originate a contract with given initial storage and balance. Its -- address is returned. originate :: Contract -> Text -> Value -> Mutez -> IntegrationalScenarioM Address originate contract contractName value balance = do - registerInterpretationIfNeeded [OriginateOp origination] - let address = mkContractAddress origination + is <- get + result <- interpret $ withGlobalOperation (OriginateOp origination) + $ executeOrigination origination + putResult $ fmap fst result + address <- either (interpreterError is) (pure . snd) $ result + isContractsNames %= insert address contractName return address where + interpreterError :: InternalState -> ExecutorError -> IntegrationalScenarioM a + interpreterError is = integrationalFail . InterpreterError . mkError is + origination = (dummyOrigination value contract) {ooBalance = balance} -- | Like 'originate', but for typed contract and value. @@ -272,7 +288,7 @@ transfer txData destination = do mSender <- use isSender let unwrappedData = maybe id (set tdSenderAddressL) mSender txData - registerInterpretationIfNeeded [TransferOp destination unwrappedData] + registerInterpretation [TransferOp destination unwrappedData] -- | Similar to 'transfer', for typed values. -- Note that it works with untyped 'Address' and does not check that @@ -300,31 +316,35 @@ } in transfer txData to --- | Validate the execution result. -validate :: IntegrationalValidator -> IntegrationalScenario -validate validator = Validated <$ do +-- | Validator for integrational testing that expects successful execution. +validate + :: (InternalState -> GState -> [GStateUpdate] -> Either TestError ()) + -> IntegrationalScenario +validate validator = do iState <- get interpreterResult <- use isExecutorResult case interpreterResult of + Nothing -> integrationalFail ValidatingEmptyScenario Just result -> do - whenLeft result $ \_ -> isExecutorResult .= Nothing - validateResult validator result iState - _ -> - failWith "Validating empty scenario" - where - failWith = integrationalFail . CustomValidationError + case validator iState (_erGState result) (_erUpdates result) of + Left bad -> integrationalFail $ IncorrectUpdates bad (_erUpdates result) + Right () -> pass -- | Just fail with given error. -integrationalFail :: ValidationError -> IntegrationalScenarioM anything +integrationalFail :: TestError -> IntegrationalScenarioM anything integrationalFail = throwError . ScenarioError emptyScenarioBranch --- | Make all further interpreter calls (which are triggered by the --- 'validate' function) use modified timestamp as the current one. +-- | Fail a test because an interpreter error happened unexpectedly, with the given reason. +unexpectedInterpreterError :: ExecutorError -> Text -> IntegrationalScenarioM a +unexpectedInterpreterError err reason = do + iState <- get + integrationalFail $ UnexpectedInterpreterError reason (mkError iState err) + +-- | Make all further interpreter calls use the modified timestamp as the current one. modifyNow :: (Timestamp -> Timestamp) -> IntegrationalScenarioM () modifyNow = modifying isNow --- | Make all further interpreter calls (which are triggered by the --- 'validate' function) use given timestamp as the current one. +-- | Make all further interpreter calls use the given timestamp as the current one. setNow :: Timestamp -> IntegrationalScenarioM () setNow time = modifyNow (const time) @@ -332,8 +352,7 @@ rewindTime :: Integer -> IntegrationalScenarioM () rewindTime interval = modifyNow (flip timestampPlusSeconds interval) --- | Make all further interpreter calls (which are triggered by the --- 'validate' function) use given gas limit. +-- | Make all further interpreter calls use the given gas limit. setMaxSteps :: RemainingSteps -> IntegrationalScenarioM () setMaxSteps = assign isMaxSteps @@ -345,16 +364,19 @@ isSender ?= addr scenario <* (isSender .= prevSender) --- | Make all further interpreter calls (which are triggered by the --- 'validate' function) use given chain id. +-- | Make all further interpreter calls use the given chain id. setChainId :: ChainId -> IntegrationalScenarioM () setChainId = assign (isGState . gsChainIdL) -- | Put an interpreted result to InternalState. -putResult :: ExecutorResOrError -> IntegrationalScenarioM () -putResult res = do - isInterpreterLog <>= one res - isExecutorResult .= pure res +putResult :: ExecutorResOrError' -> IntegrationalScenarioM () +putResult resOrErr = do + isInterpreterLog <>= one resOrErr + case resOrErr of + Right res -> isExecutorResult .= Just res + Left err -> do + iState <- get + integrationalFail $ InterpreterError $ mkError iState err -- | Make branch names for a case when we are not within any branch. emptyScenarioBranch :: ScenarioBranchName @@ -381,14 +403,13 @@ -- Providing empty list of scenarios to this function causes error; -- we do not require 'NonEmpty' here though for convenience. branchout :: HasCallStack => [(Text, IntegrationalScenario)] -> IntegrationalScenario -branchout scenarios = do - st <- get - res <- lift . forM scenarios $ \(name, scenario) -> - withExcept (seBranch %~ appendScenarioBranch name) $ - evalStateT scenario st - case nonEmpty res of - Nothing -> error "branch: empty list of scenarios provided" - Just (validated :| _) -> pure validated +branchout scenarios + | null scenarios = error "branch: empty list of scenarios provided" + | otherwise = do + st <- get + lift . forM_ scenarios $ \(name, scenario) -> + withExcept (seBranch %~ appendScenarioBranch name) $ + evalStateT scenario st -- | Make a tuple with name without extra syntactic noise. (?-) :: Text -> a -> (Text, a) @@ -397,30 +418,25 @@ -- | Test given scenario with the state gathered till this moment; -- if this scenario passes, go on as if it never happened. -offshoot :: Text -> IntegrationalScenario -> IntegrationalScenarioM () +offshoot :: Text -> IntegrationalScenario -> IntegrationalScenario offshoot name scenario = do st <- get - Validated <- lift $ + lift $ withExcept (seBranch %~ appendScenarioBranch name) $ evalStateT scenario st - pass ---------------------------------------------------------------------------- --- Validators to be used within 'IntegrationalValidator' +-- Validators ---------------------------------------------------------------------------- --- | 'SuccessValidator' that always passes. -expectAnySuccess :: SuccessValidator -expectAnySuccess _ _ _ = pass - -- | Check that there were no updates. -expectNoUpdates :: SuccessValidator -expectNoUpdates _ _ updates = +expectNoUpdates :: IntegrationalScenario +expectNoUpdates = validate $ \_ _ updates -> maybe pass (throwError . UnexpectedUpdates) . nonEmpty $ updates -- | Check that there were no storage updates. -expectNoStorageUpdates :: SuccessValidator -expectNoStorageUpdates _ _ updates = +expectNoStorageUpdates :: IntegrationalScenario +expectNoStorageUpdates = validate $ \_ _ updates -> maybe pass (throwError . UnexpectedUpdates) . nonEmpty $ filter isStorageUpdate updates where @@ -431,17 +447,16 @@ -- | Check that storage value satisfies the given predicate. expectStorage :: Address - -> (Value -> Either ValidationError ()) - -> SuccessValidator -expectStorage addr predicate is gs _ = + -> (Value -> Either TestError ()) + -> IntegrationalScenario +expectStorage addr predicate = validate $ \is gs _ -> + let intro = StoragePredicateMismatch (addrToAddrName addr is) in case gsAddresses gs ^. at addr of Just (ASContract cs) -> predicate $ csStorage cs Just (ASSimple {}) -> Left $ intro $ "it's a simple address" Nothing -> Left $ intro $ "it's unknown" - where - intro = StoragePredicateMismatch (addrToAddrName addr is) -- | Check that storage value is updated for given address. Takes a -- predicate that is used to check the value. @@ -450,9 +465,9 @@ -- updated more than once). expectStorageUpdate :: Address - -> (Value -> Either ValidationError ()) - -> SuccessValidator -expectStorageUpdate addr predicate is _ updates = + -> (Value -> Either TestError ()) + -> IntegrationalScenario +expectStorageUpdate addr predicate = validate $ \is _ updates -> case List.find checkAddr (reverse updates) of Nothing -> Left $ IncorrectStorageUpdate (addrToAddrName addr is) "storage wasn't updated" @@ -469,35 +484,38 @@ expectStorageUpdateConst :: Address -> Value - -> SuccessValidator -expectStorageUpdateConst addr expected is = - expectStorageUpdate addr predicate is - where + -> IntegrationalScenario +expectStorageUpdateConst addr expected = do + is <- get + let predicate val | val == expected = pass | otherwise = Left $ IncorrectStorageUpdate (addrToAddrName addr is) (pretty expected) + expectStorageUpdate addr predicate -- | Check that eventually address has some particular storage value. -expectStorageConst :: Address -> Value -> SuccessValidator -expectStorageConst addr expected is = expectStorage addr predicate is - where +expectStorageConst :: Address -> Value -> IntegrationalScenario +expectStorageConst addr expected = do + is <- get + let predicate val | val == expected = pass | otherwise = Left $ InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected) (pretty val) + expectStorage addr predicate -- | Similar to 'expectStorageConst', for typed stuff. tExpectStorageConst :: forall st. (StorageScope st) - => Address -> Typed.Value st -> SuccessValidator + => Address -> Typed.Value st -> IntegrationalScenario tExpectStorageConst addr expected = expectStorageConst addr (Typed.untypeValue expected) -- | Check that eventually address has some particular balance. -expectBalance :: Address -> Mutez -> SuccessValidator -expectBalance addr balance is gs _ = +expectBalance :: Address -> Mutez -> IntegrationalScenario +expectBalance addr balance = validate $ \is gs _ -> let realBalance = maybe (unsafeMkMutez 0) asBalance (gsAddresses gs ^. at addr) in if realBalance == balance then pass else @@ -505,38 +523,54 @@ $ InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance) $ "its actual balance is: " <> pretty realBalance --- | Compose two success validators. --- --- For example: --- --- expectBalance bal addr `composeValidators` --- expectStorageUpdateConst addr2 ValueUnit -composeValidators :: - SuccessValidator - -> SuccessValidator - -> SuccessValidator -composeValidators val1 val2 gState updates = - val1 gState updates >> val2 gState updates --- | Compose a list of success validators. -composeValidatorsList :: [SuccessValidator] -> SuccessValidator -composeValidatorsList = foldl' composeValidators expectAnySuccess +-- | Attempt to run an action and return its result or, if interpretation fails, an error. +attempt :: IntegrationalScenarioM a -> IntegrationalScenarioM (Either ExecutorError a) +attempt ma = catchError (Right <$> ma) $ \case + ScenarioError _ (InterpreterError err) -> pure . Left $ addrNameToAddr <$> err + err -> throwError err +-- | Run an action that is expected to fail. +-- If the action fails, the test succeeds and the error is returned. +-- If the action succeeds, the test fails. +expectError :: IntegrationalScenarioM a -> IntegrationalScenarioM ExecutorError +expectError scenario = catchExpectedError scenario pure + +-- | Run an action that is expected to fail. +-- +-- In @action `catchExpectedError` f@: +-- If the action fails, @f@ is applied to the error. +-- If the action succeeds, the test fails. +catchExpectedError + :: IntegrationalScenarioM a + -> (ExecutorError -> IntegrationalScenarioM b) + -> IntegrationalScenarioM b +catchExpectedError scenario handle = + attempt scenario >>= \case + Left err -> handle err + Right _ -> integrationalFail ExpectingInterpreterToFail + -- | Check that interpreter failed due to gas exhaustion. -expectGasExhaustion :: ExecutorError -> Bool +expectGasExhaustion :: ExecutorError -> IntegrationalScenario expectGasExhaustion = \case - EEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True - _ -> False + EEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> pass + err -> unexpectedInterpreterError err "expected runtime failure due to gas exhaustion" -- | Expect that interpretation of contract with given address ended -- with [FAILED]. -expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> ExecutorError -> Bool -expectMichelsonFailed predicate addr = - \case - EEInterpreterFailed failedAddr (RuntimeFailure (mf, _)) -> - addr == failedAddr && predicate mf - _ -> False +expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> ExecutorError -> IntegrationalScenario +expectMichelsonFailed predicate expectedAddr err = + case err of + EEInterpreterFailed actualAddr (RuntimeFailure (mf, _)) + | expectedAddr /= actualAddr -> do + iState <- get + unexpectedInterpreterError err $ + "expected runtime failure for contract with address " + <> pretty (addrToAddrName expectedAddr iState) + | not (predicate mf) -> unexpectedInterpreterError err "predicate failed" + | otherwise -> pass + _ -> unexpectedInterpreterError err "expected runtime failure" ---------------------------------------------------------------------------- -- Implementation of the testing engine @@ -560,41 +594,8 @@ integrationalTest howToFail scenario = howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS) -validateResult :: - IntegrationalValidator - -> ExecutorResOrError - -> InternalState - -> IntegrationalScenarioM () -validateResult validator result iState = - case (validator, result) of - (Left validateError, Left err) - | validateError err -> pass - (_, Left err) -> - doFail $ UnexpectedExecutorError (mkError err iState) - (Left _, Right _) -> - doFail $ ExpectingInterpreterToFail - (Right validateUpdates, Right ir) - | Left bad <- validateUpdates iState (_erGState ir) (_erUpdates ir) -> - doFail $ IncorrectUpdates bad (_erUpdates ir) - | otherwise -> pass - where - doFail = integrationalFail - mkError - :: ExecutorError -> InternalState -> IntegrationalExecutorError - mkError iErr is = case iErr of - EEUnknownContract addr -> EEUnknownContract $ addrToAddrName addr is - EEInterpreterFailed addr err -> - EEInterpreterFailed (addrToAddrName addr is) err - EEAlreadyOriginated addr cs -> - EEAlreadyOriginated (addrToAddrName addr is) cs - EEUnknownSender addr -> EEUnknownSender $ addrToAddrName addr is - EEUnknownManager addr -> EEUnknownManager $ addrToAddrName addr is - EENotEnoughFunds addr amount -> - EENotEnoughFunds (addrToAddrName addr is) amount - EEZeroTransaction addr -> - EEZeroTransaction (addrToAddrName addr is) - EEFailedToApplyUpdates err -> EEFailedToApplyUpdates err - EEIllTypedContract err -> EEIllTypedContract err - EEIllTypedStorage err -> EEIllTypedStorage err - EEIllTypedParameter err -> EEIllTypedParameter err - EEUnknownEntrypoint err -> EEUnknownEntrypoint err +mkError + :: InternalState + -> ExecutorError + -> IntegrationalExecutorError +mkError is = fmap $ flip addrToAddrName is diff --git a/src/Michelson/Test/Unit.hs b/src/Michelson/Test/Unit.hs --- a/src/Michelson/Test/Unit.hs +++ b/src/Michelson/Test/Unit.hs @@ -20,7 +20,6 @@ import Data.List.NonEmpty (fromList) import qualified Data.Map as Map -import Data.Singletons (SingI) import Fmt ((+|), (|+)) import Test.Hspec.Expectations (Expectation, shouldBe, shouldSatisfy) import Test.HUnit (Assertion, assertFailure, (@?=)) @@ -131,6 +130,6 @@ -- | 'ContractPropValidator' that expects a given failure. validateMichelsonFailsWith - :: (T.IsoValue v, Typeable (ToT v), SingI (ToT v)) + :: IsoValue v => v -> ContractPropValidator st Expectation validateMichelsonFailsWith v (res, _) = res `shouldBe` Left (MichelsonFailedWith $ toVal v) diff --git a/src/Michelson/Test/Util.hs b/src/Michelson/Test/Util.hs --- a/src/Michelson/Test/Util.hs +++ b/src/Michelson/Test/Util.hs @@ -8,6 +8,25 @@ module Michelson.Test.Util ( leftToShowPanic , leftToPrettyPanic + , failedTest + , succeededTest + , eitherIsLeft + , eitherIsRight + , total + , meanTimeUpperBoundProp + , meanTimeUpperBoundPropNF + , genEither + , genTuple2 + , runGen + , roundtripTree + + -- * Re-exports + -- + -- | These functions from "Time" are re-exported here to make it convenient to call + -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'. + , mcs, ms, sec, minute + + -- * Deprecated , failedProp , succeededProp , qcIsLeft @@ -15,12 +34,29 @@ , roundtripTest ) where +import Criterion (Benchmarkable, benchmarkWith', nf, whnf) +import Criterion.Main (defaultConfig) +import Criterion.Types (SampleAnalysis(anMean), Verbosity(Quiet), reportAnalysis, verbosity) import Data.Typeable (typeRep) import Fmt (Buildable, pretty) +import Hedgehog + (Gen, MonadGen, MonadTest, Property, annotate, eval, evalIO, failure, forAll, property, success, + tripping, withTests) +import qualified Hedgehog.Gen as Gen +import Hedgehog.Internal.Gen (runGenT) +import qualified Hedgehog.Internal.Seed as Seed +import Hedgehog.Internal.Tree (TreeT(runTreeT), nodeValue) +import qualified Hedgehog.Range as Range +import Statistics.Types (Estimate(estPoint)) import Test.QuickCheck (Arbitrary) -import Test.QuickCheck.Property (Property, Result(..), failed, property, (===)) +import qualified Test.QuickCheck.Property as QC import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.Hedgehog (testProperty) +import qualified Test.Tasty.QuickCheck as TQC +import Text.Printf (printf) +import Time + (KnownDivRat, KnownUnitName, Microsecond, Millisecond, Minute, Nanosecond, Picosecond, RatioNat, + Second, Time, mcs, minute, ms, ns, sec, timeout, toUnit, unTime, unitNameVal) leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a leftToShowPanic = either (error . show) id @@ -32,35 +68,147 @@ -- Property ---------------------------------------------------------------------------- --- | A 'Property' that always failes with given message. -failedProp :: Text -> Property -failedProp r = property $ failed { reason = toString r } +-- | A 'QC.Property' that always fails with given message. +failedProp :: Text -> QC.Property +failedProp r = QC.property $ QC.failed { QC.reason = toString r } +{-# DEPRECATED failedProp "Use 'failedtest' instead." #-} --- | A 'Property' that always succeeds. -succeededProp :: Property -succeededProp = property True +-- | A 'QC.Property' that always succeeds. +succeededProp :: QC.Property +succeededProp = QC.property True +{-# DEPRECATED succeededProp "Use 'succeededTest' instead." #-} --- | The 'Property' holds on `Left a`. -qcIsLeft :: Show b => Either a b -> Property +-- | The 'QC.Property' holds on `Left a`. +qcIsLeft :: Show b => Either a b -> QC.Property qcIsLeft = \case - Left _ -> property True + Left _ -> succeededProp Right x -> failedProp $ "expected Left, got Right (" <> show x <> ")" +{-# DEPRECATED qcIsLeft "Use 'eitherIsLeft' instead." #-} --- | The 'Property' holds on `Right b`. -qcIsRight :: Show a => Either a b -> Property +-- | The 'QC.Property' holds on `Right b`. +qcIsRight :: Show a => Either a b -> QC.Property qcIsRight = \case - Right _ -> property True + Right _ -> succeededProp Left x -> failedProp $ "expected Right, got Left (" <> show x <> ")" +{-# DEPRECATED qcIsRight "Use 'eitherIsRight' instead." #-} +-- | A 'Property' that always fails with given message. +failedTest :: (HasCallStack, MonadTest m) => Text -> m () +failedTest r = withFrozenCallStack $ annotate (toString r) >> failure + +-- | A 'Property' that always succeeds. +succeededTest :: MonadTest m => m () +succeededTest = success + +-- | The 'Property' holds on `Left a`. +eitherIsLeft :: (Show b, MonadTest m, HasCallStack) => Either a b -> m () +eitherIsLeft = \case + Left _ -> succeededTest + Right x -> withFrozenCallStack $ failedTest $ "expected Left, got Right (" <> show x <> ")" + +-- | The 'Property' holds on `Right b`. +eitherIsRight :: (Show a, MonadTest m, HasCallStack) => Either a b -> m () +eitherIsRight = \case + Right _ -> succeededTest + Left x -> withFrozenCallStack $ failedTest $ "expected Right, got Left (" <> show x <> ")" + +-- | Checks that a value is total, i.e., doesn't crash when evaluated, +-- by reducing it to its normal form. +-- +-- Equivalent to QuickCheck's @total@. +total :: (MonadTest m, NFData a, HasCallStack) => a -> m a +total a = (withFrozenCallStack $ eval $ rnf a) $> a + +-- | Benchmarks the given function and checks that the mean time to evaluate to weak head +-- normal form is under the given amount of time. +-- +-- This test fails if the benchmark takes longer than 30 seconds to run. +meanTimeUpperBoundProp + :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack) + => Time unit -> (a -> b) -> a -> Property +meanTimeUpperBoundProp upperBound run arg = + withFrozenCallStack $ + checkReport upperBound $ whnf run arg + +-- | Benchmarks the given function and checks that the mean time to evaluate to +-- normal form is under the given amount of time. +-- +-- This test aborts and fails if the benchmark takes longer than 120 seconds to run. +meanTimeUpperBoundPropNF + :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack, NFData b) + => Time unit -> (a -> b) -> a -> Property +meanTimeUpperBoundPropNF upperBound run arg = + withFrozenCallStack $ + checkReport upperBound $ nf run arg + +checkReport + :: (KnownDivRat unit Second, KnownUnitName unit) + => HasCallStack => Time unit -> Benchmarkable -> Property +checkReport upperBound benchmarkable = + withTests 1 $ property $ + evalIO runBench >>= \case + Nothing -> failedTest "Expected benchmark to complete within 120 seconds." + Just report -> + let mean = sec . realToFrac @Double @RatioNat . estPoint . anMean $ reportAnalysis report + in if mean < toUnit @Second upperBound + then succeededTest + else failedTest $ + "Expected mean estimate to be under " + <> show upperBound + <> ", but was " + <> display mean + where + runBench = timeout (minute 2) $ + benchmarkWith' (defaultConfig { verbosity = Quiet }) benchmarkable + + display :: Time Second -> Text + display n = case n of + (toUnit @Minute -> x) | x > minute 1 -> format x + (toUnit @Second -> x) | x > sec 1 -> format x + (toUnit @Millisecond -> x) | x > ms 1 -> format x + (toUnit @Microsecond -> x) | x > mcs 1 -> format x + (toUnit @Nanosecond -> x) | x > ns 1 -> format x + _ -> format (toUnit @Picosecond n) + + format :: forall unit. KnownUnitName unit => Time unit -> Text + format n = + toText @String $ printf "%.4f%s" + (realToFrac @RatioNat @Double $ unTime n) + (unitNameVal @unit) + ---------------------------------------------------------------------------- +-- Generator +---------------------------------------------------------------------------- + +-- | Randomly selects one of the two generators. +genEither :: MonadGen m => m a -> m b -> m (Either a b) +genEither genA genB = Gen.choice [ Left <$> genA, Right <$> genB ] + +-- | Generates an @a@ and a @b@ and wraps them in a tuple. +genTuple2 :: MonadGen m => m a -> m b -> m (a, b) +genTuple2 = liftA2 (,) + +-- | Run the given generator deterministically, by fixing its size and seed. +runGen :: HasCallStack => Range.Size -> Word64 -> Gen a -> a +runGen size seed genT = + let tree = runGenT size (Seed.from seed) genT + node = fromMaybe discardedErr $ runIdentity $ runMaybeT $ runTreeT tree + discardedErr = error $ + "Generator could not produce a value for size " + <> show size <> " and seed " <> show seed + in nodeValue node + + + +---------------------------------------------------------------------------- -- Roundtrip ---------------------------------------------------------------------------- -- | This 'TestTree' contains a property based test for conversion from -- some @x@ to some @y@ and back to @x@ (it should successfully return -- the initial @x@). -roundtripTest :: - forall x y err. +roundtripTest + :: forall x y err. ( Show x , Show err , Typeable x @@ -71,8 +219,33 @@ => (x -> y) -> (y -> Either err x) -> TestTree -roundtripTest xToY yToX = testProperty typeName check +roundtripTest xToY yToX = TQC.testProperty typeName check where typeName = show $ typeRep (Proxy @x) - check :: x -> Property - check x = yToX (xToY x) === Right x + check :: x -> QC.Property + check x = yToX (xToY x) QC.=== Right x +{-# DEPRECATED roundtripTest "Use 'roundtripTree' instead." #-} + +-- | This 'TestTree' contains a property based test for conversion from +-- some @x@ to some @y@ and back to @x@ (it should successfully return +-- the initial @x@). +roundtripTree + :: forall x y err. + ( Show x + , Show y + , Show err + , Typeable x + , Eq x + , Eq err + ) + => Gen x + -> (x -> y) + -> (y -> Either err x) + -> TestTree +roundtripTree genX xToY yToX = testProperty typeNameX prop + where + typeNameX = show $ typeRep (Proxy @x) + prop :: Property + prop = property $ do + x <- forAll genX + tripping x xToY yToX diff --git a/src/Michelson/Text.hs b/src/Michelson/Text.hs --- a/src/Michelson/Text.hs +++ b/src/Michelson/Text.hs @@ -25,6 +25,7 @@ , takeMText , dropMText , isMChar + , genMText -- * Misc , qqMText @@ -40,6 +41,9 @@ import Data.Data (Data) import qualified Data.Text as T import Fmt (Buildable) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import Test.QuickCheck (Arbitrary(..), choose, listOf) @@ -75,9 +79,13 @@ instance NFData MText +minBoundMChar, maxBoundMChar :: Int +minBoundMChar = 32 +maxBoundMChar = 126 + -- | Constraint on literals appearing in Michelson contract code. isMChar :: Char -> Bool -isMChar c = fromEnum c >= 32 && fromEnum c <= 126 +isMChar c = fromEnum c >= minBoundMChar && fromEnum c <= maxBoundMChar -- | Error message indicating bad character in a string literal. invalidMCharError :: Char -> Text @@ -121,13 +129,19 @@ dropMText :: Int -> MText -> MText dropMText n (MTextUnsafe txt) = MTextUnsafe $ T.drop n txt +genMText :: MonadGen m => m MText +genMText = + mkMTextUnsafe <$> Gen.text + (Range.linear 0 100) + (Gen.enum (toEnum @Char minBoundMChar) (toEnum @Char maxBoundMChar)) + instance ToText MText where toText = unMText instance Arbitrary MText where arbitrary = mkMTextUnsafe . toText <$> - listOf (choose @Char (toEnum 32, toEnum 126)) + listOf (choose @Char (toEnum minBoundMChar, toEnum maxBoundMChar)) instance ToJSON MText where toJSON = toJSON . unMText @@ -177,7 +191,7 @@ qqMText txt = scan txt where scan = \case - '\\' : [] -> Left "Unterminated '\' in string literal" + '\\' : [] -> Left "Unterminated '\\' in string literal" '\\' : '\\' : s -> ('\\' :) <$> scan s '\\' : 'n' : s -> ('\n' :) <$> scan s '\\' : c : _ -> Left $ "Unknown escape sequence: '\\" <> toText [c] <> "'" diff --git a/src/Michelson/TypeCheck/Error.hs b/src/Michelson/TypeCheck/Error.hs --- a/src/Michelson/TypeCheck/Error.hs +++ b/src/Michelson/TypeCheck/Error.hs @@ -16,7 +16,7 @@ import Fmt (Buildable(..), listF, pretty, (+|), (+||), (|+), (||+)) import qualified Text.Show (show) -import Michelson.ErrorPos (InstrCallStack) +import Michelson.ErrorPos (InstrCallStack(..), Pos(..), SrcPos(..)) import Michelson.TypeCheck.Types (SomeHST(..)) import qualified Michelson.Typed as T import Michelson.Typed.Annotation (AnnConvergeError(..)) @@ -246,33 +246,39 @@ instance NFData TCError --- TODO pva701: an instruction position should be used in --- Buildable instance within TM-151. instance Buildable TCError where build = \case - TCFailedOnInstr instr (SomeHST t) _ mbTCTypeContext mbTCTypeError -> + TCFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTCTypeError -> "Error checking expression " +| instr |+ " against input stack type " +| t |+ maybe "" (\c -> ". Error in " +| c |+ "") mbTCTypeContext - +| maybe "" (\e -> ": " +| e |+ "") mbTCTypeError - +| "." - TCFailedOnValue v t custom _ mbTCTypeError -> + +| maybe ". " (\e -> ": " +| e |+ ". ") mbTCTypeError + +| buildCallStack ics + TCFailedOnValue v t custom ics mbTCTypeError -> "Error checking value " +| v |+ " against type " +| toUType t |+ bool (": " +| custom |+ " ") "" (null custom) +| (maybe "" (\e -> " " +| e |+ "") mbTCTypeError) + +| buildCallStack ics TCContractError msg typeError -> "Error occured during contract typecheck: " +|| msg ||+ (maybe "" (\e -> " " +| e |+ "") typeError) - TCUnreachableCode _ instrs -> - "Unreachable code: " +| buildTruncated 3 (toList instrs) - TCExtError (SomeHST t) _ e -> + TCUnreachableCode ics instrs -> + "Unreachable code: " +| buildTruncated 3 (toList instrs) |+ ". " + +| buildCallStack ics + TCExtError (SomeHST t) ics e -> "Error occurred during Morley extension typecheck: " - +| e |+ " on stack " +| t |+ "" + +| e |+ " on stack " +| t |+ ". " + +| buildCallStack ics where buildTruncated k l | null (drop k l) = build l | otherwise = build (take k l) <> " ..." + buildCallStack InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos line) (Pos col)} = + "Error occured on line " +| line + 1 |+ " char " +| col + 1 |+ "" + +| case icsCallStack of + [] -> "." + _ -> " inside these let defenitions: " +| listF icsCallStack |+ "." instance Buildable U.ExpandedInstr => Show TCError where show = pretty diff --git a/src/Michelson/TypeCheck/Ext.hs b/src/Michelson/TypeCheck/Ext.hs --- a/src/Michelson/TypeCheck/Ext.hs +++ b/src/Michelson/TypeCheck/Ext.hs @@ -21,8 +21,8 @@ import Michelson.Typed (Notes(..), converge, mkUType, notesT, withUType) import qualified Michelson.Typed as T import Michelson.Untyped - (ExpandedOp, StackFn, TyVar(..), Type, Var, VarAnn, inPattern, outPattern, - quantifiedVars, varSet) + (ExpandedOp, StackFn, TyVar(..), Type, Var, VarAnn, sfnInPattern, sfnOutPattern, + sfnQuantifiedVars, varSet) import qualified Michelson.Untyped as U import Util.Peano (SingNat(SS, SZ)) @@ -81,9 +81,9 @@ -- | Check that the optional "forall" variables are consistent if present checkVars :: Text -> StackFn -> Either ExtError () -checkVars t sf = case quantifiedVars sf of +checkVars t sf = case sfnQuantifiedVars sf of Just qs - | varSet (inPattern sf) /= qs -> Left $ VarError t sf + | varSet (sfnInPattern sf) /= qs -> Left $ VarError t sf _ -> pass -- | Executes function body, pushing @ExtFrame@ onto the state and checks @@ -106,13 +106,13 @@ where checkStart hst = do liftExtError hst $ checkVars t sf - vars <- liftExtError hst $ checkStackType noBoundVars (inPattern sf) hst + vars <- liftExtError hst $ checkStackType noBoundVars (sfnInPattern sf) hst tcExtFramesL %= (vars :) return vars checkEnd :: Typeable out => BoundVars -> HST out -> TypeCheckInstr () checkEnd vars out = liftExtError out $ - void $ checkStackType vars (outPattern sf) out + void $ checkStackType vars (sfnOutPattern sf) out -- | Check that a @StackTypePattern@ matches the type of the current stack checkStackType diff --git a/src/Michelson/TypeCheck/Helpers.hs b/src/Michelson/TypeCheck/Helpers.hs --- a/src/Michelson/TypeCheck/Helpers.hs +++ b/src/Michelson/TypeCheck/Helpers.hs @@ -57,8 +57,8 @@ import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.Types import Michelson.Typed - (BadTypeForScope(..), Comparable, Instr(..), Notes(..), PackedNotes(..), SingT(..), T(..), - WellTyped, converge, getComparableProofS, notesT, orAnn, starNotes) + (BadTypeForScope(..), Comparable, Instr(..), KnownT, 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 @@ -167,7 +167,7 @@ -- given type. This function is a specialized version of `eqHST`. eqHST1 :: forall t st. - (Typeable st, Typeable t, SingI t, WellTyped t) + (Typeable st, WellTyped t) => HST st -> Either TCTypeError (st :~: '[t]) eqHST1 hst = do let hst' = sing @t -:& SNil @@ -197,7 +197,7 @@ -- for use within @Either TCTypeError a@ applicative. eqType :: forall (a :: T) (b :: T). - (Each [Typeable, SingI] [a, b]) + (Each '[KnownT] [a, b]) => Either TCTypeError (a :~: b) eqType = maybe (Left $ TypeEqError (demote @a) (demote @b)) pure eqT @@ -319,7 +319,7 @@ -- | Check whether given types are structurally equal and annotations converge. matchTypes :: forall t1 t2. - (Each [Typeable, SingI] [t1, t2]) + (Each '[KnownT] [t1, t2]) => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1) matchTypes n1 n2 = do Refl <- eqType @t1 @t2 @@ -334,7 +334,7 @@ memImpl :: forall c memKey rs inp m . ( MemOp c - , Typeable (MemOpKey c), SingI (MemOpKey c) + , KnownT (MemOpKey c) , inp ~ (memKey : c : rs) , MonadReader InstrCallStack m , MonadError TCError m @@ -358,9 +358,7 @@ getImpl :: forall c getKey rs inp m . - ( GetOp c - , Typeable (GetOpKey c), SingI (GetOpKey c) - , Typeable (GetOpVal c), SingI (GetOpVal c) + ( GetOp c, KnownT (GetOpKey c) , WellTyped (GetOpVal c) , inp ~ (getKey : c : rs) , MonadReader InstrCallStack m @@ -387,8 +385,7 @@ updImpl :: forall c updKey updParams rs inp m . ( UpdOp c - , Typeable (UpdOpKey c), SingI (UpdOpKey c) - , Typeable (UpdOpParams c), SingI (UpdOpParams c) + , KnownT (UpdOpKey c), KnownT (UpdOpParams c) , inp ~ (updKey : updParams : c : rs) , MonadReader InstrCallStack m , MonadError TCError m @@ -435,7 +432,7 @@ pure $ i :/ SLICE ::: ((rn, Dict, vn') ::& rs) concatImpl' - :: (ConcatOp c, Typeable c, SingI c, WellTyped c, inp ~ ('TList c : rs), Monad m) + :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m) => HST inp -> Un.VarAnn -> m (SomeInstr inp) @@ -443,7 +440,7 @@ pure $ i :/ CONCAT' ::: ((n, Dict, vn) ::& rs) concatImpl - :: ( ConcatOp c, Typeable c, inp ~ (c ': c ': rs) + :: ( ConcatOp c, inp ~ (c ': c ': rs) , WellTyped c , MonadReader InstrCallStack m , MonadError TCError m @@ -458,9 +455,7 @@ -- | Helper function to construct instructions for binary arithmetic -- operations. arithImpl - :: ( Typeable (ArithRes aop n m) - , SingI (ArithRes aop n m) - , Typeable (ArithRes aop n m ': s) + :: ( Typeable (ArithRes aop n m ': s) , WellTyped (ArithRes aop n m) , inp ~ (n ': m ': s) , Monad t @@ -475,7 +470,7 @@ addImpl :: forall a b inp rs m. ( Typeable rs - , Each [Typeable, SingI] [a, b] + , Each '[KnownT] [a, b] , inp ~ (a ': b ': rs) , MonadReader InstrCallStack m , MonadError TCError m @@ -498,7 +493,7 @@ edivImpl :: forall a b inp rs m. ( Typeable rs - , Each [Typeable, SingI] [a, b] + , Each '[KnownT] [a, b] , inp ~ (a ': b ': rs) , MonadReader InstrCallStack m , MonadError TCError m @@ -519,10 +514,6 @@ edivImplDo :: ( EDivOp n m - , SingI (EModOpRes n m) - , Typeable (EModOpRes n m) - , SingI (EDivOpRes n m) - , Typeable (EDivOpRes n m) , WellTyped (EModOpRes n m) , WellTyped (EDivOpRes n m) , inp ~ (n ': m ': s) @@ -537,7 +528,7 @@ subImpl :: forall a b inp rs m. ( Typeable rs - , Each [Typeable, SingI] [a, b] + , Each '[KnownT] [a, b] , inp ~ (a ': b ': rs) , MonadReader InstrCallStack m , MonadError TCError m @@ -560,7 +551,7 @@ mulImpl :: forall a b inp rs m. ( Typeable rs - , Each [Typeable, SingI] [a, b] + , Each '[KnownT] [a, b] , inp ~ (a ': b ': rs) , MonadReader InstrCallStack m , MonadError TCError m @@ -582,9 +573,7 @@ -- | Helper function to construct instructions for binary arithmetic -- operations. unaryArithImpl - :: ( Typeable (UnaryArithRes aop n) - , SingI (UnaryArithRes aop n) - , Typeable (UnaryArithRes aop n ': s) + :: ( Typeable (UnaryArithRes aop n ': s) , WellTyped (UnaryArithRes aop n) , inp ~ (n ': s) , Monad t diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs --- a/src/Michelson/TypeCheck/Instr.hs +++ b/src/Michelson/TypeCheck/Instr.hs @@ -1093,8 +1093,6 @@ mapImpl :: forall c rs . ( MapOp c - , SingI (MapOpInp c) - , Typeable (MapOpInp c) , WellTyped (MapOpInp c) , Typeable (MapOpRes c) ) @@ -1102,7 +1100,7 @@ -> U.ExpandedInstr -> [U.ExpandedOp] -> HST (c ': rs) - -> (forall v' . (Typeable v', SingI v') => + -> (forall v' . (KnownT v') => Notes v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs))) -> TypeCheckInstr (SomeInstr (c ': rs)) mapImpl vn instr mp i@(_ ::& rs) mkRes = do @@ -1122,9 +1120,7 @@ iterImpl :: forall c rs . ( IterOp c - , SingI (IterOpEl c) , WellTyped (IterOpEl c) - , Typeable (IterOpEl c) ) => Notes (IterOpEl c) -> U.ExpandedInstr @@ -1147,8 +1143,8 @@ lamImpl :: forall it ot ts . - ( Typeable it, WellTyped it, Typeable ts, Typeable ot, WellTyped ot - , SingI it, SingI ot + ( WellTyped it, WellTyped ot + , Typeable ts ) => U.ExpandedInstr -> [U.ExpandedOp] diff --git a/src/Michelson/TypeCheck/Types.hs b/src/Michelson/TypeCheck/Types.hs --- a/src/Michelson/TypeCheck/Types.hs +++ b/src/Michelson/TypeCheck/Types.hs @@ -58,7 +58,7 @@ -- Additionally constructor keeps 'SingI' constraint for the current type. data HST (ts :: [T]) where SNil :: HST '[] - (::&) :: (Typeable xs, Typeable x, SingI x) + (::&) :: (Typeable xs, T.KnownT x) => (Notes x, Dict (WellTyped x), VarAnn) -> HST xs -> HST (x ': xs) @@ -95,7 +95,7 @@ -- | Append a type to 'HST', assuming that notes and annotations -- for this type are unknown. (-:&) - :: (Typeable xs, Typeable x, SingI x, WellTyped x) + :: (Typeable xs, WellTyped x) => Sing x -> HST xs -> HST (x ': xs) @@ -107,7 +107,7 @@ pattern (::&+) :: () => ( ys ~ (x ': xs) - , Typeable x, SingI x, Typeable xs + , T.KnownT x, Typeable xs ) => (Sing x, Notes x, Dict (WellTyped x), VarAnn) -> HST xs diff --git a/src/Michelson/TypeCheck/Value.hs b/src/Michelson/TypeCheck/Value.hs --- a/src/Michelson/TypeCheck/Value.hs +++ b/src/Michelson/TypeCheck/Value.hs @@ -21,7 +21,8 @@ import Michelson.TypeCheck.TypeCheck (TcInstrHandler, TypeCheckEnv(..), TypeCheckInstr) import Michelson.TypeCheck.Types import Michelson.Typed - (pattern AsUTypeExt, EpAddress(..), Notes(..), ParamNotes(..), SingT(..), Value'(..), fromSingT, starNotes) + (pattern AsUTypeExt, EpAddress(..), KnownT, Notes(..), ParamNotes(..), SingT(..), Value'(..), + fromSingT, starNotes) import qualified Michelson.Typed as T import qualified Michelson.Untyped as U import Tezos.Address (Address(..)) @@ -96,7 +97,7 @@ STContract (pc :: Sing cp)) -> do instrPos <- ask contracts <- gets tcContracts - let ensureTypeMatches :: forall t'. (Typeable t', SingI t') => TypeCheckInstr (cp :~: t') + let ensureTypeMatches :: forall t'. KnownT t' => TypeCheckInstr (cp :~: t') ensureTypeMatches = liftEither @_ @TypeCheckInstr $ first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $ diff --git a/src/Michelson/Typed/EntryPoints.hs b/src/Michelson/Typed/EntryPoints.hs --- a/src/Michelson/Typed/EntryPoints.hs +++ b/src/Michelson/Typed/EntryPoints.hs @@ -10,6 +10,7 @@ , mformatEpAddress , parseEpAddress , unsafeParseEpAddress + , genEpAddress , ParamNotes (..) , pattern ParamNotes @@ -50,6 +51,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Fmt (Buildable(..), pretty, (+|), (|+)) +import Hedgehog (GenBase, MonadGen) import Test.QuickCheck (Arbitrary(..)) import Michelson.Text @@ -61,7 +63,8 @@ import qualified Michelson.Untyped as U import Michelson.Untyped.Annotation import Michelson.Untyped.EntryPoints -import Tezos.Address (Address, ParseAddressError, formatAddress, parseAddress) +import Tezos.Address (Address, ParseAddressError, formatAddress, genAddress, parseAddress) +import Util.Test.Gen (genEpName) import Util.TH import Util.Typeable import Util.TypeLits @@ -136,6 +139,9 @@ instance Arbitrary FieldAnn => Arbitrary EpAddress where arbitrary = EpAddress <$> arbitrary <*> arbitrary +genEpAddress :: (MonadGen m, GenBase m ~ Identity) => m EpAddress +genEpAddress = EpAddress <$> genAddress <*> genEpName + -- ParamNotes ---------------------------------------------------------------------------- @@ -276,8 +282,12 @@ -- use @Value@ type in this module easily. data EpLiftSequence (arg :: T) (param :: T) where EplArgHere :: EpLiftSequence arg arg - EplWrapLeft :: EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r) - EplWrapRight :: EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam) + EplWrapLeft + :: (KnownT subparam, KnownT r) + => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r) + EplWrapRight + :: (KnownT l, KnownT subparam) + => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam) deriving stock instance Eq (EpLiftSequence arg param) deriving stock instance Show (EpLiftSequence arg param) diff --git a/src/Michelson/Typed/Extract.hs b/src/Michelson/Typed/Extract.hs --- a/src/Michelson/Typed/Extract.hs +++ b/src/Michelson/Typed/Extract.hs @@ -22,7 +22,7 @@ import Data.Singletons (Sing, SingI) import Michelson.Typed.Annotation (Notes(..), notesSing) -import Michelson.Typed.Sing (SingT(..), fromSingT) +import Michelson.Typed.Sing (KnownT, SingT(..), fromSingT) import Michelson.Typed.T (T(..), toUType) import qualified Michelson.Untyped as Un @@ -66,7 +66,7 @@ -- | Convert 'Un.Type' to the isomorphic set of information from typed world. withUType :: Un.Type - -> (forall t. (Typeable t, SingI t) => Notes t -> r) + -> (forall t. KnownT t => Notes t -> r) -> r withUType (Un.Type ut tn) cont = case ut of @@ -154,7 +154,7 @@ cont @('TBigMap _ _) (NTBigMap tn keyN valN) -- Helper datatype for 'AsUType'. -data SomeTypedInfo = forall t. (Typeable t, SingI t) => SomeTypedInfo (Notes t) +data SomeTypedInfo = forall t. KnownT t => SomeTypedInfo (Notes t) -- | Transparently represent untyped 'Type' as wrapper over @Notes t@ -- from typed world with @SingI t@ constraint. @@ -165,13 +165,13 @@ -- Note about constraints: pattern signatures usually require two constraints - -- one they require and another one which they provide. In our case we require -- nothing (thus first constraint is @()@) and provide some knowledge about @t@. -pattern AsUType :: () => (Typeable t, SingI t) => Notes t -> Un.Type +pattern AsUType :: () => (KnownT t) => Notes t -> Un.Type pattern AsUType notes <- ((\ut -> withUType ut SomeTypedInfo) -> SomeTypedInfo notes) where AsUType notes = mkUType notes {-# COMPLETE AsUType #-} -- | Similar to 'AsUType', but also gives 'Sing' for given type. -pattern AsUTypeExt :: () => (Typeable t, SingI t) => Sing t -> Notes t -> Un.Type +pattern AsUTypeExt :: () => (KnownT t) => Sing t -> Notes t -> Un.Type pattern AsUTypeExt sng notes <- AsUType notes@(notesSing -> sng) where AsUTypeExt _ notes = AsUType notes {-# COMPLETE AsUTypeExt #-} diff --git a/src/Michelson/Typed/Haskell/Doc.hs b/src/Michelson/Typed/Haskell/Doc.hs --- a/src/Michelson/Typed/Haskell/Doc.hs +++ b/src/Michelson/Typed/Haskell/Doc.hs @@ -19,7 +19,6 @@ , FieldDescriptions , PolyTypeHasDocC , SomeTypeWithDoc (..) - , typeDocDependencies' , HaveCommonTypeCtor , IsHomomorphic @@ -41,6 +40,8 @@ , DStorageType (..) , GTypeHasDoc , GProductHasDoc + , dTypeDep + , dTypeDepP , buildADTRep , applyWithinParens ) where @@ -199,10 +200,10 @@ -- | All types which this type directly contains. -- -- Used in automatic types discovery. - typeDocDependencies :: Proxy a -> [SomeTypeWithDoc] + typeDocDependencies :: Proxy a -> [SomeDocDefinitionItem] default typeDocDependencies :: (Generic a, GTypeHasDoc (G.Rep a)) - => Proxy a -> [SomeTypeWithDoc] + => Proxy a -> [SomeDocDefinitionItem] typeDocDependencies = genericTypeDocDependencies -- | For complex types - their immediate Haskell representation. @@ -300,16 +301,6 @@ newtype DocTypeRepLHS = DocTypeRepLHS Text deriving newtype (IsString, Buildable) --- | Like 'typeDocDependencies' but returns values of more common type --- which is used in 'docItemDependencies'. -typeDocDependencies' - :: TypeHasDoc a - => Proxy a - -> [SomeDocDefinitionItem] -typeDocDependencies' at = - typeDocDependencies at <&> - \(SomeTypeWithDoc t) -> SomeDocDefinitionItem (DType t) - -- | Doc element with description of a type. data DType where DType :: TypeHasDoc a => Proxy a -> DType @@ -332,7 +323,7 @@ DocItemId ("types-" <> typeDocName a) docItemDependencies (DType (ap' :: Proxy a)) = - typeDocDependencies' ap' + typeDocDependencies ap' docItemToMarkdown lvl (DType (ap' :: Proxy a)) = mconcat . catMaybes $ @@ -365,6 +356,17 @@ in rendered <> "\n\n" ] +-- | Create a 'DType' in form suitable for putting to 'typeDocDependencies'. +dTypeDep :: forall (t :: Kind.Type). TypeHasDoc t => SomeDocDefinitionItem +dTypeDep = SomeDocDefinitionItem (DType (Proxy @t)) + +-- | Proxy version of 'dTypeDep'. +dTypeDepP + :: forall (t :: Kind.Type). + TypeHasDoc t + => Proxy t -> SomeDocDefinitionItem +dTypeDepP _ = dTypeDep @t + -- | Doc element with description of contract storage type. newtype DStorageType = DStorageType DType deriving stock Generic @@ -453,11 +455,12 @@ genericTypeDocDependencies :: forall a. (Generic a, GTypeHasDoc (G.Rep a)) - => Proxy a -> [SomeTypeWithDoc] + => Proxy a -> [SomeDocDefinitionItem] genericTypeDocDependencies _ = do ConstructorRep{..} <- toList $ gTypeDocHaskellRep @(G.Rep a) [] FieldRep{..} <- crFields - return frTypeRep + SomeTypeWithDoc ty <- pure frTypeRep + return (dTypeDepP ty) -- | Implement 'typeDocHaskellRep' for a homomorphic type. -- @@ -746,7 +749,7 @@ typeDocName _ = "Set" typeDocMdReference = poly1TypeDocMdReference typeDocMdDescription = "Set primitive." - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @a)] + typeDocDependencies _ = [dTypeDep @a] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Set Integer) @@ -762,7 +765,7 @@ typeDocName _ = "Contract" typeDocMdReference = poly1TypeDocMdReference typeDocMdDescription = "Contract primitive with given type of parameter." - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @cp)] + typeDocDependencies _ = [dTypeDep @cp] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ContractRef Integer) @@ -771,7 +774,8 @@ typeDocName _ = "Map" typeDocMdReference = poly2TypeDocMdReference typeDocMdDescription = "Map primitive." - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @k), SomeTypeWithDoc (Proxy @v)] + typeDocDependencies _ = + [dTypeDep @k, dTypeDep @v] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Map Integer Natural) @@ -780,7 +784,8 @@ typeDocName _ = "BigMap" typeDocMdReference = poly2TypeDocMdReference typeDocMdDescription = "BigMap primitive." - typeDocDependencies _ = [SomeTypeWithDoc (Proxy @k), SomeTypeWithDoc (Proxy @v)] + typeDocDependencies _ = + [dTypeDep @k, dTypeDep @v] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep = concreteTypeDocMichelsonRep @(BigMap Integer Natural) @@ -872,7 +877,9 @@ buildFieldName (toText (symbolVal $ Proxy @n)) +| " " +| typeDocMdReference (Proxy @(ApplyNamedFunctor f a)) (WithinParens False) |+ "" typeDocDependencies _ = - [SomeTypeWithDoc (Proxy @(ApplyNamedFunctor f a)), SomeTypeWithDoc (Proxy @Integer)] + [ dTypeDep @(ApplyNamedFunctor f a) + , dTypeDep @Integer + ] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep _ = (Just "number: Integer", demote @(ToT (ApplyNamedFunctor f Integer))) typeDocMdDescription = diff --git a/src/Michelson/Typed/Haskell/LooseSum.hs b/src/Michelson/Typed/Haskell/LooseSum.hs --- a/src/Michelson/Typed/Haskell/LooseSum.hs +++ b/src/Michelson/Typed/Haskell/LooseSum.hs @@ -20,7 +20,6 @@ ) where import qualified Data.Kind as Kind -import Data.Singletons (SingI) import Data.Typeable (TypeRep, cast, typeRep) import GHC.Generics ((:*:), (:+:)) import qualified GHC.Generics as G @@ -106,7 +105,7 @@ gExtractField = gExtractField . G.unM1 gMakeField v = G.M1 <$> gMakeField @x v -instance (Typeable a, IsoValue a, Typeable (ToT a), SingI (ToT a)) => +instance (Typeable a, IsoValue a) => GAccessField (G.Rec0 a) where gExtractField = SomeValue . toVal . G.unK1 gMakeField (SomeValue v) = G.K1 . fromVal <$> composeCast v diff --git a/src/Michelson/Typed/Haskell/Value.hs b/src/Michelson/Typed/Haskell/Value.hs --- a/src/Michelson/Typed/Haskell/Value.hs +++ b/src/Michelson/Typed/Haskell/Value.hs @@ -8,6 +8,8 @@ module Michelson.Typed.Haskell.Value ( -- * Value conversions IsoValue (..) + , KnownIsoT + , KnownT , GIsoValue (GValueType) , ToT' , SomeIsoValue (..) @@ -33,6 +35,9 @@ , IsoValuesStack (..) , totsKnownLemma , totsAppendLemma + + -- * Generators + , genBigMap ) where import Data.Constraint ((:-)(..), Dict(..)) @@ -44,12 +49,16 @@ import Fmt (Buildable(..)) import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Named (NamedF(..)) import Test.QuickCheck (Arbitrary(..)) import Michelson.Text import Michelson.Typed.Aliases import Michelson.Typed.EntryPoints +import Michelson.Typed.Sing import Michelson.Typed.T import Michelson.Typed.Value import Tezos.Address (Address) @@ -61,6 +70,8 @@ -- Complex values isomorphism ---------------------------------------------------------------------------- +type KnownIsoT a = KnownT (ToT a) + -- | Isomorphism between Michelson values and plain Haskell types. -- -- Default implementation of this typeclass converts ADTs to Michelson @@ -91,7 +102,7 @@ -- | Hides some Haskell value put in line with Michelson 'Value'. data SomeIsoValue where - SomeIsoValue :: (Typeable a, IsoValue a) => a -> SomeIsoValue + SomeIsoValue :: (KnownIsoT a) => a -> SomeIsoValue -- | Any Haskell value which can be converted to Michelson 'Value'. newtype AnyIsoValue = AnyIsoValue (forall a. IsoValue a => a) @@ -115,7 +126,7 @@ fromVal (VString x) = x instance DoNotUseTextError => IsoValue Text where - type ToT Text = ToT () + type ToT Text = ToT MText toVal = error "impossible" fromVal = error "impossible" @@ -271,6 +282,12 @@ ) => Arbitrary (BigMap k v) where arbitrary = BigMap <$> arbitrary +genBigMap + :: forall k v m. + (MonadGen m, Ord k, WellTypedToT k, WellTypedToT v, Comparable (ToT k)) + => m k -> m v -> m (BigMap k v) +genBigMap genK genV = BigMap <$> Gen.map (Range.linear 0 100) (liftA2 (,) genK genV) + -- Generic magic ---------------------------------------------------------------------------- @@ -282,7 +299,8 @@ -- A drawback of such approach is that, in theory, in new GHC version -- generified representation may change; however, chances are small and -- I (martoon) believe that contract versions will change much faster anyway. -class GIsoValue (x :: Kind.Type -> Kind.Type) where +class KnownT (GValueType x) => + GIsoValue (x :: Kind.Type -> Kind.Type) where type GValueType x :: T gToValue :: x p -> Value (GValueType x) gFromValue :: Value (GValueType x) -> x p @@ -369,7 +387,7 @@ -- 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 +class KnownT t => WellTyped (t :: T) where instance WellTyped 'TKey where instance WellTyped 'TUnit where diff --git a/src/Michelson/Typed/Instr.hs b/src/Michelson/Typed/Instr.hs --- a/src/Michelson/Typed/Instr.hs +++ b/src/Michelson/Typed/Instr.hs @@ -41,6 +41,7 @@ import Michelson.Typed.EntryPoints import Michelson.Typed.Polymorphic import Michelson.Typed.Scope +import Michelson.Typed.Sing (KnownT) import Michelson.Typed.T (T(..)) import Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..)) import Michelson.Untyped (Annotation(..), FieldAnn, VarAnn) @@ -189,36 +190,36 @@ :: forall t s . ConstantScope t => Value' Instr t -> Instr s (t ': s) SOME :: Instr (a ': s) ('TOption a ': s) - NONE :: forall a s . SingI a => Instr s ('TOption a ': s) + NONE :: forall a s . KnownT a => Instr s ('TOption a ': s) UNIT :: Instr s ('TUnit ': s) IF_NONE :: Instr s s' -> Instr (a ': s) s' -> Instr ('TOption a ': s) s' PAIR :: Instr (a ': b ': s) ('TPair a b ': s) - LEFT :: forall b a s . SingI b => Instr (a ': s) ('TOr a b ': s) - RIGHT :: forall a b s . SingI a => Instr (b ': s) ('TOr a b ': s) + LEFT :: forall b a s . KnownT b => Instr (a ': s) ('TOr a b ': s) + RIGHT :: forall a b s . KnownT a => Instr (b ': s) ('TOr a b ': s) IF_LEFT :: Instr (a ': s) s' -> Instr (b ': s) s' -> Instr ('TOr a b ': s) s' - NIL :: SingI p => Instr s ('TList p ': s) + NIL :: KnownT p => Instr s ('TList p ': s) CONS :: Instr (a ': 'TList a ': s) ('TList a ': s) IF_CONS :: Instr (a ': 'TList a ': s) s' -> Instr s s' -> Instr ('TList a ': s) 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 + EMPTY_SET :: (KnownT e, Comparable e) => Instr s ('TSet e ': s) + EMPTY_MAP :: (KnownT a, KnownT b, Comparable a) => Instr s ('TMap a b ': s) + EMPTY_BIG_MAP :: (KnownT a, KnownT b, Comparable a) => Instr s ('TBigMap a b ': s) + MAP :: (MapOp c, KnownT b) => 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 (MemOpKey c ': c ': s) ('TBool ': s) GET - :: GetOp c + :: (GetOp c, KnownT (GetOpVal c)) => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s) UPDATE :: UpdOp c @@ -231,25 +232,25 @@ LOOP_LEFT :: Instr (a ': s) ('TOr a b ': s) -> Instr ('TOr a b ': s) (b ': s) - LAMBDA :: forall i o s . (Each [Typeable, SingI] [i, o]) + LAMBDA :: forall i o s . (KnownT i, KnownT o) => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s) EXEC :: Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s) APPLY - :: forall a b c s . ConstantScope a + :: forall a b c s . (ConstantScope a, KnownT b) => Instr (a ': 'TLambda ('TPair a b) c ': s) ('TLambda b c ': s) DIP :: Instr a c -> Instr (b ': a) (b ': c) DIPN :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s', (NFData (Sing n))) => Sing n -> Instr s s' -> Instr inp out - FAILWITH :: (Typeable a, SingI a) => Instr (a ': s) t + FAILWITH :: (KnownT a) => Instr (a ': s) t CAST :: forall a s . SingI a => Instr (a ': s) (a ': s) RENAME :: Instr (a ': s) (a ': s) PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s) - UNPACK :: UnpackedValScope a => Instr ('TBytes ': s) ('TOption a ': s) + UNPACK :: (UnpackedValScope a, KnownT 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 + :: (SliceOp c, KnownT c) => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s) ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s) ADD @@ -291,7 +292,7 @@ :: UnaryArithOp Not n => Instr (n ': s) (UnaryArithRes Not n ': s) COMPARE - :: (Comparable n, Typeable n, SingI n) + :: (Comparable n, KnownT n) => Instr (n ': n ': s) ('TInt ': s) EQ :: UnaryArithOp Eq' n diff --git a/src/Michelson/Typed/Polymorphic.hs b/src/Michelson/Typed/Polymorphic.hs --- a/src/Michelson/Typed/Polymorphic.hs +++ b/src/Michelson/Typed/Polymorphic.hs @@ -22,6 +22,7 @@ import qualified Data.Set as S import Michelson.Text +import Michelson.Typed.Sing (KnownT) import Michelson.Typed.T (T(..)) import Michelson.Typed.Value (Value'(..)) @@ -44,7 +45,9 @@ type MapOpInp c :: T type MapOpRes c :: T -> T mapOpToList :: Value' instr c -> [Value' instr (MapOpInp c)] - mapOpFromList :: Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b) + mapOpFromList + :: (KnownT b) + => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b) instance MapOp ('TMap k v) where type MapOpInp ('TMap k v) = 'TPair k v type MapOpRes ('TMap k v) = 'TMap k diff --git a/src/Michelson/Typed/Scope.hs b/src/Michelson/Typed/Scope.hs --- a/src/Michelson/Typed/Scope.hs +++ b/src/Michelson/Typed/Scope.hs @@ -105,7 +105,7 @@ import Fmt (Buildable(..)) import GHC.TypeLits (ErrorMessage(..), TypeError) -import Michelson.Typed.Sing (SingT(..)) +import Michelson.Typed.Sing (KnownT, SingT(..)) import Michelson.Typed.T (T(..)) ---------------------------------------------------------------------------- @@ -564,11 +564,11 @@ -- | Alias for constraints which Michelson applies to parameter. type ParameterScope t = - (Typeable t, SingI t, HasNoOp t, HasNoNestedBigMaps t) + (KnownT t, HasNoOp t, HasNoNestedBigMaps t) -- | Alias for constraints which Michelson applies to contract storage. type StorageScope t = - (Typeable t, SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) + (KnownT t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) -- | Alias for constraints which Michelson applies to pushed constants. type ConstantScope t = @@ -606,33 +606,33 @@ instance SingI t => CheckScope (HasNoContract t) where checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing -instance (Typeable t, SingI t) => CheckScope (ParameterScope t) where +instance KnownT t => CheckScope (ParameterScope t) where checkScope = (\Dict Dict -> Dict) <$> checkScope @(HasNoOp t) <*> checkScope @(HasNoNestedBigMaps t) -instance (Typeable t, SingI t) => CheckScope (StorageScope t) where +instance KnownT t => CheckScope (StorageScope t) where checkScope = (\Dict Dict Dict -> Dict) <$> checkScope @(HasNoOp t) <*> checkScope @(HasNoNestedBigMaps t) <*> checkScope @(HasNoContract t) -instance (Typeable t, SingI t) => CheckScope (ConstantScope t) where +instance KnownT t => CheckScope (ConstantScope t) where checkScope = (\Dict Dict Dict -> Dict) <$> checkScope @(HasNoOp t) <*> checkScope @(HasNoBigMap t) <*> checkScope @(HasNoContract t) -instance (Typeable t, SingI t) => CheckScope (PackedValScope t) where +instance KnownT t => CheckScope (PackedValScope t) where checkScope = (\Dict Dict -> Dict) <$> checkScope @(HasNoOp t) <*> checkScope @(HasNoBigMap t) -instance (Typeable t, SingI t) => CheckScope (UnpackedValScope t) where +instance KnownT t => CheckScope (UnpackedValScope t) where checkScope = (\Dict Dict -> Dict) <$> checkScope @(PackedValScope t) @@ -646,10 +646,10 @@ -} type ProperParameterBetterErrors t = - (Typeable t, SingI t, ForbidOp t, ForbidNestedBigMaps t) + (KnownT t, ForbidOp t, ForbidNestedBigMaps t) type ProperStorageBetterErrors t = - (Typeable t, SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t) + (KnownT t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t) type ProperConstantBetterErrors t = (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t) diff --git a/src/Michelson/Typed/Sing.hs b/src/Michelson/Typed/Sing.hs --- a/src/Michelson/Typed/Sing.hs +++ b/src/Michelson/Typed/Sing.hs @@ -14,6 +14,7 @@ module Michelson.Typed.Sing ( SingT (..) + , KnownT , withSomeSingT , fromSingT ) where @@ -32,22 +33,22 @@ 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 ) + STOption :: KnownT a => Sing a -> SingT ( 'TOption a) + STList :: KnownT a => Sing a -> SingT ( 'TList a ) + STSet :: KnownT a => Sing a -> SingT ( 'TSet a ) STOperation :: SingT 'TOperation - STContract :: (SingI a, Typeable a) - => Sing a -> SingT ( 'TContract a ) - STPair :: (SingI a, SingI b, Typeable a, Typeable b) - => Sing a -> Sing b -> SingT ('TPair a b) - STOr :: (SingI a, SingI b, Typeable a, Typeable b) - => Sing a -> Sing b -> SingT ('TOr a b) - STLambda :: (SingI a, SingI b, Typeable a, Typeable b) - => Sing a -> Sing b -> SingT ('TLambda a b) - STMap :: (SingI a, SingI b, Typeable a, Typeable b) - => Sing a -> Sing b -> SingT ('TMap a b) - STBigMap :: (SingI a, SingI b, Typeable a, Typeable b) - => Sing a -> Sing b -> SingT ('TBigMap a b) + STContract :: (KnownT a) + => Sing a -> SingT ( 'TContract a ) + STPair :: (KnownT a, KnownT b) + => Sing a -> Sing b -> SingT ('TPair a b) + STOr :: (KnownT a, KnownT b) + => Sing a -> Sing b -> SingT ('TOr a b) + STLambda :: (KnownT a, KnownT b) + => Sing a -> Sing b -> SingT ('TLambda a b) + STMap :: (KnownT a, KnownT b) + => Sing a -> Sing b -> SingT ('TMap a b) + STBigMap :: (KnownT a, KnownT b) + => Sing a -> Sing b -> SingT ('TBigMap a b) STInt :: SingT 'TInt STNat :: SingT 'TNat STString :: SingT 'TString @@ -64,10 +65,16 @@ -- Singleton-related helpers for T -------------------------------------------- +-- | 'Typeable' + 'SingI' constraints. +-- +-- This restricts a type to be a constructible type of 'T' kind. +class (Typeable t, SingI t) => KnownT (t :: T) +instance (Typeable t, SingI t) => KnownT t + -- | Version of 'SomeSing' with 'Typeable' constraint, -- specialized for use with 'T' kind. data SomeSingT where - SomeSingT :: forall (a :: T). (Typeable a, SingI a) + SomeSingT :: forall (a :: T). (KnownT a) => Sing a -> SomeSingT -- | Version of 'withSomeSing' with 'Typeable' constraint @@ -77,7 +84,7 @@ -- conversion from value of type 'T' to its singleton representation. withSomeSingT :: T - -> (forall (a :: T). (Typeable a, SingI a) => Sing a -> r) + -> (forall (a :: T). (KnownT a) => Sing a -> r) -> r withSomeSingT t f = (\(SomeSingT s) -> f s) (toSingT t) @@ -165,30 +172,30 @@ sing = STSignature instance SingI 'TChainId where sing = STChainId -instance (SingI a, Typeable a) => SingI ( 'TOption (a :: T)) where +instance (KnownT a) => SingI ( 'TOption (a :: T)) where sing = STOption sing -instance (SingI a, Typeable a) => SingI ( 'TList (a :: T)) where +instance (KnownT a) => SingI ( 'TList (a :: T)) where sing = STList sing -instance (SingI a, Typeable a) => SingI ( 'TSet (a :: T)) where +instance (KnownT a) => SingI ( 'TSet (a :: T)) where sing = STSet sing instance SingI 'TOperation where sing = STOperation -instance (SingI a, Typeable a) => +instance (KnownT a) => SingI ( 'TContract (a :: T)) where sing = STContract sing -instance (SingI a, Typeable a, Typeable b, SingI b) => +instance (KnownT a, KnownT b) => SingI ( 'TPair a b) where sing = STPair sing sing -instance (SingI a, Typeable a, Typeable b, SingI b) => +instance (KnownT a, KnownT b) => SingI ( 'TOr a b) where sing = STOr sing sing -instance (SingI a, Typeable a, Typeable b, SingI b) => +instance (KnownT a, KnownT b) => SingI ( 'TLambda a b) where sing = STLambda sing sing -instance (SingI a, Typeable a, Typeable b, SingI b) => +instance (KnownT a, KnownT b) => SingI ( 'TMap a b) where sing = STMap sing sing -instance (SingI a, Typeable a, Typeable b, SingI b) => +instance (KnownT a, KnownT b) => SingI ( 'TBigMap a b) where sing = STBigMap sing sing instance SingI 'TInt where diff --git a/src/Michelson/Typed/Value.hs b/src/Michelson/Typed/Value.hs --- a/src/Michelson/Typed/Value.hs +++ b/src/Michelson/Typed/Value.hs @@ -32,15 +32,17 @@ , comparabilityPresence , getComparableProofS , liftCallArg + , valueTypeSanity + , withValueTypeSanity + , eqValueExt ) where import GHC.TypeLits (ErrorMessage(..), TypeError) - -import Data.Constraint (Dict(..)) -import Data.Singletons (SingI, Sing, sing) +import Data.Singletons (SingI (..), Sing) +import Data.Constraint (Dict (..), (\\)) import Data.Type.Bool (type (&&)) +import Fmt (Buildable(build), (+|), (|+), Builder) import qualified Data.Kind as Kind -import Fmt (Buildable(build), Builder, (+|), (|+)) import Michelson.Text (MText) import Michelson.Typed.EntryPoints @@ -265,7 +267,7 @@ -- | Alias for comparable types. type ComparabilityScope t = - (Typeable t, SingI t, Comparable t) + (KnownT t, Comparable t) data Comparability t where CanBeCompared :: (Comparable t) => Comparability t @@ -308,7 +310,7 @@ instance SingI t => CheckScope (Comparable t) where checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing -instance (Typeable t, SingI t) => CheckScope (ComparabilityScope t) where +instance (KnownT t) => CheckScope (ComparabilityScope t) where checkScope = (\Dict -> Dict) <$> checkScope @(Comparable t) @@ -322,22 +324,46 @@ 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. (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) + VOption + :: forall t instr. + (KnownT t) + => Maybe (Value' instr t) -> Value' instr ('TOption t) + VList + :: forall t instr. + (KnownT t) + => [Value' instr t] -> Value' instr ('TList t) + VSet + :: forall t instr. + (KnownT t, 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. + (KnownT l, KnownT r) + => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r) VLam :: forall inp out instr. - ( forall i o. Show (instr i o) + ( KnownT inp, KnownT out + , 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. (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) + VMap + :: forall k v instr. + (KnownT k, KnownT v, Comparable k) + => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v) + VBigMap + :: forall k v instr. + (KnownT k, KnownT v, 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 @@ -364,7 +390,7 @@ VContract addr epc -> "Contract " +| addr |+ " call " +| epc |+ "" data SomeValue' instr where - SomeValue :: (Typeable t, SingI t) => Value' instr t -> SomeValue' instr + SomeValue :: KnownT t => Value' instr t -> SomeValue' instr deriving stock instance Show (SomeValue' instr) @@ -401,6 +427,54 @@ -> Value' instr arg -> Value' instr param liftCallArg epc = compileEpLiftSequence (epcLiftSequence epc) + +-- | Get a witness of that value's type is known. +-- +-- Note that we cannot pick such witness out of nowhere as not all types +-- of kind 'T' have 'Typeable' and 'SingI' instances; example: +-- +-- @ +-- type family Any :: T where +-- -- nothing here +-- @ +valueTypeSanity :: Value' instr t -> Dict (KnownT t) +valueTypeSanity = \case + VKey{} -> Dict + VUnit{} -> Dict + VSignature{} -> Dict + VChainId{} -> Dict + VOption{} -> Dict + VList{} -> Dict + VSet{} -> Dict + VOp{} -> Dict + VContract _ (SomeEpc EntryPointCall{}) -> Dict + VPair (l, r) -> case (valueTypeSanity l, valueTypeSanity r) of + (Dict, Dict) -> Dict + VOr{} -> Dict + VLam{} -> Dict + VMap{} -> Dict + VBigMap{} -> Dict + VInt{} -> Dict + VNat{} -> Dict + VString{} -> Dict + VBytes{} -> Dict + VMutez{} -> Dict + VBool{} -> Dict + VKeyHash{} -> Dict + VTimestamp{} -> Dict + VAddress{} -> Dict + +-- | Provide a witness of that value's type is known. +withValueTypeSanity :: Value' instr t -> (KnownT t => a) -> a +withValueTypeSanity v a = case valueTypeSanity v of Dict -> a + +-- | Extended values comparison - it does not require 'Value's to be +-- of the same type, only their content to match. +eqValueExt :: Value' instr t1 -> Value' instr t2 -> Bool +eqValueExt v1 v2 = + v1 `eqParam1` v2 + \\ valueTypeSanity v1 + \\ valueTypeSanity v2 -- TODO: actually we should handle big maps with something close -- to following: diff --git a/src/Michelson/Untyped/Annotation.hs b/src/Michelson/Untyped/Annotation.hs --- a/src/Michelson/Untyped/Annotation.hs +++ b/src/Michelson/Untyped/Annotation.hs @@ -25,6 +25,9 @@ , VarAnn , SomeAnn , RootAnn + , TypeTag + , FieldTag + , VarTag -- * Creation and conversions , noAnn diff --git a/src/Michelson/Untyped/EntryPoints.hs b/src/Michelson/Untyped/EntryPoints.hs --- a/src/Michelson/Untyped/EntryPoints.hs +++ b/src/Michelson/Untyped/EntryPoints.hs @@ -10,9 +10,12 @@ , epNameFromRefAnn , epNameToRefAnn , EpNameFromRefAnnError (..) + , buildEpName + , unsafeBuildEpName , mkEntrypointsMap ) where +import Data.Aeson.TH (deriveJSON) import Data.Default (Default(..)) import qualified Data.Map as Map import Fmt (Buildable(..), pretty, (+|), (|+)) @@ -20,6 +23,7 @@ import Michelson.Untyped.Annotation import Michelson.Untyped.Type +import Util.Aeson import Util.CLI -- | Entrypoint name. @@ -32,6 +36,8 @@ instance NFData EpName +deriveJSON morleyAesonOptions ''EpName + pattern DefEpName :: EpName pattern DefEpName = EpNameUnsafe "" @@ -82,18 +88,22 @@ epNameToRefAnn :: EpName -> FieldAnn epNameToRefAnn (EpNameUnsafe name) = ann name +buildEpName :: Text -> Either String EpName +buildEpName txt = do + annotation <- + mkAnnotation txt + & first (mappend "Failed to parse entrypoint: " . pretty) + epNameFromRefAnn annotation + & first pretty + +unsafeBuildEpName :: Text -> EpName +unsafeBuildEpName = either (error . pretty) id . buildEpName + instance Arbitrary FieldAnn => Arbitrary EpName where arbitrary = arbitrary `suchThatMap` (rightToMaybe . epNameFromRefAnn) instance HasCLReader EpName where - getReader = eitherReader parseEntrypointDo - where - parseEntrypointDo (toText -> txt) = do - an <- - mkAnnotation txt - & first (mappend "Failed to parse entrypoint: " . pretty) - epNameFromRefAnn an - & first pretty + getReader = eitherReader (buildEpName . toText) getMetavar = "ENTRYPOINT" -- | Given an untyped type, extract a map that maps entrypoint names to the diff --git a/src/Michelson/Untyped/Ext.hs b/src/Michelson/Untyped/Ext.hs --- a/src/Michelson/Untyped/Ext.hs +++ b/src/Michelson/Untyped/Ext.hs @@ -116,9 +116,9 @@ -- | A stack function that expresses the type signature of a @LetMacro@ data StackFn = StackFn - { quantifiedVars :: Maybe (Set Var) - , inPattern :: StackTypePattern - , outPattern :: StackTypePattern + { sfnQuantifiedVars :: Maybe (Set Var) + , sfnInPattern :: StackTypePattern + , sfnOutPattern :: StackTypePattern } deriving stock (Eq, Show, Data, Generic) instance NFData StackFn diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs --- a/src/Michelson/Untyped/Instr.hs +++ b/src/Michelson/Untyped/Instr.hs @@ -11,14 +11,17 @@ , flattenExpandedOp -- * Contract's address + , OperationHash (..) , OriginationOperation (..) - , mkContractAddress + , GlobalCounter (..) + , mkOriginationOperationHash ) where import Prelude hiding (EQ, GT, LT) import qualified Data.Aeson as Aeson import Data.Aeson.TH (deriveJSON) +import Data.Binary.Put (putWord64be, runPut) import qualified Data.ByteString.Lazy as BSL import Data.Data (Data(..)) import Fmt (Buildable(build), (+|), (|+)) @@ -36,9 +39,9 @@ import Michelson.Untyped.Ext (ExtInstrAbstract) import Michelson.Untyped.Type (Type) import Michelson.Untyped.Value (Value'(..)) -import Tezos.Address (Address, mkContractAddressRaw) +import Tezos.Address (Address(..), OperationHash(..)) import Tezos.Core (Mutez) -import Tezos.Crypto (KeyHash) +import Tezos.Crypto (KeyHash, blake2b) import Util.Aeson ------------------------------------- @@ -313,11 +316,7 @@ mi -> buildRenderDoc mi ---------------------------------------------------------------------------- --- Contract's address computation --- --- Note: it might be a bit weird place for this functionality, but it's the --- lowest layer where all necessary Michelson types are defined. We may --- reconsider it later. +-- Operation hash computation ---------------------------------------------------------------------------- -- | Data necessary to originate a contract. @@ -332,15 +331,30 @@ -- ^ Initial storage value of the contract. , ooContract :: Contract' ExpandedOp -- ^ The contract itself. - } deriving stock (Show, Generic) + } deriving stock (Show, Eq, Generic) --- | Compute address of a contract from its origination operation. +newtype GlobalCounter = GlobalCounter { unGlobalCounter :: Word64 } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +-- | Construct 'OperationHash' for an 'OriginationOperation'. -- --- TODO [TM-62] It's certainly imprecise, real Tezos implementation doesn't --- use JSON, but we don't need precise format yet, so we just use some --- serialization format (JSON because we have necessary instances already). -mkContractAddress :: OriginationOperation -> Address -mkContractAddress = mkContractAddressRaw . BSL.toStrict . Aeson.encode +-- In Tezos each operation has a special field called @counter@, see here: +-- https://gitlab.com/tezos/tezos/-/blob/master/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120 +-- +-- This counter seems to be a part of global state of Tezos network. In fact, it may be observed +-- in raw JSON representation of the operation in the network explorer. +-- +-- This counter is increased at each operation and thus ensures that origination of identical +-- contracts with identical metadata will result in different addresses. +-- +-- Our counter is represented as 'Word64', while in Tezos it is unbounded. We believe that +-- for our interpreter it should not matter. +mkOriginationOperationHash :: OriginationOperation -> GlobalCounter -> OperationHash +mkOriginationOperationHash op (GlobalCounter counter) = + -- TODO [#235] This should use the same encoding as used in Tezos. + -- Using JSON is easier for now, however. + OperationHash $ blake2b $ BSL.toStrict $ Aeson.encode op <> runPut (putWord64be counter) ---------------------------------------------------------------------------- -- JSON serialization diff --git a/src/Michelson/Untyped/Type.hs b/src/Michelson/Untyped/Type.hs --- a/src/Michelson/Untyped/Type.hs +++ b/src/Michelson/Untyped/Type.hs @@ -8,15 +8,6 @@ ( Type (..) , T (..) , ParameterType (..) - , tint - , tnat - , tstring - , tbytes - , tmutez - , tbool - , tkeyHash - , ttimestamp - , taddress , toption , tpair , tor @@ -220,33 +211,6 @@ instance NFData T -tint :: T -tint = TInt - -tnat :: T -tnat = TNat - -tstring :: T -tstring = TString - -tbytes :: T -tbytes = TBytes - -tmutez :: T -tmutez = TMutez - -tbool :: T -tbool = TBool - -tkeyHash :: T -tkeyHash = TKeyHash - -ttimestamp :: T -ttimestamp = TTimestamp - -taddress :: T -taddress = TAddress - toption :: Type -> T toption t = TOption t @@ -257,16 +221,16 @@ tor l r = TOr noAnn noAnn l r tyint :: Type -tyint = Type tint noAnn +tyint = Type TInt noAnn tynat :: Type -tynat = Type tnat noAnn +tynat = Type TNat noAnn tyunit :: Type tyunit = Type TUnit noAnn tybool :: Type -tybool = Type tbool noAnn +tybool = Type TBool noAnn typair :: Type -> Type -> Type typair l r = Type (tpair l r) noAnn diff --git a/src/Morley/Micheline.hs b/src/Morley/Micheline.hs --- a/src/Morley/Micheline.hs +++ b/src/Morley/Micheline.hs @@ -2,78 +2,11 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ --- | Module that provides type classes for converting to and from low-level --- Micheline representation. module Morley.Micheline - ( ToExpression (..) - , FromExpression (..) + ( module Exports ) where -import Data.Sequence (fromList, (|>)) -import Data.Singletons (pattern FromSing, Sing, SingI, withSingI) -import Tezos.Common.Binary (decode, encode) -import Tezos.V005.Micheline - (Annotation(..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..)) - -import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT') -import Michelson.Interpret.Unpack (unpackInstr', unpackValue') -import Michelson.Typed - (Contract(..), 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 --- something to Micheline Expression. -class ToExpression a where - toExpression :: a -> Expression - -instance ToExpression (Instr inp out) where - toExpression = decode . packCode' - -instance ToExpression T where - toExpression (FromSing (ts :: Sing t)) = - decode $ withSingI ts $ (packT' @t) - -instance SingI t => ToExpression (Notes t) where - toExpression = decode . packNotedT' - -instance (SingI t, HasNoOp t) => ToExpression (Value t) where - toExpression = decode . encodeValue' - -instance ToExpression (Contract cp st) where - toExpression Contract{..} = Expression_Seq $ fromList - [ Expression_Prim $ - MichelinePrimAp (MichelinePrimitive "parameter") - (fromList [ addRootAnnToExpression (pnRootAnn cParamNotes) $ - toExpression $ pnNotes cParamNotes - ]) - (fromList []) - , Expression_Prim $ - MichelinePrimAp (MichelinePrimitive "storage") - (fromList [toExpression $ cStoreNotes]) - (fromList []) - , Expression_Prim $ - MichelinePrimAp (MichelinePrimitive "code") - (fromList [toExpression cCode]) - (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. -class FromExpression a where - fromExpression :: Expression -> Maybe a - -instance UnpackedValScope t => FromExpression (Value t) where - fromExpression = rightToMaybe . unpackValue' . ("\05" <>) . encode - -instance UnpackedValScope t => FromExpression [ExpandedOp] where - fromExpression = rightToMaybe . unpackInstr' . encode +import Morley.Micheline.Binary as Exports +import Morley.Micheline.Class as Exports +import Morley.Micheline.Json as Exports +import Morley.Micheline.Expression as Exports diff --git a/src/Morley/Micheline/Binary.hs b/src/Morley/Micheline/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Micheline/Binary.hs @@ -0,0 +1,158 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- SPDX-FileCopyrightText: 2018 obsidian.systems +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems + +-- | Module that define encoding and decoding function from Expression type +-- to binary format. +module Morley.Micheline.Binary + ( decodeExpression + , eitherDecodeExpression + , encodeExpression + ) where + +import qualified Data.Binary.Get as Bi +import qualified Data.Binary.Builder as Bi +import Data.Bits (Bits, (.&.), (.|.), bit, setBit, shift, testBit, zeroBits) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Sequence (Seq((:<|))) +import qualified Data.Sequence as Seq +import qualified Data.Text.Encoding as TE + +import Morley.Micheline.Expression +import Util.Binary (UnpackError(..), ensureEnd, launchGet) + +newtype DynamicSize a = DynamicSize { unDynamicSize :: a } + +------------------------------------------------- +-- Encode +------------------------------------------------- + +-- | Encode 'Expression' to 'ByteString'. +encodeExpression :: Expression -> BS.ByteString +encodeExpression = LBS.toStrict . Bi.toLazyByteString . buildExpr + +buildExpr :: Expression -> Bi.Builder +buildExpr = \case + ExpressionSeq xs -> buildWord8 2 <> buildDynamic buildSeq (DynamicSize xs) + ExpressionPrim (MichelinePrimAp prim args annots) -> case (args, annots) of + (Seq.Empty, Seq.Empty) -> buildWord8 3 <> buildPrim prim + (Seq.Empty, _) -> buildWord8 4 <> buildPrim prim <> buildAnnotationSeq annots + (arg1 :<| Seq.Empty, Seq.Empty) -> buildWord8 5 <> buildPrim prim <> buildExpr arg1 + (arg1 :<| Seq.Empty, _) -> buildWord8 6 <> buildPrim prim <> buildExpr arg1 <> buildAnnotationSeq annots + (arg1 :<| (arg2 :<| Seq.Empty), Seq.Empty) -> buildWord8 7 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2 + (arg1 :<| (arg2 :<| Seq.Empty), _) -> buildWord8 8 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2 <> buildAnnotationSeq annots + _ -> buildWord8 9 <> buildPrim prim <> buildDynamic buildSeq (DynamicSize args) <> buildAnnotationSeq annots + ExpressionString x -> buildWord8 1 <> buildDynamic buildText (DynamicSize x) + ExpressionInt x -> buildWord8 0 <> buildInteger x + ExpressionBytes x -> buildWord8 10 <> buildDynamic buildByteString (DynamicSize x) + +buildWord8 :: Word8 -> Bi.Builder +buildWord8 = Bi.singleton + +buildByteString :: ByteString -> Bi.Builder +buildByteString = Bi.fromByteString + +buildInteger :: Integer -> Bi.Builder +buildInteger n = + let signBit = if n < 0 then bit 6 else zeroBits + ab = abs n + in + -- Refer to: https://gitlab.com/obsidian.systems/tezos-bake-monitor-lib/-/blob/2cf12e53072bcd966d471430ead25f597db5e23f/tezos-bake-monitor-lib/src/Tezos/Common/Binary.hs#L122 + if ab < 0x40 then Bi.singleton (fromIntegral ab .|. signBit) + else Bi.singleton (fromIntegral (ab .&. 0x3f) .|. signBit .|. bit 7) <> writeZ (-6) ab + +writeZ :: (Integral a, Bits a) => Int -> a -> Bi.Builder +writeZ offset n = + if n < bit (7 - offset) then Bi.singleton $ fromIntegral $ n `shift` offset + else Bi.singleton (fromIntegral (((n `shift` offset) .&. 0x7f) `setBit` 7)) <> writeZ (offset - 7) n + +buildDynamic :: (a -> Bi.Builder) -> (DynamicSize a) -> Bi.Builder +buildDynamic build (DynamicSize x) = + let b = build x + in Bi.putWord32be (fromIntegral $ LBS.length $ Bi.toLazyByteString b) <> b + +buildText :: Text -> Bi.Builder +buildText n = + buildByteString $ TE.encodeUtf8 n + +buildSeq :: Seq Expression -> Bi.Builder +buildSeq xs = foldMap buildExpr xs + +buildPrim :: MichelinePrimitive -> Bi.Builder +buildPrim (MichelinePrimitive p) = case Seq.elemIndexL p michelsonPrimitive of + Nothing -> error "unknown Michelson/Micheline primitive" + Just ix -> buildWord8 (fromIntegral ix) + +buildAnnotationSeq :: Seq Annotation -> Bi.Builder +buildAnnotationSeq seqAnn = buildDynamic buildText (DynamicSize $ unwords . toList . fmap annotToText $ seqAnn) + +------------------------------------------------- +-- Decode +------------------------------------------------- + +-- | Decode 'Expression' from 'ByteString'. +eitherDecodeExpression :: BS.ByteString -> Either UnpackError Expression +eitherDecodeExpression x = launchGet (getExpr <* ensureEnd) $ LBS.fromStrict x + +-- | Partial version of 'eitherDecodeExpression'. +decodeExpression :: HasCallStack => BS.ByteString -> Expression +decodeExpression = either (error . unUnpackError) id . eitherDecodeExpression + +getExpr :: Bi.Get Expression +getExpr = Bi.getWord8 >>= \case + 0 -> ExpressionInt <$> getInteger + 1 -> ExpressionString . unDynamicSize <$> (getDynamic getText) + 2 -> ExpressionSeq . unDynamicSize <$> (getDynamic getSeq) + 3 -> ExpressionPrim . (\pn -> MichelinePrimAp pn Seq.Empty Seq.Empty) <$> getPrim + 4 -> ExpressionPrim <$> (flip MichelinePrimAp Seq.Empty <$> getPrim <*> getAnnotationSeq) + 5 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (Seq.singleton <$> getExpr) <*> pure Seq.empty) + 6 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (Seq.singleton <$> getExpr) <*> getAnnotationSeq) + 7 -> ExpressionPrim <$> ((\n a -> MichelinePrimAp n a Seq.empty) <$> getPrim <*> Seq.replicateA 2 getExpr) + 8 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> Seq.replicateA 2 getExpr <*> getAnnotationSeq) + 9 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (unDynamicSize <$> (getDynamic getSeq)) <*> getAnnotationSeq) + 10 -> ExpressionBytes . unDynamicSize <$> (getDynamic getByteString) + _ -> fail "invalid Micheline expression tag" + +getInteger :: Bi.Get Integer +getInteger = do + b <- Bi.getWord8 + n <- if b `testBit` 7 then readZ 6 (fromIntegral $ b .&. 0x3f) else pure (fromIntegral $ b .&. 0x3f) + pure $ if b `testBit` 6 then negate n else n + +readZ :: (Num a, Bits a) => Int -> a -> Bi.Get a +readZ offset n = do + b <- Bi.getWord8 + if (b == 0) && (offset > 0) then fail "trailing zero" else pure () + let n' = (fromIntegral (b .&. 0x7f) `shift` offset) .|. n + if b `testBit` 7 then readZ (offset + 7) n' else pure n' + +getDynamic :: (Bi.Get a) -> (Bi.Get (DynamicSize a)) +getDynamic getter = do + len <- fromIntegral <$> Bi.getWord32be + DynamicSize <$> Bi.isolate len getter + +getText :: Bi.Get Text +getText = + fmap decodeUtf8' getByteString >>= \case + Left err -> fail $ show err + Right answer -> pure answer + +getByteString :: Bi.Get ByteString +getByteString = + LBS.toStrict <$> Bi.getRemainingLazyByteString + +getSeq :: Bi.Get (Seq Expression) +getSeq = + Seq.fromList <$> many getExpr + +getPrim :: Bi.Get MichelinePrimitive +getPrim = + Bi.getWord8 >>= \ix -> case Seq.lookup (fromIntegral ix) michelsonPrimitive of + Nothing -> fail "unknown Michelson/Micheline opcode" + Just str -> pure $ MichelinePrimitive str + +getAnnotationSeq :: Bi.Get (Seq Annotation) +getAnnotationSeq = mapM annotFromText . Seq.fromList . words . unDynamicSize =<< (getDynamic getText) diff --git a/src/Morley/Micheline/Class.hs b/src/Morley/Micheline/Class.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Micheline/Class.hs @@ -0,0 +1,79 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +-- | Module that provides type classes for converting to and from low-level +-- Micheline representation. +module Morley.Micheline.Class + ( ToExpression (..) + , FromExpression (..) + ) where + +import Data.Sequence (fromList, (|>)) +import Data.Singletons (pattern FromSing, Sing, SingI, withSingI) + +import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT') +import Michelson.Interpret.Unpack (unpackInstr', unpackValue') +import Michelson.Typed + (Contract(..), HasNoOp, Instr(..), Notes(..), T(..), Value, pnNotes, pnRootAnn) +import Michelson.Typed.Scope (UnpackedValScope) +import Michelson.Untyped.Annotation (RootAnn, convAnn) +import Michelson.Untyped.Instr (ExpandedOp) +import Morley.Micheline.Binary (decodeExpression, encodeExpression) +import Morley.Micheline.Expression (Annotation (..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..)) + +-- | Type class that provides an ability to convert +-- something to Micheline Expression. +class ToExpression a where + toExpression :: a -> Expression + +instance ToExpression (Instr inp out) where + toExpression = decodeExpression . packCode' + +instance ToExpression T where + toExpression (FromSing (ts :: Sing t)) = + decodeExpression $ withSingI ts $ (packT' @t) + +instance SingI t => ToExpression (Notes t) where + toExpression = decodeExpression . packNotedT' + +instance (SingI t, HasNoOp t) => ToExpression (Value t) where + toExpression = decodeExpression . encodeValue' + +instance ToExpression (Contract cp st) where + toExpression Contract{..} = ExpressionSeq $ fromList + [ ExpressionPrim $ + MichelinePrimAp (MichelinePrimitive "parameter") + (fromList [ addRootAnnToExpression (pnRootAnn cParamNotes) $ + toExpression $ pnNotes cParamNotes + ]) + (fromList []) + , ExpressionPrim $ + MichelinePrimAp (MichelinePrimitive "storage") + (fromList [toExpression $ cStoreNotes]) + (fromList []) + , ExpressionPrim $ + MichelinePrimAp (MichelinePrimitive "code") + (fromList [toExpression cCode]) + (fromList []) + ] + where + addRootAnnToExpression :: RootAnn -> Expression -> Expression + addRootAnnToExpression rootAnn = \case + ExpressionPrim p -> ExpressionPrim + p{ mpaAnnots = mpaAnnots p |> + (AnnotationField $ convAnn rootAnn) + } + x -> x + +-- | Type class that provides the ability to convert +-- something from a Micheline Expression. +class FromExpression a where + fromExpression :: Expression -> Maybe a + +instance UnpackedValScope t => FromExpression (Value t) where + -- | `05` is the prefix for serialized Michelson value. + fromExpression = rightToMaybe . unpackValue' . ("\05" <>) . encodeExpression + +instance FromExpression [ExpandedOp] where + fromExpression = rightToMaybe . unpackInstr' . encodeExpression diff --git a/src/Morley/Micheline/Expression.hs b/src/Morley/Micheline/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Micheline/Expression.hs @@ -0,0 +1,183 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- SPDX-FileCopyrightText: 2018 obsidian.systems +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems + +-- | Module that defines Expression type, its related types +-- and its JSON instance. +module Morley.Micheline.Expression + ( Annotation(..) + , Expression(..) + , MichelinePrimAp(..) + , MichelinePrimitive(..) + , michelsonPrimitive + , annotToText + , annotFromText + , genExpression + , genExpressionSeq + , genMichelinePrimAp + , genExprAnnotation + ) where + +import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:), (.:?)) +import Data.Aeson.Casing (aesonPrefix, snakeCase) +import qualified Data.Aeson.Encoding.Internal as Aeson +import Data.Aeson.TH (deriveToJSON) +import qualified Data.Aeson.Types as Aeson +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Sequence as Seq +import qualified Data.Text as T (uncons) +import Fmt (pretty) +import Hedgehog (MonadGen(GenBase)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import qualified Michelson.Untyped.Annotation as MUA (Annotation) +import Michelson.Untyped.Annotation + (KnownAnnTag(..), FieldAnn, TypeAnn, VarAnn, TypeTag, FieldTag, VarTag, ann, annPrefix) +import Morley.Micheline.Json +import Util.ByteString (HexJSONByteString(..)) +import Util.Test.Gen (genAnnotation) + +newtype MichelinePrimitive = MichelinePrimitive Text + deriving newtype (Eq, Ord, ToJSON, FromJSON) + deriving stock (Show) + +michelsonPrimitive :: Seq Text +michelsonPrimitive = Seq.fromList [ + "parameter", "storage", "code", "False", "Elt", "Left", "None", "Pair", + "Right", "Some", "True", "Unit", "PACK", "UNPACK", "BLAKE2B", "SHA256", + "SHA512", "ABS", "ADD", "AMOUNT", "AND", "BALANCE", "CAR", "CDR", + "CHECK_SIGNATURE", "COMPARE", "CONCAT", "CONS", "CREATE_ACCOUNT", + "CREATE_CONTRACT", "IMPLICIT_ACCOUNT", "DIP", "DROP", "DUP", "EDIV", + "EMPTY_MAP", "EMPTY_SET", "EQ", "EXEC", "FAILWITH", "GE", "GET", "GT", + "HASH_KEY", "IF", "IF_CONS", "IF_LEFT", "IF_NONE", "INT", "LAMBDA", + "LE", "LEFT", "LOOP", "LSL", "LSR", "LT", "MAP", "MEM", "MUL", "NEG", + "NEQ", "NIL", "NONE", "NOT", "NOW", "OR", "PAIR", "PUSH", "RIGHT", + "SIZE", "SOME", "SOURCE", "SENDER", "SELF", "STEPS_TO_QUOTA", "SUB", + "SWAP", "TRANSFER_TOKENS", "SET_DELEGATE", "UNIT", "UPDATE", "XOR", + "ITER", "LOOP_LEFT", "ADDRESS", "CONTRACT", "ISNAT", "CAST", "RENAME", + "bool", "contract", "int", "key", "key_hash", "lambda", "list", "map", + "big_map", "nat", "option", "or", "pair", "set", "signature", "string", + "bytes", "mutez", "timestamp", "unit", "operation", "address", "SLICE", + "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID" + ] + +-- | Type for Micheline Expression +data Expression + = ExpressionInt Integer + -- ^ Micheline represents both nats and ints using the same decimal format. + -- The Haskell Integer type spans all possible values that the final + -- (Michelson) type could end up being, and then some, so we use + -- (StringEncode Integer) to represent all integral values here for easy + -- JSON encoding compatibility. + | ExpressionString Text + | ExpressionBytes ByteString + | ExpressionSeq (Seq Expression) + | ExpressionPrim MichelinePrimAp + deriving stock (Eq, Show) + +data Annotation + = AnnotationType TypeAnn + | AnnotationVariable VarAnn + | AnnotationField FieldAnn + deriving stock (Eq, Show) + +data MichelinePrimAp = MichelinePrimAp + { mpaPrim :: MichelinePrimitive + , mpaArgs :: Seq Expression + , mpaAnnots :: Seq Annotation + } deriving stock (Eq, Show) + +instance FromJSON MichelinePrimAp where + parseJSON = withObject "Prim" $ \v -> MichelinePrimAp + <$> v .: "prim" + <*> v .:? "args" .!= mempty + <*> v .:? "annots" .!= mempty + +deriveToJSON (aesonPrefix snakeCase) ''MichelinePrimAp + +annotFromText :: MonadFail m => Text -> m Annotation +annotFromText txt = case result of + Just a -> pure a + Nothing -> fail "Unknown annotation type" + where + result = (AnnotationType <$> stripPrefix @TypeTag txt) + <|> (AnnotationVariable <$> stripPrefix @VarTag txt) + <|> (AnnotationField <$> stripPrefix @FieldTag txt) + +stripPrefix :: forall tag . KnownAnnTag tag => Text -> Maybe (MUA.Annotation tag) +stripPrefix txt = do + (n, t) <- T.uncons txt + guard (toText [n] == prefix) + Just $ ann t + where + prefix = annPrefix @tag + +annotToText :: Annotation -> Text +annotToText = \case + AnnotationType n -> pretty n + AnnotationVariable n -> pretty n + AnnotationField n -> pretty n + +instance FromJSON Annotation where + parseJSON = withText "Annotation" annotFromText + +instance ToJSON Annotation where + toJSON = toJSON . annotToText + toEncoding = toEncoding . annotToText + +instance FromJSON Expression where + parseJSON v = ExpressionSeq <$> parseJSON v + <|> ExpressionPrim <$> parseJSON v + <|> ExpressionString <$> withObject "ExpressionString" (.: "string") v + <|> ExpressionInt . unStringEncode <$> withObject "ExpressionInt" (.: "int") v + <|> ExpressionBytes . unHexJSONByteString <$> withObject "ExpressionBytes" (.: "bytes") v + +instance ToJSON Expression where + toJSON (ExpressionSeq xs) = toJSON xs + toJSON (ExpressionPrim xs) = toJSON xs + toJSON (ExpressionString x) = Aeson.Object (HashMap.singleton "string" $ toJSON x) + toJSON (ExpressionInt x) = Aeson.Object (HashMap.singleton "int" $ toJSON $ StringEncode x) + toJSON (ExpressionBytes x) = Aeson.Object (HashMap.singleton "bytes" $ toJSON $ HexJSONByteString x) + + toEncoding (ExpressionSeq xs) = toEncoding xs + toEncoding (ExpressionPrim xs) = toEncoding xs + toEncoding (ExpressionString x) = Aeson.pairs (Aeson.pair "string" (toEncoding x)) + toEncoding (ExpressionInt x) = Aeson.pairs (Aeson.pair "int" (toEncoding $ StringEncode x)) + toEncoding (ExpressionBytes x) = Aeson.pairs (Aeson.pair "bytes" (toEncoding $ HexJSONByteString x)) + +----------------------------------------------------- +-- Gen Function for testing +----------------------------------------------------- + +genExpression :: forall m. (MonadGen m, GenBase m ~ Identity) => m Expression +genExpression = Gen.recursive Gen.choice + [genExpressionInt, genExpressionString, genExpressionBytes] + [genSeq, genExpressionPrim] + where + genExpressionInt = ExpressionInt <$> (Gen.integral (Range.linearFrom 0 -1000 1000)) + genExpressionString = ExpressionString <$> (Gen.text (Range.linear 0 10) Gen.unicodeAll) + genExpressionBytes = ExpressionBytes <$> (Gen.bytes (Range.linear 0 100)) + genSeq = ExpressionSeq <$> genExpressionSeq + genExpressionPrim = ExpressionPrim <$> genMichelinePrimAp + +genExpressionSeq :: forall m. (MonadGen m, GenBase m ~ Identity) => m (Seq Expression) +genExpressionSeq = (Gen.seq (Range.linear 0 10) genExpression) + +genMichelinePrimAp :: forall m. (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp +genMichelinePrimAp = MichelinePrimAp <$> genMichelinePrimitive <*> genExpressionSeq <*> genAnnots + where + genMichelinePrimitive = MichelinePrimitive <$> (Gen.element $ toList michelsonPrimitive) + + genAnnots :: m (Seq Annotation) + genAnnots = Gen.seq (Range.linear 0 10) genExprAnnotation + +genExprAnnotation :: forall m. (MonadGen m, GenBase m ~ Identity) => m Annotation +genExprAnnotation = Gen.choice + [genAnnotationType, genAnnotationVariable, genAnnotationField] + where + genAnnotationType = AnnotationType <$> genAnnotation + genAnnotationVariable = AnnotationVariable <$> genAnnotation + genAnnotationField = AnnotationField <$> genAnnotation diff --git a/src/Morley/Micheline/Json.hs b/src/Morley/Micheline/Json.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Micheline/Json.hs @@ -0,0 +1,48 @@ +-- SPDX-FileCopyrightText: 2018 obsidian.systems +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems + +-- | Module that defines helper types and functions that are related +-- to Micheline. +module Morley.Micheline.Json + ( StringEncode (..) + , TezosBigNum + , TezosInt64 + ) where + +import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON) +import qualified Data.Aeson.Encoding as AE +import qualified Data.Aeson.Types as Aeson +import Data.Bits (Bits) +import Data.Typeable (typeRep) +import qualified Text.Show as T + +parseAsString :: forall a. (Read a, Typeable a) => Aeson.Value -> Aeson.Parser a +parseAsString = Aeson.withText (T.show $ typeRep (Proxy :: Proxy a)) $ \txt -> + maybe (fail "Failed to parse string") pure $ readMaybe (toString txt) + +parseStringEncodedIntegral :: (Read a, Typeable a) => Aeson.Value -> Aeson.Parser (StringEncode a) +parseStringEncodedIntegral x = StringEncode <$> parseAsString x + +newtype StringEncode a = StringEncode { unStringEncode :: a } + deriving stock (Generic, Eq, Ord, Bounded, Read, Show) + deriving newtype (Enum, Num, Integral, Bits, Real, NFData, Hashable) + +type TezosBigNum = StringEncode Integer + +instance FromJSON TezosBigNum where + parseJSON = parseStringEncodedIntegral + +instance ToJSON TezosBigNum where + toJSON (StringEncode x) = Aeson.String $ show x + toEncoding (StringEncode x) = AE.integerText x + +type TezosInt64 = StringEncode Int64 + +instance FromJSON TezosInt64 where + parseJSON = parseStringEncodedIntegral + +instance ToJSON TezosInt64 where + toJSON (StringEncode x) = Aeson.String $ show x + toEncoding (StringEncode x) = AE.int64Text x diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs --- a/src/Tezos/Address.hs +++ b/src/Tezos/Address.hs @@ -9,9 +9,13 @@ , Address (..) , mkKeyAddress , detGenKeyAddress - , mkContractAddressRaw - , mkContractHashRaw + , OperationHash (..) + , OriginationIndex (..) + , mkContractAddress + , mkContractHashHack + , genAddress + -- * Formatting , ParseAddressError (..) , ParseContractAddressError @@ -26,9 +30,14 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encoding as Aeson import qualified Data.Aeson.Types as AesonTypes +import Data.Binary.Put (putInt32be, runPut) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Fmt (fmt, hexF, pretty) import qualified Formatting.Buildable as Buildable +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary(..), oneof, vector) import Michelson.Text @@ -61,24 +70,51 @@ detGenKeyAddress :: ByteString -> Address detGenKeyAddress = mkKeyAddress . toPublic . detSecretKey --- | Smart constructor for 'ContractAddress'. Its argument is --- serialized origination operation. +newtype OperationHash = OperationHash + { unOperationHash :: ByteString + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +newtype OriginationIndex = OriginationIndex { unOriginationIndex :: Int32 } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +-- | Compute address of a contract from its origination operation and origination index. -- --- Note: it's quite unsafe to pass 'ByteString', because we can pass --- some garbage which is not a serialized origination operation, but --- this operation includes contract itself and necessary types are --- defined in 'Michelson.*'. So we have to serialize this data outside --- this module and pass it here as a 'ByteString'. Alternatively we --- could add some constraint, but it would be almost as unsafe as --- passing a 'ByteString'. For this reason we add `Raw` suffix to this --- function and provide a safer function in 'Michelson.Untyped.Instr'. --- We may reconsider it later. -mkContractAddressRaw :: ByteString -> Address -mkContractAddressRaw = ContractAddress . mkContractHashRaw +-- However, in real Tezos encoding of the operation is more than just 'OriginationOperation'. +-- There an Operation has several more meta-fields plus a big sum-type of all possible operations. +-- +-- See here: https://gitlab.com/tezos/tezos/-/blob/master/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78 +-- +-- What is important is that one (big) Operation may lead to origination of multiple contracts. That +-- is why contract address is constructed from hash of the operation that originated and of index +-- of the contract's origination in the execution of that operation. +-- +-- In other words, contract hash is calculated as the blake2b160 (20-byte) hash of +-- origination operation hash + int32 origination index. +-- +-- In Morley we do not yet support full encoding of Tezos Operations, therefore we choose +-- to generate contract addresses in a simplified manner. +-- +-- Namely, we encode 'OriginationOperation' as we can and concat it with the origination index. +-- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's +-- address. +mkContractAddress + :: OperationHash + -> OriginationIndex + -> Address +mkContractAddress (OperationHash opHash) (OriginationIndex idx) = + ContractAddress + $ ContractHash + $ blake2b160 + $ opHash <> BSL.toStrict (runPut $ putInt32be idx) --- | Create a dummy 'ContractHash' value. -mkContractHashRaw :: ByteString -> ContractHash -mkContractHashRaw = ContractHash . blake2b160 . blake2b160 +-- | Create a dummy 'ContractHash' value by hashing given 'ByteString'. +-- +-- Use in tests **only**. +mkContractHashHack :: ByteString -> ContractHash +mkContractHashHack = ContractHash . blake2b160 ---------------------------------------------------------------------------- -- Formatting/parsing @@ -236,3 +272,10 @@ where genKeyAddress = KeyAddress <$> arbitrary genContractAddress = ContractAddress . ContractHash . BS.pack <$> vector 20 + +genAddress :: MonadGen m => m Address +genAddress = Gen.choice [genKeyAddress, genContractAddress] + where + genKeyAddress = KeyAddress <$> genKeyHash + genContractAddress = ContractAddress . ContractHash <$> Gen.bytes (Range.singleton 20) + diff --git a/src/Tezos/Core.hs b/src/Tezos/Core.hs --- a/src/Tezos/Core.hs +++ b/src/Tezos/Core.hs @@ -41,6 +41,7 @@ , mformatChainId , parseChainId , chainIdLength + , genChainId ) where import Data.Aeson (FromJSON(..), ToJSON(..)) @@ -56,6 +57,9 @@ import Data.Time.RFC3339 (formatTimeRFC3339) import Fmt (fmt, hexF, pretty) import Formatting.Buildable (Buildable(build)) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH.Quote as TH import Language.Haskell.TH.Syntax (liftData) import qualified Options.Applicative as Opt @@ -335,6 +339,9 @@ instance Arbitrary ChainId where arbitrary = ChainIdUnsafe . BS.pack <$> (vector 4) + +genChainId :: MonadGen m => m ChainId +genChainId = ChainIdUnsafe <$> Gen.bytes (Range.singleton 4) ---------------------------------------------------------------------------- -- JSON diff --git a/src/Tezos/Crypto.hs b/src/Tezos/Crypto.hs --- a/src/Tezos/Crypto.hs +++ b/src/Tezos/Crypto.hs @@ -40,6 +40,13 @@ , KeyHashTag (..) , KeyHash (..) + -- * Generators + , genPublicKey + , genSecretKey + , genSignature + , genKeyHashTag + , genKeyHash + -- * Public/secret key functions , detSecretKey , toPublic @@ -83,6 +90,9 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import Fmt (Buildable, build, pretty) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary(..), elements, oneof) import Michelson.Text @@ -113,6 +123,9 @@ instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary +genPublicKey :: MonadGen m => m PublicKey +genPublicKey = toPublic <$> genSecretKey + -- | Secret cryptographic key used by Tezos. -- Constructors correspond to 'PublicKey' constructors. data SecretKey @@ -142,6 +155,13 @@ , SecretKeyP256 <$> arbitrary ] +genSecretKey :: MonadGen m => m SecretKey +genSecretKey = Gen.choice + [ SecretKeyEd25519 <$> Ed25519.genSecretKey + , SecretKeySecp256k1 <$> Secp256k1.genSecretKey + , SecretKeyP256 <$> P256.genSecretKey + ] + -- | Create a public key from a secret key. toPublic :: SecretKey -> PublicKey toPublic = \case @@ -207,6 +227,14 @@ , SignatureGeneric . BS.replicate signatureLengthBytes <$> arbitrary ] +genSignature :: MonadGen m => m Signature +genSignature = Gen.choice + [ SignatureEd25519 <$> Ed25519.genSignature + , SignatureSecp256k1 <$> Secp256k1.genSignature + , SignatureP256 <$> P256.genSignature + , SignatureGeneric <$> Gen.bytes (Range.singleton signatureLengthBytes) + ] + ---------------------------------------------------------------------------- -- Signature ---------------------------------------------------------------------------- @@ -357,6 +385,9 @@ instance Arbitrary KeyHashTag where arbitrary = elements [minBound .. ] +genKeyHashTag :: MonadGen m => m KeyHashTag +genKeyHashTag = Gen.enumBounded + instance NFData KeyHashTag -- | Blake2b_160 hash of a public key. @@ -376,6 +407,9 @@ instance Arbitrary KeyHash where arbitrary = hashKey <$> arbitrary + +genKeyHash :: MonadGen m => m KeyHash +genKeyHash = hashKey <$> genPublicKey -- | Compute the b58check of a public key hash. hashKey :: PublicKey -> KeyHash diff --git a/src/Tezos/Crypto/Ed25519.hs b/src/Tezos/Crypto/Ed25519.hs --- a/src/Tezos/Crypto/Ed25519.hs +++ b/src/Tezos/Crypto/Ed25519.hs @@ -12,6 +12,12 @@ , detSecretKey , toPublic + -- * Generators + , genPublicKey + , genSecretKey + , genSignature + + -- * Raw bytes (no checksums, tags or anything) , publicKeyToBytes , mkPublicKey @@ -40,6 +46,9 @@ import Data.ByteArray (ByteArray, ByteArrayAccess, convert) import qualified Data.ByteString as BS import Fmt (Buildable, build) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary(..), vector) import Michelson.Text @@ -58,6 +67,9 @@ instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary +genPublicKey :: MonadGen m => m PublicKey +genPublicKey = toPublic <$> genSecretKey + instance NFData PublicKey -- | ED25519 secret cryptographic key. @@ -74,6 +86,9 @@ instance Arbitrary SecretKey where arbitrary = detSecretKey . BS.pack <$> vector 32 +genSecretKey :: MonadGen m => m SecretKey +genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32) + -- | Create a public key from a secret key. toPublic :: SecretKey -> PublicKey toPublic = PublicKey . Ed25519.toPublic . unSecretKey @@ -87,6 +102,9 @@ arbitrary = sign <$> arbitrary <*> (encodeUtf8 @String <$> arbitrary) instance NFData Signature + +genSignature :: MonadGen m => m Signature +genSignature = sign <$> genSecretKey <*> Gen.utf8 (Range.linear 0 100) Gen.unicode ---------------------------------------------------------------------------- -- Conversion to/from raw bytes (no checksums, tags or anything) diff --git a/src/Tezos/Crypto/P256.hs b/src/Tezos/Crypto/P256.hs --- a/src/Tezos/Crypto/P256.hs +++ b/src/Tezos/Crypto/P256.hs @@ -15,6 +15,11 @@ , detSecretKey , toPublic + -- * Generators + , genPublicKey + , genSecretKey + , genSignature + -- * Raw bytes (no checksums, tags or anything) , publicKeyToBytes , mkPublicKey @@ -40,6 +45,9 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import Fmt (Buildable, build) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary(..), vector) import Michelson.Text @@ -59,6 +67,9 @@ instance NFData PublicKey +genPublicKey :: MonadGen m => m PublicKey +genPublicKey = toPublic <$> genSecretKey + -- | P256 secret cryptographic key. newtype SecretKey = SecretKey { unSecretKey :: ByteString @@ -74,6 +85,9 @@ instance Arbitrary SecretKey where arbitrary = detSecretKey . BS.pack <$> vector 32 +genSecretKey :: MonadGen m => m SecretKey +genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32) + -- | Create a public key from a secret key. toPublic :: SecretKey -> PublicKey toPublic = PublicKey . unSecretKey @@ -87,6 +101,9 @@ arbitrary = Signature . BS.pack <$> replicateM signatureLengthBytes arbitrary instance NFData Signature + +genSignature :: MonadGen m => m Signature +genSignature = Signature <$> Gen.bytes (Range.singleton signatureLengthBytes) ---------------------------------------------------------------------------- -- Conversion to/from raw bytes (no checksums, tags or anything) diff --git a/src/Tezos/Crypto/Secp256k1.hs b/src/Tezos/Crypto/Secp256k1.hs --- a/src/Tezos/Crypto/Secp256k1.hs +++ b/src/Tezos/Crypto/Secp256k1.hs @@ -12,6 +12,11 @@ , detSecretKey , toPublic + -- * Generators + , genPublicKey + , genSecretKey + , genSignature + -- * Raw bytes (no checksums, tags or anything) , publicKeyToBytes , mkPublicKey @@ -37,13 +42,17 @@ import Crypto.Number.Serialize (i2ospOf_, os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Generate as ECC.Generate -import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), CurveCommon(..), CurvePrime(..) - ,Point(..), curveSizeBits, getCurveByName) +import Crypto.PubKey.ECC.Types + (Curve(..), CurveCommon(..), CurveName(..), CurvePrime(..), Point(..), curveSizeBits, + getCurveByName) import Crypto.Random (MonadRandom, drgNewSeed, seedFromInteger, withDRG) import Data.ByteArray (ByteArray, ByteArrayAccess) import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import Fmt (Buildable, build) +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.QuickCheck (Arbitrary(..), vector) import Michelson.Text @@ -78,6 +87,9 @@ instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary +genPublicKey :: MonadGen m => m PublicKey +genPublicKey = toPublic <$> genSecretKey + rnfCurve :: Curve -> () rnfCurve cu = case cu of @@ -111,6 +123,9 @@ instance Arbitrary SecretKey where arbitrary = detSecretKey . BS.pack <$> vector 32 +genSecretKey :: MonadGen m => m SecretKey +genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32) + -- | Create a public key from a secret key. toPublic :: SecretKey -> PublicKey toPublic = @@ -132,6 +147,14 @@ instance NFData Signature where rnf (Signature (ECDSA.Signature a b)) = rnf a `seq` rnf b + +genSignature :: MonadGen m => m Signature +genSignature = do + seed <- drgNewSeed . seedFromInteger <$> Gen.integral (Range.linearFrom 0 -1000 1000) + byteToSign <- Gen.word8 Range.linearBounded + return $ fst $ withDRG seed $ do + sk <- detSecretKeyDo + sign sk (one byteToSign) ---------------------------------------------------------------------------- -- Conversion to/from raw bytes (no checksums, tags or anything) diff --git a/src/Util/Binary.hs b/src/Util/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Util/Binary.hs @@ -0,0 +1,47 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +-- | Module contains helper functions when dealing with encoding +-- and decoding 'Binary' +module Util.Binary + ( UnpackError (..) + , ensureEnd + , launchGet + ) where + +import Prelude hiding (EQ, Ordering(..), get) + +import Data.Binary (Get) +import qualified Data.Binary.Get as Get +import qualified Data.ByteString.Lazy as LBS +import Fmt (Buildable, build, pretty, (+|), (+||), (|+), (||+)) +import Text.Hex (encodeHex) + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +-- | Any decoding error. +newtype UnpackError = UnpackError { unUnpackError :: Text } + deriving stock (Show, Eq) + +instance Buildable UnpackError where + build (UnpackError msg) = build msg + +instance Exception UnpackError where + displayException = pretty + +ensureEnd :: Get () +ensureEnd = + unlessM Get.isEmpty $ do + remainder <- Get.getRemainingLazyByteString + fail $ "Expected end of entry, unconsumed bytes \ + \(" +| length remainder |+ "): " + +|| encodeHex (LBS.toStrict remainder) ||+ "" + +launchGet :: Get a -> LByteString -> Either UnpackError a +launchGet decoder bs = + case Get.runGetOrFail decoder bs of + Left (_remainder, _offset, err) -> Left . UnpackError $ toText err + Right (_remainder, _offset, res) -> Right res diff --git a/src/Util/ByteString.hs b/src/Util/ByteString.hs --- a/src/Util/ByteString.hs +++ b/src/Util/ByteString.hs @@ -12,6 +12,8 @@ -- | Newtype wrapper for ByteString which uses hexadecimal representation -- for JSON serialization. newtype HexJSONByteString = HexJSONByteString { unHexJSONByteString :: ByteString } + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (NFData, Hashable) instance ToJSON HexJSONByteString where toJSON = toJSON . encodeHex . unHexJSONByteString diff --git a/src/Util/Test/Arbitrary.hs b/src/Util/Test/Arbitrary.hs --- a/src/Util/Test/Arbitrary.hs +++ b/src/Util/Test/Arbitrary.hs @@ -121,6 +121,7 @@ , LOOP_LEFT <$> smallList , LAMBDA <$> arbitrary <*> arbitrary <*> arbitrary <*> smallList , EXEC <$> arbitrary + , APPLY <$> arbitrary , DIP <$> smallList , pure FAILWITH , CAST <$> arbitrary <*> arbitrary diff --git a/src/Util/Test/Gen.hs b/src/Util/Test/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Util/Test/Gen.hs @@ -0,0 +1,317 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +module Util.Test.Gen + ( genInternalByteString + , genVar + , genTyVar + , genExpandedOp + , genInstrCallStack + , genSrcPos + , genPos + , genLetName + , genExtInstrAbstract + , genPrintComment + , genStackRef + , genTestAssert + , genStackFn + , genStackTypePattern + , genInstrAbstract + , genContract + , genContract' + , genValue + , genValue' + , genElt + , genParameterType + , genType + , genEpName + , genAnnotation + , genT + ) where + +import Prelude hiding (EQ, GT, LT) + +import qualified Data.Text as T +import Hedgehog (MonadGen(GenBase), Range) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..)) +import Michelson.Test.Util (genEither) +import Michelson.Text (genMText) +import Michelson.Untyped + (Annotation, Contract, Contract'(..), Elt(..), EpName, ExpandedOp(..), ExtInstrAbstract(..), + InstrAbstract(..), InternalByteString(..), ParameterType(..), PrintComment(..), StackFn(..), + StackRef(..), StackTypePattern(..), T(..), TestAssert(..), TyVar(..), Type(..), Value, + Value'(..), Var(..), epNameFromRefAnn, mkAnnotation, specialFieldAnn, specialVarAnns) + +genInternalByteString :: MonadGen m => m InternalByteString +genInternalByteString = InternalByteString <$> Gen.bytes (Range.linear 0 100) + +genVar :: MonadGen m => m Var +genVar = Var <$> genSmallText + +genTyVar :: (MonadGen m, GenBase m ~ Identity) => m TyVar +genTyVar = Gen.choice [VarID <$> genVar, TyCon <$> genType] + +genExpandedOp :: (MonadGen m, GenBase m ~ Identity) => m ExpandedOp +genExpandedOp = Gen.recursive Gen.choice + -- non-recursive constructors + [ + -- NB: When used together, genExpandedOp & genInstrAbstract are mutually recursive. + -- So we use a generator of InstrAbstract that does not contain any ops as an escape hatch. + PrimEx <$> Gen.choice instrAbstractWithoutOp + ] + -- recursive constructors + [ PrimEx <$> genInstrAbstract genExpandedOp + , SeqEx <$> genSmallList genExpandedOp + , Gen.subtermM genExpandedOp $ \expandedOp -> WithSrcEx <$> genInstrCallStack <*> pure expandedOp + ] + +genInstrCallStack :: MonadGen m => m InstrCallStack +genInstrCallStack = InstrCallStack <$> genLetCallStack <*> genSrcPos + where + genLetCallStack = Gen.frequency + [ (80, pure []) + , (18, Gen.list (Range.singleton 1) genLetName) + , (2, Gen.list (Range.singleton 2) genLetName) + ] + +genSrcPos :: MonadGen m => m SrcPos +genSrcPos = SrcPos <$> genPos <*> genPos + +genPos :: MonadGen m => m Pos +genPos = Pos <$> Gen.word Range.linearBounded + +genLetName :: MonadGen m => m LetName +genLetName = LetName <$> Gen.text (Range.linear 0 3) Gen.unicodeAll + +genExtInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (ExtInstrAbstract op) +genExtInstrAbstract genOp = Gen.choice + [ STACKTYPE <$> genStackTypePattern + , FN <$> genSmallText <*> genStackFn <*> genSmallList genOp + , UTEST_ASSERT <$> genTestAssert genOp + , UPRINT <$> genPrintComment + , UCOMMENT <$> genSmallText + ] + +genPrintComment :: MonadGen m => m PrintComment +genPrintComment = PrintComment <$> Gen.list (Range.linear 0 5) (genEither genSmallText genStackRef) + +genStackRef :: MonadGen m => m StackRef +genStackRef = StackRef <$> Gen.integral (Range.linear 0 (fromIntegral $ maxBound @Word64)) + +genTestAssert :: MonadGen m => m op -> m (TestAssert op) +genTestAssert genOp = TestAssert <$> genSmallText <*> genPrintComment <*> genSmallList genOp + +genStackFn :: (MonadGen m, GenBase m ~ Identity) => m StackFn +genStackFn = StackFn + <$> Gen.maybe (Gen.set smallCollectionRange genVar) + <*> genStackTypePattern + <*> genStackTypePattern + +genStackTypePattern :: (MonadGen m, GenBase m ~ Identity) => m StackTypePattern +genStackTypePattern = Gen.recursive Gen.choice + [ pure StkEmpty, pure StkRest ] + [ Gen.subtermM genStackTypePattern $ \stp -> StkCons <$> genTyVar <*> pure stp ] + +genInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (InstrAbstract op) +genInstrAbstract genOp = + Gen.choice $ instrAbstractWithOp genOp <> instrAbstractWithoutOp + +instrAbstractWithOp :: (MonadGen m, GenBase m ~ Identity) => m op -> [m (InstrAbstract op)] +instrAbstractWithOp genOp = + [ EXT <$> genExtInstrAbstract genOp + , PUSH <$> genAnnotation <*> genType <*> genValue' genOp + , IF_NONE <$> genSmallList genOp <*> genSmallList genOp + , IF_LEFT <$> genSmallList genOp <*> genSmallList genOp + , IF_CONS <$> genSmallList genOp <*> genSmallList genOp + , MAP <$> genAnnotation <*> genSmallList genOp + , ITER <$> genSmallList genOp + , IF <$> genSmallList genOp <*> genSmallList genOp + , LOOP <$> genSmallList genOp + , LOOP_LEFT <$> genSmallList genOp + , LAMBDA <$> genAnnotation <*> genType <*> genType <*> genSmallList genOp + , DIP <$> genSmallList genOp + , DIPN <$> Gen.word Range.linearBounded <*> genSmallList genOp + , CREATE_CONTRACT <$> genAnnotation <*> genAnnotation <*> genContract' genOp + ] + +instrAbstractWithoutOp :: (MonadGen m, GenBase m ~ Identity) => [m (InstrAbstract op)] +instrAbstractWithoutOp = + [ DROPN <$> Gen.word Range.linearBounded + , pure DROP + , DUP <$> genAnnotation + , pure SWAP + , DIG <$> Gen.word Range.linearBounded + , DUG <$> Gen.word Range.linearBounded + , SOME <$> genAnnotation <*> genAnnotation + , NONE <$> genAnnotation <*> genAnnotation <*> genType + , UNIT <$> genAnnotation <*> genAnnotation + , PAIR <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation + , CAR <$> genAnnotation <*> genAnnotation + , CDR <$> genAnnotation <*> genAnnotation + , LEFT <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genType + , RIGHT <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genType + , NIL <$> genAnnotation <*> genAnnotation <*> genType + , CONS <$> genAnnotation + , SIZE <$> genAnnotation + , EMPTY_SET <$> genAnnotation <*> genAnnotation <*> genType + , EMPTY_MAP <$> genAnnotation <*> genAnnotation <*> genType <*> genType + , EMPTY_BIG_MAP <$> genAnnotation <*> genAnnotation <*> genType <*> genType + , MEM <$> genAnnotation + , GET <$> genAnnotation + , UPDATE <$> genAnnotation + , EXEC <$> genAnnotation + , APPLY <$> genAnnotation + , pure FAILWITH + , CAST <$> genAnnotation <*> genType + , RENAME <$> genAnnotation + , PACK <$> genAnnotation + , UNPACK <$> genAnnotation <*> genAnnotation <*> genType + , CONCAT <$> genAnnotation + , SLICE <$> genAnnotation + , ISNAT <$> genAnnotation + , ADD <$> genAnnotation + , SUB <$> genAnnotation + , MUL <$> genAnnotation + , EDIV <$> genAnnotation + , ABS <$> genAnnotation + , NEG <$> genAnnotation + , LSL <$> genAnnotation + , LSR <$> genAnnotation + , OR <$> genAnnotation + , AND <$> genAnnotation + , XOR <$> genAnnotation + , NOT <$> genAnnotation + , COMPARE <$> genAnnotation + , EQ <$> genAnnotation + , NEQ <$> genAnnotation + , LT <$> genAnnotation + , GT <$> genAnnotation + , LE <$> genAnnotation + , GE <$> genAnnotation + , INT <$> genAnnotation + , SELF <$> genAnnotation <*> genAnnotation + , CONTRACT <$> genAnnotation <*> genAnnotation <*> genType + , TRANSFER_TOKENS <$> genAnnotation + , SET_DELEGATE <$> genAnnotation + , IMPLICIT_ACCOUNT <$> genAnnotation + , NOW <$> genAnnotation + , AMOUNT <$> genAnnotation + , BALANCE <$> genAnnotation + , CHECK_SIGNATURE <$> genAnnotation + , SHA256 <$> genAnnotation + , SHA512 <$> genAnnotation + , BLAKE2B <$> genAnnotation + , HASH_KEY <$> genAnnotation + , SOURCE <$> genAnnotation + , SENDER <$> genAnnotation + , ADDRESS <$> genAnnotation + , CHAIN_ID <$> genAnnotation + ] + +genContract :: (MonadGen m, GenBase m ~ Identity) => m Contract +genContract = genContract' genExpandedOp + +genContract' :: (MonadGen m, GenBase m ~ Identity) => m op -> m (Contract' op) +genContract' genOp = Contract <$> genParameterType <*> genType <*> genSmallList genOp + +genValue :: (MonadGen m, GenBase m ~ Identity) => m Value +genValue = genValue' genExpandedOp + +genValue' :: MonadGen m => m op -> m (Value' op) +genValue' genOp = Gen.recursive Gen.choice + -- non-recursive constructors + [ ValueInt <$> Gen.integral (Range.linearFrom 0 (fromIntegral $ minBound @Int64) (fromIntegral $ maxBound @Word64)) + , ValueString <$> genMText + , ValueBytes <$> genInternalByteString + , pure ValueUnit + , pure ValueTrue + , pure ValueFalse + , pure ValueNone + , pure ValueNil + ] + -- recursive constructors + [ Gen.subterm2 (genValue' genOp) (genValue' genOp) ValuePair + , Gen.subterm (genValue' genOp) ValueLeft + , Gen.subterm (genValue' genOp) ValueRight + , Gen.subterm (genValue' genOp) ValueSome + , ValueSeq <$> genSmallNonEmpty (genValue' genOp) + , ValueMap <$> genSmallNonEmpty (genElt genOp) + , ValueLambda <$> genSmallNonEmpty genOp + ] + +genElt :: MonadGen m => m op -> m (Elt op) +genElt genOp = Elt <$> genValue' genOp <*> genValue' genOp + +genParameterType :: (MonadGen m, GenBase m ~ Identity) => m ParameterType +genParameterType = ParameterType <$> genType <*> genAnnotation + + +genType :: (MonadGen m, GenBase m ~ Identity) => m Type +genType = Type <$> genT <*> genAnnotation + +genEpName :: (MonadGen m, GenBase m ~ Identity) => m EpName +genEpName = Gen.mapMaybe (rightToMaybe . epNameFromRefAnn) genAnnotation + +genAnnotation :: forall m a. (MonadGen m, GenBase m ~ Identity) => m (Annotation a) +genAnnotation = Gen.mapMaybe (rightToMaybe . mkAnnotation) genAnnotationText + where + genAnnotationText :: m Text + genAnnotationText = Gen.frequency + [ (1, pure "") + , (17, T.cons <$> annStart <*> Gen.text (Range.linear 0 100) annBodyChar) + , (1, pure specialFieldAnn) + , (1, Gen.element specialVarAnns) + ] + + annStart :: m Char + annStart = Gen.choice [ pure '_', Gen.alphaNum ] + + annBodyChar :: m Char + annBodyChar = Gen.choice [ annStart, Gen.element (".%@" :: String) ] + +genT :: (MonadGen m, GenBase m ~ Identity) => m T +genT = + Gen.recursive Gen.choice + -- non-recursive constructors + [ pure TKey + , pure TUnit + , pure TSignature + , pure TChainId + , pure TOperation + , pure TInt + , pure TNat + , pure TString + , pure TBytes + , pure TMutez + , pure TBool + , pure TKeyHash + , pure TTimestamp + , pure TAddress + ] + -- recursive constructors + [ TOption <$> genType + , TList <$> genType + , TSet <$> genType + , TContract <$> genType + , TPair <$> genAnnotation <*> genAnnotation <*> genType <*> genType + , TOr <$> genAnnotation <*> genAnnotation <*> genType <*> genType + , TLambda <$> genType <*> genType + , TMap <$> genType <*> genType + , TBigMap <$> genType <*> genType + ] + +smallCollectionRange :: Range Int +smallCollectionRange = Range.linear 0 3 + +genSmallList :: MonadGen m => m a -> m [a] +genSmallList = Gen.list smallCollectionRange + +genSmallNonEmpty :: MonadGen m => m a -> m (NonEmpty a) +genSmallNonEmpty = Gen.nonEmpty smallCollectionRange + +genSmallText :: MonadGen m => m Text +genSmallText = Gen.text (Range.linear 0 10) Gen.unicodeAll diff --git a/test/Test/EntryPoints.hs b/test/Test/EntryPoints.hs --- a/test/Test/EntryPoints.hs +++ b/test/Test/EntryPoints.hs @@ -16,23 +16,22 @@ import Data.Default (def) import Fmt (pretty) import Test.HUnit (assertBool, (@?=)) -import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) +import Michelson.Test.Util (runGen) import Michelson.Typed -import Michelson.Untyped (ann, noAnn) +import Michelson.Untyped (ann, noAnn, unsafeBuildEpName) import Tezos.Address -import Util.Test.Arbitrary -import Test.Util.QuickCheck +import Test.Util.Hedgehog test_EpAddress :: [TestTree] test_EpAddress = [ testGroup "Parsing" $ [ testCase "Simple entrypoint" $ parseEpAddress (formatAddress addr <> "%ab") - @?= Right (EpAddress addr (EpNameUnsafe "ab")) + @?= Right (EpAddress addr (unsafeBuildEpName "ab")) , testCase "No entrypoint" $ parseEpAddress (formatAddress addr) @@ -40,24 +39,24 @@ , testCase "Weird entrypoint" $ parseEpAddress (formatAddress addr <> "%a%b") - @?= Right (EpAddress addr (EpNameUnsafe "a%b")) + @?= Right (EpAddress addr (unsafeBuildEpName "a%b")) ] , testGroup "parse . format = pure" - [ roundtripTestSTB formatEpAddress parseEpAddress ] + [ roundtripTreeSTB genEpAddress formatEpAddress parseEpAddress ] ] where - addr = runGen 123 arbitrary + addr = runGen 20 123 genAddress test_ParamNotes :: [TestTree] test_ParamNotes = [ testGroup "Duplications are handled" $ [ testCase "One duplicated entrypoint" $ mkParamNotes (or "a" "a" prim prim) noAnn - @?= Left (ParamEpDuplicatedNames (EpNameUnsafe "a" :| [])) + @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [])) , testCase "Several duplicated entrypoint" $ mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn - @?= Left (ParamEpDuplicatedNames (EpNameUnsafe "a" :| [EpNameUnsafe "b"])) + @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [unsafeBuildEpName "b"])) , testCase "Duplicated default entrypoint" $ mkParamNotes (or "default" "default" prim prim) noAnn @?= Left (ParamEpDuplicatedNames (DefEpName :| [])) @@ -87,7 +86,7 @@ test_ParamEpError = [ testGroup "Buildable instance" [ testCase "Duplicated entrypoints error" $ - pretty @_ @Text (ParamEpDuplicatedNames $ EpNameUnsafe "a" :| [EpNameUnsafe ""]) + pretty @_ @Text (ParamEpDuplicatedNames $ unsafeBuildEpName "a" :| [DefEpName]) @?= "Duplicated entrypoint names: 'a', ''" , testCase "Uncallable arms error" $ pretty @_ @Text (ParamEpUncallableArm [AcLeft, AcRight]) diff --git a/test/Test/Ext.hs b/test/Test/Ext.hs --- a/test/Test/Ext.hs +++ b/test/Test/Ext.hs @@ -46,7 +46,7 @@ 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 _) = + 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'] interpret (T.cCode contract) epcPrimitive (T.VPair (x', y')) T.VUnit dummyContractEnv `shouldSatisfy` check diff --git a/test/Test/Integrational.hs b/test/Test/Integrational.hs --- a/test/Test/Integrational.hs +++ b/test/Test/Integrational.hs @@ -33,5 +33,4 @@ tTransfer (#from .! genesisAddress) (#to .! contractAddr) minBound DefEpName (toVal ()) - validate . Right $ - tExpectStorageConst contractAddr (toVal chainId) + tExpectStorageConst contractAddr (toVal chainId) diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs --- a/test/Test/Interpreter.hs +++ b/test/Test/Interpreter.hs @@ -24,18 +24,20 @@ ) where import Fmt (pretty) +import Hedgehog (MonadTest, annotate, assert, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.Hspec.Expectations (Expectation, shouldSatisfy) import Test.HUnit (assertFailure) -import Test.QuickCheck (Property, label, (.&&.), (===)) import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.Interpret (MichelsonFailed(..), interpret) import Michelson.Test (concatTestTrees, testTreesWithTypedContract) import Michelson.Test.Dummy (dummyContractEnv) import Michelson.Test.Unit -import Michelson.Test.Util (failedProp) +import Michelson.Test.Util (failedTest) import Michelson.Text import Michelson.Typed (IsoValue(..), T(..), epcPrimitive) import qualified Michelson.Typed as T @@ -100,9 +102,10 @@ test_basic1 :: IO [TestTree] test_basic1 = testTreesWithTypedContract (contractsDir "basic1.tz") $ \contract -> pure - [ testProperty "Random check" $ \input -> + [ testProperty "Random check" $ property $ do + input <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000)) contractProp @_ @[Integer] contract (validateBasic1 input) - dummyContractEnv () input + dummyContractEnv () input ] test_lsl :: IO [TestTree] @@ -164,16 +167,17 @@ test_add1_list = testTreesWithTypedContract (contractsDir "tezos_examples/attic/add1_list.tz") $ \contract -> let - doValidate :: - [Integer] -> ContractPropValidator (ToT [Integer]) Property + doValidate :: MonadTest m => + [Integer] -> ContractPropValidator (ToT [Integer]) (m ()) doValidate param (res, _) = case res of - Left failed -> failedProp $ + Left failed -> failedTest $ "add1_list unexpectedly failed: " <> pretty failed Right (fromVal . snd -> finalStorage) -> map succ param === finalStorage in pure - [ testProperty "Random check" $ \param -> + [ testProperty "Random check" $ property $ do + param <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000)) contractProp contract (doValidate param) dummyContractEnv param param ] @@ -319,9 +323,11 @@ ---------------------------------------------------------------------------- validateBasic1 - :: [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 + :: MonadTest m + => [Integer] -> ContractPropValidator ('TList 'TInt) (m ()) +validateBasic1 input (Right (ops, res), _) = do + fromVal res === [sum input + 12, 100] + + annotate "returned no ops" + assert $ null ops +validateBasic1 _ (Left e, _) = failedTest $ show e diff --git a/test/Test/Interpreter/Auction.hs b/test/Test/Interpreter/Auction.hs --- a/test/Test/Interpreter/Auction.hs +++ b/test/Test/Interpreter/Auction.hs @@ -9,24 +9,24 @@ ( test_Auction ) where +import Hedgehog (MonadTest, annotate, forAll, property, withTests, (===)) +import qualified Hedgehog.Gen as Gen import Test.Hspec.Expectations (shouldSatisfy) -import Test.QuickCheck (Property, arbitrary, choose, counterexample, (.&&.), (===)) -import Test.QuickCheck.Property (forAll, withMaxSuccess) import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.Interpret (ContractEnv(..)) import Michelson.Test (ContractPropValidator, contractProp, midTimestamp, testTreesWithTypedContract) import Michelson.Test.Dummy -import Michelson.Test.Util (failedProp) +import Michelson.Test.Gen (genMutez, genTimestamp) +import Michelson.Test.Util (eitherIsLeft, failedTest, runGen) 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) -import Tezos.Crypto (KeyHash) -import Util.Test.Arbitrary (runGen) +import Tezos.Crypto (KeyHash, genKeyHash) import Test.Util.Contracts @@ -36,7 +36,7 @@ -- | Spec to test auction.tz contract. -- -- This test serves as an example on how to test contract with both unit tests --- and QuickCheck. +-- and Hedgehog. test_Auction :: IO [TestTree] test_Auction = testTreesWithTypedContract (inContractsDir "tezos_examples/attic/auction.tz") auctionTest @@ -51,27 +51,32 @@ keyHash2 (aBitBeforeMidTimestamp, (unsafeMkMutez 1000, keyHash1)) - , testProperty "Random check (sparse distribution)" $ withMaxSuccess 200 $ - qcProp contract arbitrary arbitrary + , testProperty "Random check (sparse distribution)" $ withTests 200 $ + hhProp contract genTimestamp genMutez , testProperty "Random check (dense end of auction)" $ - qcProp contract denseTime arbitrary + hhProp contract denseTime genMutez , testProperty "Random check (dense amount)" $ - qcProp contract arbitrary denseAmount + hhProp contract genTimestamp denseAmount ] - qcProp contract eoaGen amountGen = - forAll ((,) <$> eoaGen <*> ((,) <$> amountGen <*> arbitrary)) $ - \s p -> - let validate = validateAuction env p s - in contractProp contract validate env p s + hhProp contract eoaGen amountGen = + property $ do + eoa <- forAll eoaGen + amount <- forAll amountGen + keyHash <- forAll genKeyHash + param <- forAll genKeyHash + let storage = (eoa, (amount, keyHash)) + let validate = validateAuction env param storage + contractProp contract validate env param storage + aBitBeforeMidTimestamp = midTimestamp `timestampPlusSeconds` -1 -- ^ 1s before NOW - denseTime = timestampPlusSeconds midTimestamp <$> choose (-4, 4) - denseAmount = unsafeMkMutez . (midAmount +) . fromInteger <$> choose (-4, 4) + denseTime = timestampPlusSeconds midTimestamp <$> Gen.enum -4 4 + denseAmount = unsafeMkMutez . (midAmount +) . fromInteger <$> Gen.enum -4 4 env = dummyContractEnv { ceNow = midTimestamp @@ -80,10 +85,10 @@ midAmount = unMutez (maxBound `unsafeSubMutez` minBound) `div` 2 keyHash1 :: KeyHash -keyHash1 = runGen 300406 arbitrary +keyHash1 = runGen 20 300406 genKeyHash keyHash2 :: KeyHash -keyHash2 = runGen 142917 arbitrary +keyHash2 = runGen 20 142917 genKeyHash -- | This validator checks the result of auction.tz execution. -- @@ -100,38 +105,38 @@ -- * Script returned exactly one operation, @TransferTokens@, which -- returns money back to the previous bidder validateAuction - :: ContractEnv + :: MonadTest m + => ContractEnv -> Param -> Storage - -> ContractPropValidator (ToT Storage) Property + -> ContractPropValidator (ToT Storage) (m ()) validateAuction env newKeyHash (endOfAuction, (amount, keyHash)) (resE, _) | ceNow env > endOfAuction - = counterexample "Failure didn't trigger on end of auction" $ isLeft resE + = annotate "Failure didn't trigger on end of auction" >> eitherIsLeft resE | ceAmount env <= amount - = counterexample ("Failure didn't trigger on attempt to bid" - <> " with amount <= than previous bid") $ isLeft resE + = annotate ("Failure didn't trigger on attempt to bid" + <> " with amount <= than previous bid") >> eitherIsLeft resE | Left e <- resE - = failedProp $ "Unexpected script fail: " <> show e + = failedTest $ "Unexpected script fail: " <> show e | Right (_, (T.VPair ( T.VTimestamp endOfAuction', _))) <- resE , endOfAuction /= endOfAuction' - = failedProp "End of auction timestamp of contract changed" + = failedTest "End of auction timestamp of contract changed" | Right (_, (T.VPair (_, T.VPair (T.VMutez amount', _)))) <- resE , amount' /= ceAmount env - = failedProp $ "Storage updated to wrong value: new amount" + = failedTest $ "Storage updated to wrong value: new amount" <> " is not equal to amount of transaction" | Right (_, (T.VPair (_, T.VPair (_, T.VKeyHash keyHash')))) <- resE , keyHash' /= newKeyHash - = failedProp $ "Storage updated to wrong value: new key hash" + = failedTest $ "Storage updated to wrong value: new key hash" <> " is not equal to contract's parameter" | Right (ops, _) <- resE - = let counterE msg = - counterexample $ "Invalid money back operation (" <> msg <> ")" + = let annotate' msg = + annotate $ "Invalid money back operation (" <> msg <> ")" in case ops of - [OpTransferTokens (TransferTokens T.VUnit retAmount (T.VContract retAddr _))] -> - counterE "wrong amount" (retAmount === amount) - .&&. - counterE "wrong address" (KeyAddress keyHash === retAddr) - _ -> failedProp $ "Unexpected operation list: " <> show ops + [OpTransferTokens (TransferTokens T.VUnit retAmount (T.VContract retAddr _))] -> do + annotate' "wrong amount" >> retAmount === amount + annotate' "wrong address" >> KeyAddress keyHash === retAddr + _ -> failedTest $ "Unexpected operation list: " <> show ops diff --git a/test/Test/Interpreter/Balance.hs b/test/Test/Interpreter/Balance.hs --- a/test/Test/Interpreter/Balance.hs +++ b/test/Test/Interpreter/Balance.hs @@ -7,11 +7,11 @@ , test_balanceIncludesAmountComplexCase ) where -import Test.QuickCheck (Arbitrary(..), choose, withMaxSuccess) -import Test.QuickCheck.Instances.Text () +import Hedgehog (Gen, forAll, property, withTests) +import qualified Hedgehog.Gen as Gen import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.Runtime.GState import Michelson.Test (testTreesWithUntypedContract) @@ -28,11 +28,11 @@ , fAmount :: Mutez } deriving stock (Show) -instance Arbitrary Fixture where - arbitrary = do - fStartingBalance <- unsafeMkMutez <$> choose (1000, 5000) - fAmount <- unsafeMkMutez <$> choose (0, 1000) - return Fixture{..} +genFixture :: Gen Fixture +genFixture = do + fStartingBalance <- unsafeMkMutez <$> Gen.enum 1000 5000 + fAmount <- unsafeMkMutez <$> Gen.enum 0 1000 + return Fixture{..} test_balanceIncludesAmount :: IO [TestTree] test_balanceIncludesAmount = do @@ -40,8 +40,9 @@ (inContractsDir "check_if_balance_includes_incoming_amount.tz") $ \checker -> pure - [ testProperty "BALANCE includes AMOUNT" $ withMaxSuccess 50 $ - integrationalTestProperty . scenario checker + [ testProperty "BALANCE includes AMOUNT" $ withTests 50 $ property $ do + fixture <- forAll genFixture + integrationalTestProp $ scenario checker fixture ] where scenario :: U.Contract -> Fixture -> IntegrationalScenario @@ -63,9 +64,7 @@ } transfer txData address - validate - $ Right - $ expectBalance address result + expectBalance address result test_balanceIncludesAmountComplexCase :: IO [TestTree] test_balanceIncludesAmountComplexCase = do @@ -103,8 +102,6 @@ -- A sends 30 to B, then B sends 5 back to A. A records call to BALANCE at each entry. -- We expect that 5 mutez sent back are included in the second call to BALANCE. - validate - $ Right - $ expectStorageConst addressA + expectStorageConst addressA $ untypeValue $ toVal [unsafeMkMutez 75, unsafeMkMutez 100] diff --git a/test/Test/Interpreter/CallSelf.hs b/test/Test/Interpreter/CallSelf.hs --- a/test/Test/Interpreter/CallSelf.hs +++ b/test/Test/Interpreter/CallSelf.hs @@ -8,11 +8,12 @@ ( test_self_caller ) where +import Hedgehog (Gen, forAll, property, withTests) +import qualified Hedgehog.Gen as Gen import Test.HUnit (Assertion, (@?=)) -import Test.QuickCheck (Gen, choose, forAll, withMaxSuccess) import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Michelson.Runtime.GState @@ -21,7 +22,6 @@ import Michelson.Test.Integrational import Michelson.Typed import qualified Michelson.Untyped as U -import Tezos.Address (Address) import Tezos.Core (unsafeMkMutez) import Test.Util.Contracts @@ -49,7 +49,7 @@ genFixture :: Gen Fixture genFixture = - Fixture <$> (RemainingSteps <$> choose (minGas, maxGas)) <*> choose (minCalls, maxCalls) + Fixture <$> (RemainingSteps <$> Gen.enum minGas maxGas) <*> Gen.enum minCalls maxCalls where minCalls = 1 maxCalls = 10 @@ -74,9 +74,9 @@ (2 :: Integer) (0 :: Natural) , testProperty propertyDescription $ - withMaxSuccess 10 $ - forAll genFixture $ \fixture -> - integrationalTestProperty (integrationalScenario uSelfCaller fixture) + withTests 10 $ property $ do + fixture <- forAll genFixture + integrationalTestProp (integrationalScenario uSelfCaller fixture) ] where -- Environment for unit test @@ -88,9 +88,7 @@ remSteps @?= ceMaxSteps unitContractEnv - gasDiff propertyDescription = - "calls itself as many times as you pass to it as a parameter, " <> - "it fails due to gas limit if the number is large, otherwise the " <> - "storage is updated to the number of calls" + "calls itself n times, sets storage to n OR fails due to gas limit" integrationalScenario :: U.Contract -> Fixture -> IntegrationalScenario integrationalScenario uSelfCaller fixture = do @@ -104,13 +102,10 @@ , tdEntrypoint = DefEpName , tdAmount = minBound } - transfer txData address - validate (validator address) - where - validator :: Address -> IntegrationalValidator - validator address - | fExpectSuccess fixture = - let expectedStorage = - U.ValueInt (fromIntegral $ fParameter fixture) - in Right $ expectStorageUpdateConst address expectedStorage - | otherwise = Left expectGasExhaustion + if fExpectSuccess fixture + then do + transfer txData address + let expectedStorage = U.ValueInt (fromIntegral $ fParameter fixture) + expectStorageUpdateConst address expectedStorage + else + transfer txData address `catchExpectedError` expectGasExhaustion diff --git a/test/Test/Interpreter/ComparableSet.hs b/test/Test/Interpreter/ComparableSet.hs --- a/test/Test/Interpreter/ComparableSet.hs +++ b/test/Test/Interpreter/ComparableSet.hs @@ -8,15 +8,16 @@ ) where import Data.Set as Set (fromList, toList) -import Test.QuickCheck (Property, (===)) -import Test.QuickCheck.Property (withMaxSuccess) +import Hedgehog (MonadTest, forAll, property, withTests, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.Hedgehog (testProperty) import Michelson.Interpret (InterpreterState, MichelsonFailed) import Michelson.Test (contractProp, testTreesWithTypedContract) import Michelson.Test.Dummy -import Michelson.Test.Util (failedProp) +import Michelson.Test.Util (failedTest, genTuple2) import Michelson.Typed (ToT, fromVal) import qualified Michelson.Typed as T @@ -38,11 +39,14 @@ contractProp contract (validate (mkExpected inputParam)) dummyContractEnv inputParam initStorage in pure - [ testProperty "success test" $ + [ testProperty "success test" $ property $ contractProp' (fromList [ (10, 11) , (10, 12)]) - , testProperty "Random check" $ - withMaxSuccess 200 contractProp' + , testProperty "Random check" $ + withTests 200 $ property $ do + let genInteger = Gen.integral (Range.linearFrom 0 -1000 1000) + inputParam <- forAll $ Gen.set (Range.linear 0 100) (genTuple2 genInteger genInteger) + contractProp' inputParam ] where initStorage :: HContractStorage @@ -54,9 +58,10 @@ _ -> Just $ maximum x validate - :: HContractStorage + :: MonadTest m + => HContractStorage -> ContractResult x - -> Property + -> m () validate e (Right ([], fromVal -> l), _) = l === e - validate _ (Left _, _) = failedProp "Unexpected fail of script." - validate _ _ = failedProp "Invalid result got." + validate _ (Left _, _) = failedTest "Unexpected fail of script." + validate _ _ = failedTest "Invalid result got." diff --git a/test/Test/Interpreter/Compare.hs b/test/Test/Interpreter/Compare.hs --- a/test/Test/Interpreter/Compare.hs +++ b/test/Test/Interpreter/Compare.hs @@ -7,15 +7,15 @@ ( test_compare ) where -import Test.QuickCheck (Property, (===)) -import Test.QuickCheck.Property (withMaxSuccess) +import Hedgehog (MonadTest, forAll, property, withTests, (===)) import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.Hedgehog (testProperty) import Michelson.Interpret (InterpreterState, MichelsonFailed) import Michelson.Test (contractProp, testTreesWithTypedContract) import Michelson.Test.Dummy -import Michelson.Test.Util (failedProp) +import Michelson.Test.Gen (genMutez) +import Michelson.Test.Util (failedTest, genTuple2) import Michelson.Typed (ToT, fromVal) import qualified Michelson.Typed as T import Tezos.Core (Mutez, unsafeMkMutez) @@ -37,10 +37,12 @@ contractProp contract (validate (mkExpected inputParam)) dummyContractEnv inputParam initStorage in pure - [ testProperty "success test" $ + [ testProperty "success test" $ property $ contractProp' (unsafeMkMutez 10, unsafeMkMutez 11) , testProperty "Random check" $ - withMaxSuccess 200 contractProp' + withTests 200 $ property $ do + inputParam <- forAll $ genTuple2 genMutez genMutez + contractProp' inputParam ] where initStorage :: [Bool] @@ -50,9 +52,10 @@ mkExpected (a, b) = [a == b, a > b, a < b, a >= b, a <= b] validate - :: [Bool] + :: MonadTest m + => [Bool] -> ContractResult x - -> Property + -> m () validate e (Right ([], fromVal -> l), _) = l === e - validate _ (Left _, _) = failedProp "Unexpected fail of sctipt." - validate _ _ = failedProp "Invalid result got." + validate _ (Left _, _) = failedTest "Unexpected fail of sctipt." + validate _ _ = failedTest "Invalid result got." diff --git a/test/Test/Interpreter/ComparePairs.hs b/test/Test/Interpreter/ComparePairs.hs --- a/test/Test/Interpreter/ComparePairs.hs +++ b/test/Test/Interpreter/ComparePairs.hs @@ -7,15 +7,15 @@ ( test_compare_pairs ) where -import Test.QuickCheck (Property, (===)) -import Test.QuickCheck.Property (withMaxSuccess) +import Hedgehog (MonadTest, forAll, property, withTests, (===)) import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.Hedgehog (testProperty) import Michelson.Interpret (InterpreterState, MichelsonFailed) import Michelson.Test (contractProp, testTreesWithTypedContract) import Michelson.Test.Dummy -import Michelson.Test.Util (failedProp) +import Michelson.Test.Gen (genMutez) +import Michelson.Test.Util (failedTest, genTuple2) import Michelson.Typed (ToT, fromVal) import qualified Michelson.Typed as T import Tezos.Core (Mutez, unsafeMkMutez) @@ -35,14 +35,17 @@ let contractProp' inputParam = contractProp contract (validate (mkExpected inputParam)) - dummyContractEnv inputParam initStorage + dummyContractEnv inputParam initStorage in pure - [ testProperty "success test" $ + [ testProperty "success test" $ property $ contractProp' ( (unsafeMkMutez 10, unsafeMkMutez 11) , (unsafeMkMutez 10, unsafeMkMutez 12) - ) , testProperty "Random check" $ - withMaxSuccess 200 contractProp' + ) + , testProperty "Random check" $ + withTests 200 $ property $ do + inputParam <- forAll $ genTuple2 (genTuple2 genMutez genMutez) (genTuple2 genMutez genMutez) + contractProp' inputParam ] where initStorage :: [Bool] @@ -52,9 +55,10 @@ mkExpected (a, b) = [a == b, a > b, a < b, a >= b, a <= b] validate - :: [Bool] + :: MonadTest m + => [Bool] -> ContractResult x - -> Property + -> m () validate e (Right ([], fromVal -> l), _) = l === e - validate _ (Left _, _) = failedProp "Unexpected fail of sctipt." - validate _ _ = failedProp "Invalid result got." + validate _ (Left _, _) = failedTest "Unexpected fail of sctipt." + validate _ _ = failedTest "Invalid result got." diff --git a/test/Test/Interpreter/Conditionals.hs b/test/Test/Interpreter/Conditionals.hs --- a/test/Test/Interpreter/Conditionals.hs +++ b/test/Test/Interpreter/Conditionals.hs @@ -7,16 +7,16 @@ ( test_conditionals ) where -import Test.QuickCheck (Property, (===)) -import Test.QuickCheck.Instances.Text () -import Test.QuickCheck.Property (withMaxSuccess) +import Hedgehog (MonadTest, forAll, property, withTests, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.Hedgehog (testProperty) import Michelson.Interpret (InterpreterState, MichelsonFailed) import Michelson.Test (contractProp, testTreesWithTypedContract) import Michelson.Test.Dummy (dummyContractEnv) -import Michelson.Test.Util (failedProp, qcIsLeft, qcIsRight) +import Michelson.Test.Util (eitherIsLeft, eitherIsRight, failedTest, genEither) import Michelson.Text import qualified Michelson.Typed as T @@ -33,24 +33,30 @@ test_conditionals = testTreesWithTypedContract (inContractsDir "tezos_examples/attic/conditionals.tz") $ \contract -> let + contractProp' :: MonadTest m => Param -> m () contractProp' inputParam = contractProp contract (validate inputParam) dummyContractEnv inputParam - [mt|storage|] + [mt|storage|] in pure [ testProperty "success 1 test" $ - contractProp' $ Left [mt|abc|] + property $ contractProp' $ Left [mt|abc|] , testProperty "Random check" $ - withMaxSuccess 200 contractProp' + withTests 200 $ property $ do + inputParam <- forAll $ genEither + genMText + (Gen.maybe (Gen.integral (Range.linearFrom 0 -1000 1000))) + contractProp' inputParam ] where validate - :: Show x + :: MonadTest m + => Show x => Param -> ContractResult x - -> Property + -> m () validate (Left a) (Right ([], T.VString b), _) = a === b - validate (Right Nothing) r = qcIsLeft $ fst r + validate (Right Nothing) r = eitherIsLeft $ fst r validate (Right (Just a)) r - | a < 0 = qcIsLeft $ fst r - | otherwise = qcIsRight $ fst r - validate _ res = failedProp $ "Unexpected result: " <> show res + | a < 0 = eitherIsLeft $ fst r + | otherwise = eitherIsRight $ fst r + validate _ res = failedTest $ "Unexpected result: " <> show res diff --git a/test/Test/Interpreter/ContractOp.hs b/test/Test/Interpreter/ContractOp.hs --- a/test/Test/Interpreter/ContractOp.hs +++ b/test/Test/Interpreter/ContractOp.hs @@ -9,12 +9,12 @@ import qualified Data.Map as M import Fmt (pretty) -import Test.QuickCheck (Property, (===)) +import Hedgehog (MonadTest, property, (===)) import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.Hedgehog (testProperty) import Michelson.Interpret (ContractEnv(..), ContractReturn) -import Michelson.Test (contractProp, dummyContractEnv, failedProp, testTreesWithTypedContract) +import Michelson.Test (contractProp, dummyContractEnv, failedTest, testTreesWithTypedContract) import Michelson.Typed (Contract, ToT, fromVal) import Michelson.Untyped (ParameterType(..), T(..), Type(..), noAnn) import Tezos.Address @@ -27,11 +27,11 @@ test_contract_op :: IO [TestTree] test_contract_op = testTreesWithTypedContract (inContractsDir "contract_op.tz") $ \contract -> pure $ - [ testProperty "contract not found" $ + [ testProperty "contract not found" $ property $ contractProp' False [] contract ] <> map (\(res, paramType) -> - testProperty (msg res paramType) $ + testProperty (msg res paramType) $ property $ contractProp' res [(addr, paramType)] contract ) [ (True, ParameterType intQ "root") @@ -56,16 +56,18 @@ addr = unsafeParseContractHash "KT1WsLzQ61xtMNJHfwgCHh2RnALGgFAzeSx9" validate - :: Bool + :: MonadTest m + => Bool -> ContractReturn (ToT Bool) - -> Property + -> m () validate ex (Right ([], fromVal -> l), _) = l === ex - validate _ (Left _, _) = failedProp "Unexpected fail in interepreter" - validate _ _ = failedProp "Unexpected result of script execution" + validate _ (Left _, _) = failedTest "Unexpected fail in interepreter" + validate _ _ = failedTest "Unexpected result of script execution" contractProp' - :: Bool -> [(ContractHash, ParameterType)] -> Contract (ToT Address) (ToT Bool) - -> Property + :: MonadTest m + => Bool -> [(ContractHash, ParameterType)] -> Contract (ToT Address) (ToT Bool) + -> m () contractProp' res ctrs contract = contractProp contract diff --git a/test/Test/Interpreter/EnvironmentSpec.hs b/test/Test/Interpreter/EnvironmentSpec.hs --- a/test/Test/Interpreter/EnvironmentSpec.hs +++ b/test/Test/Interpreter/EnvironmentSpec.hs @@ -8,11 +8,11 @@ ( test_environment ) where -import Test.QuickCheck (Arbitrary(..), choose, withMaxSuccess) -import Test.QuickCheck.Instances.Text () +import Hedgehog (Gen, forAll, property, withTests) +import qualified Hedgehog.Gen as Gen import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.Interpret (RemainingSteps(..)) import Michelson.Runtime.GState @@ -44,14 +44,14 @@ , fAmount :: Mutez } deriving stock (Show) -instance Arbitrary Fixture where - arbitrary = do - fNow <- timestampFromSeconds <$> choose (100000, 111111) - fMaxSteps <- RemainingSteps <$> choose (1015, 1028) - fPassOriginatedAddress <- arbitrary - fBalance <- unsafeMkMutez <$> choose (1, 1234) - fAmount <- unsafeMkMutez <$> choose (1, 42) - return Fixture {..} +genFixture :: Gen Fixture +genFixture = do + fNow <- timestampFromSeconds <$> Gen.enum 100000 111111 + fMaxSteps <- RemainingSteps <$> Gen.enum 1015 1028 + fPassOriginatedAddress <- Gen.bool + fBalance <- unsafeMkMutez <$> Gen.enum 1 1234 + fAmount <- unsafeMkMutez <$> Gen.enum 1 42 + return Fixture {..} shouldExpectFailed :: Fixture -> Bool shouldExpectFailed fixture = @@ -67,14 +67,16 @@ -> TestTree testImpl (uEnvironment, _environment) = do testProperty description $ - withMaxSuccess 50 $ - integrationalTestProperty . scenario + withTests 50 $ property $ do + fixture <- forAll genFixture + integrationalTestProp (scenario fixture) where + scenario :: Fixture -> IntegrationalScenario scenario = integrationalScenario uEnvironment description = - "This contract fails under conditions described in a comment at the " <> - "beginning of this contract and returns whether remaining gas is " <> - "greater than 1000" + -- The conditions under which this contract fails are described in a comment + -- at the beginning of the contract. + "contract fails under certain conditions and returns whether remaining gas > 1000" integrationalScenario :: U.Contract -> Fixture -> IntegrationalScenario integrationalScenario contract fixture = do @@ -97,18 +99,14 @@ , tdEntrypoint = DefEpName , tdAmount = fAmount fixture } - transfer txData environmentAddress + transferToEnvironment = transfer txData environmentAddress -- Execute operations and check that interpreter fails when one of -- failure conditions is met or updates environment's storage -- approriately - let - validator - | shouldExpectFailed fixture = - Left $ expectMichelsonFailed (const True) environmentAddress - | otherwise = - Right $ expectAnySuccess - validate validator + if shouldExpectFailed fixture + then transferToEnvironment `catchExpectedError` expectMichelsonFailed (const True) environmentAddress + else transferToEnvironment testDefaultBalance :: IntegrationalScenario testDefaultBalance = do @@ -121,4 +119,4 @@ , tdAmount = unsafeMkMutez 1 } transfer txData addr - validate . Right $ expectBalance addr (unsafeMkMutez 1) + expectBalance addr (unsafeMkMutez 1) diff --git a/test/Test/Interpreter/StringCaller.hs b/test/Test/Interpreter/StringCaller.hs --- a/test/Test/Interpreter/StringCaller.hs +++ b/test/Test/Interpreter/StringCaller.hs @@ -10,11 +10,10 @@ ( test_stringCaller ) where -import Test.QuickCheck (withMaxSuccess) -import Test.QuickCheck.Instances.Text () -import Test.Tasty (TestTree) +import Hedgehog (forAll, property, withTests) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.Runtime.GState import Michelson.Test (testTreesWithContract) @@ -33,27 +32,26 @@ testTreesWithContract (inContractsDir "string_caller.tz") $ \stringCaller -> testTreesWithContract (inContractsDir "fail_or_store_and_transfer.tz") $ \failOrStoreAndTransfer -> - pure $ testImpl stringCaller failOrStoreAndTransfer + pure $ [testImpl stringCaller failOrStoreAndTransfer] testImpl :: (U.Contract, T.Contract 'TString 'TAddress) -> (U.Contract, T.Contract 'TString 'TString) - -> [TestTree] + -> TestTree testImpl (uStringCaller, _stringCaller) (uFailOrStore, _failOrStoreAndTransfer) = let scenario = integrationalScenario uStringCaller uFailOrStore - prefix = - "stringCaller calls failOrStoreAndTransfer and updates its storage with " - suffix = - " and properly updates balances. But fails if failOrStoreAndTransfer's" - <> " balance is ≥ 1300 and NOW is ≥ 500" in - [ testCase (prefix <> "a constant" <> suffix) $ - integrationalTestExpectation (scenario constStr) - -- The test is trivial, so it's kinda useless to run it many times - , testProperty (prefix <> "an arbitrary value" <> suffix) $ - withMaxSuccess 2 $ - \str -> integrationalTestProperty (scenario str) - ] + -- failOrStoreAndTransfer's pre-conditions: + -- balance is >= 1300 and NOW >= 500 + testGroup "calls failOrStoreAndTransfer, updates storage & balance, checks pre-conditions" + [ testCase "when parameter is a constant" $ + integrationalTestExpectation (scenario constStr) + -- The test is trivial, so it's kinda useless to run it many times + , testProperty "when parameter is an arbitrary value" $ + withTests 2 $ property $ do + mtext <- forAll genMText + integrationalTestProp (scenario mtext) + ] where constStr = [mt|caller|] @@ -97,21 +95,16 @@ expectedFailOrStoreBalance = unsafeMkMutez (900 + 300 - 5) expectedConstAddrBalance = unsafeMkMutez 5 - updatesValidator :: SuccessValidator - updatesValidator = composeValidatorsList - [ expectStorageUpdateConst failOrStoreAndTransferAddress newValue - , expectBalance failOrStoreAndTransferAddress expectedFailOrStoreBalance - , expectBalance stringCallerAddress expectedStringCallerBalance - , expectBalance constAddr expectedConstAddrBalance - ] - validate (Right updatesValidator) + expectStorageUpdateConst failOrStoreAndTransferAddress newValue + expectBalance failOrStoreAndTransferAddress expectedFailOrStoreBalance + expectBalance stringCallerAddress expectedStringCallerBalance + expectBalance constAddr expectedConstAddrBalance -- Now let's transfer 100 tokens to stringCaller again. - transferToStringCaller - -- This time execution should fail, because failOrStoreAndTransfer should fail -- because its balance is greater than 1300. - void $ validate (Left $ expectMichelsonFailed (const True) failOrStoreAndTransferAddress) + transferToStringCaller `catchExpectedError` + expectMichelsonFailed (const True) failOrStoreAndTransferAddress -- We can also send tokens from failOrStoreAndTransfer to tz1 address directly let @@ -130,25 +123,17 @@ expectedFailOrStoreBalance = unsafeMkMutez (900 + 300 - 5 - 200) expectedConstAddrBalance = unsafeMkMutez (5 + 200) - updatesValidator :: SuccessValidator - updatesValidator = composeValidatorsList - [ expectBalance failOrStoreAndTransferAddress expectedFailOrStoreBalance - , expectBalance constAddr expectedConstAddrBalance - ] - - void $ validate (Right updatesValidator) + expectBalance failOrStoreAndTransferAddress expectedFailOrStoreBalance + expectBalance constAddr expectedConstAddrBalance -- Now we can transfer to stringCaller again and it should succeed -- this time, because the balance of failOrStoreAndTransfer decreased transferToStringCaller - -- Let's simply assert that it should succeed to keep the scenario shorter - void $ validate (Right expectAnySuccess) - -- Now let's set NOW to 600 and expect stringCaller to fail setNow (timestampFromSeconds 600) - transferToStringCaller - validate (Left $ expectMichelsonFailed (const True) stringCallerAddress) + transferToStringCaller `catchExpectedError` + expectMichelsonFailed (const True) stringCallerAddress -- Address hardcoded in 'failOrStoreAndTransfer.tz'. constAddr :: Address diff --git a/test/Test/Michelson/Runtime.hs b/test/Test/Michelson/Runtime.hs --- a/test/Test/Michelson/Runtime.hs +++ b/test/Test/Michelson/Runtime.hs @@ -9,10 +9,10 @@ ) where import Control.Lens (at) -import Fmt (pretty) +import Fmt (pretty, (+|), (|+)) import System.FilePath (()) import Test.Hspec.Expectations (Expectation, expectationFailure, shouldSatisfy) -import Test.HUnit (Assertion, assertFailure, (@?=)) +import Test.HUnit (Assertion, assertFailure, (@?), (@?=)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) @@ -22,8 +22,8 @@ import Michelson.Runtime.GState (GState(..), genesisAddress, initGState) import Michelson.Test.Dummy (dummyContractEnv, dummyMaxSteps, dummyNow, dummyOrigination) import Michelson.Test.Integrational - (IntegrationalScenario, expectAnySuccess, integrationalTestExpectation, originate, transfer, - validate) + (IntegrationalScenario, TestError(CustomTestError), catchExpectedError, integrationalFail, + integrationalTestExpectation, originate, transfer, unexpectedInterpreterError) import Michelson.Text (mt) import Michelson.Typed (untypeValue) import Michelson.Untyped @@ -41,7 +41,8 @@ [ testCase "contract1" $ updatesStorageValue contractAux1 , testCase "contract2" $ updatesStorageValue contractAux2 ] - , testCase "Fails to originate an already originated contract" failsToOriginateTwice + , testCase "Succeeds to originate the same contract twice, with different addresses" + succeedsToOriginateTwice , testCase "Fails to originate an ill-typed contract" (failsToOriginateIllTyped (ValueString [mt||]) illTypedContract) , testCase "Fails transfering 0tz to plain account" @@ -70,24 +71,24 @@ let ce = caEnv ca origination = contractAuxToOrigination ca - addr = mkContractAddress origination txData = TxData { tdSenderAddress = ceSender ce , tdParameter = caParameter ca , tdEntrypoint = DefEpName , tdAmount = unsafeMkMutez 100 } - interpreterOps = - [ OriginateOp origination - , TransferOp addr txData - ] - (addr,) <$> executorPure dummyNow dummyMaxSteps initGState interpreterOps + + runExecutorM dummyNow dummyMaxSteps initGState $ do + addr <- withGlobalOperation (OriginateOp origination) + $ executeOrigination origination + executeGlobalOperations [TransferOp addr txData] + return addr where toNewStorage :: InterpretResult -> Value toNewStorage InterpretResult {..} = untypeValue iurNewStorage - handleResult :: (Address, ExecutorRes) -> Assertion - handleResult (addr, ir) = do + handleResult :: (ExecutorRes, Address) -> Assertion + handleResult (ir, addr) = do expectedValue <- either (assertFailure . pretty) (pure . toNewStorage) $ interpretUntyped @@ -97,16 +98,22 @@ Just (ASContract cs) -> csStorage cs @?= expectedValue Just _ -> expectationFailure $ "Address has unexpected state " <> pretty addr -failsToOriginateTwice :: Expectation -failsToOriginateTwice = - simpleTest ops isAlreadyOriginated +succeedsToOriginateTwice :: Expectation +succeedsToOriginateTwice = either (assertFailure . pretty) handleResult $ do + runExecutorM dummyNow dummyMaxSteps initGState $ do + addr1 <- withGlobalOperation (OriginateOp origination) + $ executeOrigination origination + addr2 <- withGlobalOperation (OriginateOp origination) + $ executeOrigination origination + return (addr1, addr2) where contract = caContract contractAux1 origination = dummyOrigination (caStorage contractAux1) contract - ops = [OriginateOp origination, OriginateOp origination] - isAlreadyOriginated (Left (EEAlreadyOriginated {})) = True - isAlreadyOriginated _ = False + handleResult :: (ExecutorRes, (Address, Address)) -> Assertion + handleResult (_, (addr1, addr2)) = + addr1 /= addr2 @? "Two originated addresses are not different" + failsToOriginateIllTyped :: Value -> Contract -> Expectation failsToOriginateIllTyped initialStorage illTypedContract = simpleTest ops isIllTypedContract @@ -116,13 +123,14 @@ isIllTypedContract (Left (EEIllTypedContract {})) = True isIllTypedContract _ = False -simpleTest :: - [ExecutorOp] +simpleTest + :: HasCallStack + => [ExecutorOp] -> (Either ExecutorError ExecutorRes -> Bool) -> Expectation simpleTest ops predicate = - executorPure dummyNow dummyMaxSteps initGState ops `shouldSatisfy` - predicate + fst <$> runExecutorM dummyNow dummyMaxSteps initGState (executeGlobalOperations ops) + `shouldSatisfy` predicate testZeroTransactionFails :: IntegrationalScenario testZeroTransactionFails = do @@ -132,12 +140,15 @@ , tdParameter = ValueNil , tdEntrypoint = DefEpName , tdAmount = unsafeMkMutez 0 } - validator = - \case EEZeroTransaction addr -> addr == genesisAddress - _ -> False - transfer txData genesisAddress - validate $ Left validator + transfer txData genesisAddress `catchExpectedError` + \case + EEZeroTransaction addr + | addr == genesisAddress -> pass + | otherwise -> integrationalFail $ CustomTestError $ + "Expected " +| genesisAddress |+ ", but got " +| addr |+ "" + err -> unexpectedInterpreterError err "expected attempt to send 0tz" + testZeroTransactionSuccess :: IntegrationalScenario testZeroTransactionSuccess = do let @@ -151,18 +162,19 @@ , tdAmount = unsafeMkMutez 0 } address <- originate contract "test0tzContract" storage balance transfer txData address - validate $ Right expectAnySuccess transferFromUnknown :: Assertion -transferFromUnknown = - whenLeft (executorPure dummyNow dummyMaxSteps initGState interpreterOps) $ - assertFailure . pretty +transferFromUnknown = do + let + res = runExecutorM dummyNow dummyMaxSteps initGState $ do + addr <- withGlobalOperation (OriginateOp origination) + $ executeOrigination origination + executeGlobalOperations [TransferOp addr txData] + + whenLeft res $ + assertFailure . pretty where ca = contractAux1 - interpreterOps = - [ OriginateOp origination - , TransferOp (mkContractAddress origination) txData - ] origination = contractAuxToOrigination ca txData = TxData @@ -189,8 +201,8 @@ where contract :: Contract contract = Contract - { contractParameter = ParameterType (Type tstring noAnn) noAnn - , contractStorage = Type tbool noAnn + { 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) diff --git a/test/Test/Michelson/Text.hs b/test/Test/Michelson/Text.hs --- a/test/Test/Michelson/Text.hs +++ b/test/Test/Michelson/Text.hs @@ -21,7 +21,7 @@ import qualified Michelson.Untyped as U import Michelson.Text -import Test.Util.QuickCheck (roundtripTest) +import Test.Util.Hedgehog (roundtripTree) -- | Parse string literal content to 'MText'. parseMTextTest :: Text -> Either () MText @@ -36,7 +36,7 @@ -- | 'MText' rountrip conversions. test_Roundtrip :: [TestTree] test_Roundtrip = - [ roundtripTest writeMText parseMTextTest ] + [ roundtripTree genMText writeMText parseMTextTest ] -- | Check value against the given predicate. (@??) :: (Show a, HasCallStack) => a -> (a -> Bool) -> Assertion diff --git a/test/Test/Michelson/Typed/Util.hs b/test/Test/Michelson/Typed/Util.hs --- a/test/Test/Michelson/Typed/Util.hs +++ b/test/Test/Michelson/Typed/Util.hs @@ -6,12 +6,13 @@ module Test.Michelson.Typed.Util ( unit_linearizeLeft_sample - , prop_linearizeLeft_performance + , hprop_linearizeLeft_performance ) where +import Hedgehog (Property) import Test.HUnit (Assertion, (@?)) -import Test.QuickCheck (Property, total, within) +import Michelson.Test (meanTimeUpperBoundPropNF, sec) import Michelson.Typed unit_linearizeLeft_sample :: Assertion @@ -29,10 +30,6 @@ go 0 = SWAP go n = Seq SWAP (go (n - 1)) -prop_linearizeLeft_performance :: Property -prop_linearizeLeft_performance = - -- Without existing optimization it would take much more time. - within (10 * 1000 * 1000) $ -- at most 10 sec - total $ show @Text $ linearizeLeft instr - where - instr = rightLinear 300000 +hprop_linearizeLeft_performance :: Property +hprop_linearizeLeft_performance = + meanTimeUpperBoundPropNF (sec 10) (linearizeLeft . rightLinear) 300000 diff --git a/test/Test/Michelson/Typed/Value.hs b/test/Test/Michelson/Typed/Value.hs new file mode 100644 --- /dev/null +++ b/test/Test/Michelson/Typed/Value.hs @@ -0,0 +1,35 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +-- | Tests on 'Value'. +module Test.Michelson.Typed.Value + ( test_eqValueExt + ) where + +import Test.HUnit (assertBool) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase) + +import Michelson.Text +import Michelson.Typed.Haskell.Value +import Michelson.Typed.Value + +test_eqValueExt :: [TestTree] +test_eqValueExt = + [ testCase "Simple" $ + assertBool "Occured to be not reflexive" $ + toVal @Integer 5 `eqValueExt` toVal @Integer 5 + + , testCase "Complex" $ + assertBool "Occured to be not reflexive" $ + toVal ([mt|a|], 5 :: Integer) + `eqValueExt` + toVal ([mt|a|], 5 :: Integer) + + , testCase "Types do not matter if content is the same" $ + -- Not sure this property is desired, leaving a test just for + -- illustration purposes + assertBool "Unexpectedly equal" . not $ + toVal ([] @Integer) `eqValueExt` toVal ([] @MText) + ] diff --git a/test/Test/Morley/Expression.hs b/test/Test/Morley/Expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Morley/Expression.hs @@ -0,0 +1,167 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +-- | Tests for 'Morley.Micheline.Expression'. + +module Test.Morley.Expression + ( test_Roundtrip_binary + , test_Roundtrip_expression + , test_Roundtrip_JSON + , test_toExpression + ) where + +import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) +import qualified Data.Sequence as Seq +import Hedgehog (Gen) +import Test.Tasty (TestTree) + +import Michelson.Test.Gen +import qualified Michelson.Typed as T +import qualified Michelson.Untyped as U +import qualified Morley.Micheline as M +import Test.Util.Hedgehog (roundtripTree) +import Tezos.Core (Mutez) + +import Test.Hspec.Expectations (shouldBe) +import Test.Tasty.HUnit (testCase) + +testJSON + :: forall a. (Eq a, Show a, ToJSON a, FromJSON a, Typeable a) + => Gen a -> TestTree +testJSON genA = roundtripTree @a genA encode eitherDecode + +testValue + :: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a) + => Gen a -> TestTree +testValue genA = roundtripTree @a genA M.toExpression (maybeToRight () . M.fromExpression) + +testValueJSON + :: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a) + => Gen a -> TestTree +testValueJSON genA = roundtripTree @a genA + (encode . M.toExpression) + (maybeToRight "error" . M.fromExpression <=< eitherDecode) + +testBinary :: Gen M.Expression -> TestTree +testBinary genA = roundtripTree genA M.encodeExpression M.eitherDecodeExpression + +test_Roundtrip_JSON :: [TestTree] +test_Roundtrip_JSON = + [ testJSON M.genExprAnnotation + , testJSON M.genExpression + , testJSON M.genMichelinePrimAp + , testValueJSON @(T.Value $ T.ToT Integer) genValueInt + , testValueJSON @(T.Value $ T.ToT Mutez) genValueMutez + , testValueJSON @(T.Value $ T.ToT ()) genValueUnit + ] + +test_Roundtrip_binary :: [TestTree] +test_Roundtrip_binary = + [ testBinary M.genExpression + ] + +test_Roundtrip_expression :: [TestTree] +test_Roundtrip_expression = + [ testValue @(T.Value $ T.ToT Integer) genValueInt + , testValue @(T.Value $ T.ToT Mutez) genValueMutez + , testValue @(T.Value $ T.ToT ()) genValueUnit + ] + +test_toExpression :: [TestTree] +test_toExpression = + [ testCase "Converting TInt to Expression" $ + M.toExpression T.TInt `shouldBe` + M.ExpressionPrim (M.MichelinePrimAp (M.MichelinePrimitive "int") mempty mempty) + + , testCase "Converting (TOption TString) to Expression" $ + M.toExpression (T.TOption T.TString) `shouldBe` + M.ExpressionPrim + ( M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "option" + , mpaArgs = Seq.fromList [M.ExpressionPrim + ( M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "string" + , mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList [] } + )] + , mpaAnnots = Seq.fromList [] + } + ) + + , testCase "Converting Instr (DIP SIZE) to Expression" $ + M.toExpression (T.DIP (T.SIZE @'T.TString)) `shouldBe` + M.ExpressionSeq (Seq.fromList + [ M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "DIP" + , mpaArgs = Seq.fromList [M.ExpressionSeq (Seq.fromList [M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "SIZE" + , mpaArgs = Seq.fromList [] + , mpaAnnots = Seq.fromList [] + })])] + , mpaAnnots = Seq.fromList [] + })] + ) + , testCase "Converting VInt to Expression" $ + M.toExpression @(T.Value $ T.ToT Integer) (T.VInt 12) `shouldBe` M.ExpressionInt 12 + + , testCase "Converting NTPair to Expression" $ + M.toExpression (T.NTPair (U.ann "pair") (U.ann "a") (U.ann "b") (T.NTString U.noAnn) (T.NTInt $ U.ann "val")) `shouldBe` + M.ExpressionPrim + (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "pair" + , mpaArgs = Seq.fromList + [ M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "string" + , mpaArgs = Seq.fromList [] + , mpaAnnots = Seq.fromList [M.AnnotationField (U.ann "a") ]}) + , M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "int" + , mpaArgs = Seq.fromList [] + , mpaAnnots = Seq.fromList [ M.AnnotationType (U.ann "val"), M.AnnotationField (U.ann "b")]}) + ] + , mpaAnnots = Seq.fromList [ M.AnnotationType (U.ann "pair") ] + } + ) + , testCase "Converting sample contract to Expression" $ + M.toExpression sampleContract `shouldBe` + M.ExpressionSeq (Seq.fromList + [ M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "parameter" + , mpaArgs = Seq.fromList [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "unit", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList [M.AnnotationField (U.ann "")]})] + , mpaAnnots = Seq.fromList [] + }) + , M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "storage" + , mpaArgs = Seq.fromList [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "chain_id", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []})] + , mpaAnnots = Seq.fromList [] + }) + , M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "code" + , mpaArgs = Seq.fromList [M.ExpressionSeq (Seq.fromList + [ M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "DROP", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []}) + , M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "CHAIN_ID", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []}) + , M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "NIL" + , mpaArgs = Seq.fromList + [ M.ExpressionPrim (M.MichelinePrimAp + { mpaPrim = M.MichelinePrimitive "operation" + , mpaArgs = Seq.fromList [] + , mpaAnnots = Seq.fromList [] + }) + ] + , mpaAnnots = Seq.fromList [] + }) + , M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "PAIR", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []}) + ])] + , mpaAnnots = Seq.fromList [] + }) + ]) + ] + where + sampleContract :: T.Contract 'T.TUnit 'T.TChainId + sampleContract = + let code = T.DROP `T.Seq` T.CHAIN_ID `T.Seq` T.NIL `T.Seq` T.PAIR + in T.Contract + { cCode = code + , cParamNotes = T.starParamNotes @'T.TUnit + , cStoreNotes = T.starNotes + } diff --git a/test/Test/OpSize.hs b/test/Test/OpSize.hs --- a/test/Test/OpSize.hs +++ b/test/Test/OpSize.hs @@ -16,21 +16,24 @@ import qualified Data.Text as T import Fmt (pretty) +import Hedgehog (Gen) import Test.HUnit (Assertion, (@?=)) -import Test.QuickCheck (Arbitrary(..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Michelson.Macro import Michelson.OpSize import qualified Michelson.Parser as Parser +import Michelson.Test.Util (runGen) import Michelson.Typed -import Tezos.Address +import Michelson.Untyped (unsafeBuildEpName) +import Tezos.Address (genAddress) import Tezos.Core import Tezos.Crypto +import qualified Tezos.Crypto.Ed25519 as Ed25519 +import qualified Tezos.Crypto.Secp256k1 as Secp256k1 import Test.Util.Parser -import Util.Test.Arbitrary (?==) :: HasCallStack => Text -> Word -> Assertion codeText ?== expectedCost = do @@ -38,18 +41,15 @@ let code = expandList parsed expandedInstrsOpSize code @?= OpSize expectedCost -(?=) :: HasCallStack => Text -> Word -> TestTree -code ?= expectedCost = testCase (toString code) $ code ?== expectedCost - {- All particular numbers below are got using dump-op-size.py script -} test_Nesting :: [TestTree] test_Nesting = - [ "" ?= 0 - , "{}" ?= 5 - , "{}; {}" ?= 10 - , mconcat (replicate 100 "{}; ") ?= 500 - , "{{}}" ?= 10 + [ testCase "empty string" $ "" ?== 0 + , testCase "{}" $ "{}" ?== 5 + , testCase "{}; {}" $ "{}; {}" ?== 10 + , testCase "100 * {}" $ mconcat (replicate 100 "{}; ") ?== 500 + , testCase "{{}}" $ "{{}}" ?== 10 ] test_Numbers :: [TestTree] @@ -94,27 +94,27 @@ ] , valueTestCase "mutez" "5" 8 , valueTestCase "bool" "True" 8 - , valueTestCase "key_hash" (stringLike $ pretty (gen @KeyHash)) 47 + , valueTestCase "key_hash" (stringLike $ pretty (gen genKeyHash)) 47 , testGroup "timestamp" [ valueTestCaseExt "small" "timestamp" "5" 8 , valueTestCaseExt "bigger" "timestamp" "123" 9 , valueTestCaseExt "textual" "timestamp" (stringLike "2018-08-08 00:00:00Z") 31 ] , testGroup "address" - [ valueTestCaseExt "plain tz address" "address" (stringLike $ pretty (gen @Address)) 47 - , valueTestCaseExt "plain KT address" "address" (stringLike $ pretty (gen @Address)) 47 - , let addr = gen @Address + [ valueTestCaseExt "plain tz address" "address" (stringLike $ pretty (gen genAddress)) 47 + , valueTestCaseExt "plain KT address" "address" (stringLike $ pretty (gen genAddress)) 47 + , let addr = gen genAddress in valueTestCaseExt "empty entrypoint" "address" (stringLike $ pretty addr <> "%") 48 - , let epAddr = EpAddress gen (EpNameUnsafe "a") + , let epAddr = EpAddress(gen genAddress) (unsafeBuildEpName "a") in valueTestCaseExt "short entrypoint" "address" (stringLike $ pretty epAddr) 49 - , let epAddr = EpAddress gen (EpNameUnsafe . mconcat $ replicate 8 "a") + , let epAddr = EpAddress (gen genAddress) (unsafeBuildEpName . mconcat $ replicate 8 "a") in valueTestCaseExt "long entrypoint" "address" (stringLike $ pretty epAddr) 56 ] -- ed25519 and secp256k1 keys have different size - , valueTestCase "key" (stringLike $ pretty (PublicKeyEd25519 gen)) 65 - , valueTestCase "key" (stringLike $ pretty (PublicKeySecp256k1 gen)) 66 + , valueTestCase "key" (stringLike $ pretty (PublicKeyEd25519 (gen Ed25519.genPublicKey))) 65 + , valueTestCase "key" (stringLike $ pretty (PublicKeySecp256k1 (gen Secp256k1.genPublicKey))) 66 , valueTestCase "unit" "Unit" 8 - , valueTestCase "signature" (stringLike $ pretty (gen @Signature)) 110 + , valueTestCase "signature" (stringLike $ pretty (SignatureEd25519 (gen Ed25519.genSignature))) 110 , testGroup "chain_id" [ valueTestCase "chain_id" (stringLike $ pretty dummyChainId) 26 , valueTestCase "chain_id" "0x00000000" 15 @@ -164,8 +164,8 @@ in valueTestCaseExt name "bytes" val gas stringLike x = "\"" <> x <> "\"" - gen :: Arbitrary a => a - gen = runGen 12 arbitrary + gen :: Gen a -> a + gen genA = runGen 20 12 genA test_Types :: [TestTree] test_Types = @@ -204,63 +204,74 @@ test_Instructions :: [TestTree] test_Instructions = - [ customInstrTestCase "FAILWITH" 2 - , customInstrTestCase "FAIL" 9 + [ instrTestCase "FAILWITH" 2 + , instrTestCase "FAIL" 9 - , instrTestCase "DUP" 4 - , instrTestCase "DUP @" 4 - , instrTestCase "DUP @a" 10 - , instrTestCase "DUP; DROP" 6 - , instrTestCase "DUP; SWAP" 6 - , instrTestCase "DUP; SWAP; SWAP" 8 - , instrTestCase "PUSH int 0" 8 - , instrTestCase "PUSH @a int 0" 14 - , instrTestCase "PUSH @a (int :a) 0" 20 - , instrTestCase "SOME" 4 - , instrTestCase "SOME @" 4 - , instrTestCase "SOME @a" 10 - , instrTestCase "NONE int" 6 - , instrTestCase "NONE (option int)" 8 - , instrTestCase "NONE :a @a (option :a int)" 23 - , instrTestCase "UNIT" 4 - , instrTestCase "DUP; SOME; IF_NONE {}{DROP}" 20 - , instrTestCase "DUP; DUP; PAIR" 8 - , instrTestCase "DUP; DUP; PAIR % % : @" 8 - , instrTestCase "DUP; DUP; PAIR %a" 14 - , instrTestCase "DUP; DUP; PAIR %a %a" 17 - , instrTestCase "DUP; DUP; PAIR %a %a :a" 20 - , instrTestCase "DUP; DUP; PAIR %a % :a @a" 20 - , instrTestCase "DUP; DUP; PAIR % %a :a @a" 23 - , instrTestCase "DUP; DUP; PAIR %a %a :a @a" 23 + , instrTestCaseFailWith "DUP" 4 + , instrTestCaseFailWith "DUP @" 4 + , instrTestCaseFailWith "DUP @a" 10 + , instrTestCaseFailWith "DUP; DROP" 6 + , instrTestCaseFailWith "DUP; SWAP" 6 + , instrTestCaseFailWith "DUP; SWAP; SWAP" 8 + , instrTestCaseFailWith "PUSH int 0" 8 + , instrTestCaseFailWith "PUSH @a int 0" 14 + , instrTestCaseFailWith "PUSH @a (int :a) 0" 20 + , instrTestCaseFailWith "SOME" 4 + , instrTestCaseFailWith "SOME @" 4 + , instrTestCaseFailWith "SOME @a" 10 + , instrTestCaseFailWith "NONE int" 6 + , instrTestCaseFailWith "NONE (option int)" 8 + , instrTestCaseFailWith "NONE :a @a (option :a int)" 23 + , instrTestCaseFailWith "UNIT" 4 + , instrTestCaseFailWith "DUP; SOME; IF_NONE {}{DROP}" 20 + , instrTestCaseFailWith "DUP; DUP; PAIR" 8 + , instrTestCaseFailWith "DUP; DUP; PAIR % % : @" 8 + , instrTestCaseFailWith "DUP; DUP; PAIR %a" 14 + , instrTestCaseFailWith "DUP; DUP; PAIR %a %a" 17 + , instrTestCaseFailWith "DUP; DUP; PAIR %a %a :a" 20 + , instrTestCaseFailWith "DUP; DUP; PAIR %a % :a @a" 20 + , instrTestCaseFailWith "DUP; DUP; PAIR % %a :a @a" 23 + , instrTestCaseFailWith "DUP; DUP; PAIR %a %a :a @a" 23 -- Further skipping some instructions since everything is trivial - , instrTestCase "EMPTY_BIG_MAP :a @a (int :a) (unit :a)" 29 - , instrTestCase "PUSH (list int) {}; MAP {}" 20 - , instrTestCase "DIP {}" 9 - , instrTestCase "DIP 0 {}" 11 - , instrTestCase "DIP 1 {}" 11 - , instrTestCase "DROP 0" 6 - , instrTestCase "PACK" 4 - , instrTestCase "PUSH int 1; PUSH int 2; ADD" 16 - , instrTestCase "DUP; CONTRACT int" 8 + , instrTestCaseFailWith "EMPTY_BIG_MAP :a @a (int :a) (unit :a)" 29 + , instrTestCaseFailWith "PUSH (list int) {}; MAP {}" 20 + , instrTestCaseFailWith "DIP {}" 9 + , instrTestCaseFailWith "DIP 0 {}" 11 + , instrTestCaseFailWith "DIP 1 {}" 11 + , instrTestCaseFailWith "DROP 0" 6 + , instrTestCaseFailWith "PACK" 4 + , instrTestCaseFailWith "PUSH int 1; PUSH int 2; ADD" 16 + , instrTestCaseFailWith "DUP; CONTRACT int" 8 - , instrTestCase "UNIT; PUSH mutez 5; NONE key_hash; \ - \CREATE_CONTRACT \ - \{ parameter unit; \ - \ storage unit; \ - \ code { CDR; NIL operation; PAIR } }" 44 - , instrTestCase "PUSH (or 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 - , 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 + , namedInstrTestCaseFailWith "CREATE_CONTRACT" + "UNIT; PUSH mutez 5; NONE key_hash; \ + \CREATE_CONTRACT \ + \{ parameter unit; \ + \ storage unit; \ + \ code { CDR; NIL operation; PAIR } }" 44 + + , namedInstrTestCaseFailWith "CREATE_CONTRACT + PUSH or" + "PUSH (or 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 + , namedInstrTestCaseFailWith "CREATE_CONTRACT + PUSH or + Annotation" + "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 = - testCase (show instr) $ instr ?== gas + namedInstrTestCase testName instr gas = + testCase testName $ instr ?== gas + + namedInstrTestCaseFailWith testName instr gas = + namedInstrTestCase testName (instr <> "; FAILWITH") gas + instrTestCase instr gas = - customInstrTestCase (instr <> "; FAILWITH") gas + namedInstrTestCase (show instr) instr gas + + instrTestCaseFailWith instr gas = + instrTestCase (instr <> "; FAILWITH") gas diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs --- a/test/Test/Parser.hs +++ b/test/Test/Parser.hs @@ -21,17 +21,20 @@ , unit_PrintComment , unit_ParserException , unit_letType + , unit_block_comment ) where 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), ErrorItem(Tokens), ParseError(FancyError, TrivialError), bundleErrors) +import Text.Megaparsec.Error + (ErrorFancy(ErrorCustom), ErrorItem(Tokens), ParseError(FancyError, TrivialError), bundleErrors) import Michelson.ErrorPos (srcPos) import Michelson.Macro as Mo import Michelson.Parser as P import Michelson.Parser.Annotations as PA +import Michelson.Parser.Lexer as PL import Michelson.Untyped as Mo import Util.IO import Util.Positive @@ -293,3 +296,17 @@ -- They used to be prohibited, but now we permit them. P.parseNoEnv P.letType "" "type Parameter = int" `shouldSatisfy` isRight P.parseNoEnv P.letType "" "type Storage = int" `shouldSatisfy` isRight + +unit_block_comment :: Expectation +unit_block_comment = + forM_ validBlockComments $ \blockComment -> + P.parseNoEnv PL.mSpace "" blockComment `shouldBe` Right () + where + validBlockComments = + [ "/* */" + , " /* */" + , "/* */ " + , "/* */;" + , "/* */ ;" + , "/* */\n;" + ] diff --git a/test/Test/Serialization/Aeson.hs b/test/Test/Serialization/Aeson.hs --- a/test/Test/Serialization/Aeson.hs +++ b/test/Test/Serialization/Aeson.hs @@ -7,51 +7,46 @@ ) where import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) -import Test.QuickCheck (Arbitrary) +import Hedgehog (Gen) import Test.Tasty (TestTree) +import Michelson.Test.Gen (genMutez, genTimestamp) import Michelson.Untyped - (Contract, Elt, ExpandedOp, FieldAnn, InstrAbstract, TypeAnn, Value, VarAnn) + (Contract, Elt, ExpandedOp, FieldAnn, InstrAbstract, StackFn, TypeAnn, Value, VarAnn) import Tezos.Core (Mutez, Timestamp) -import Util.Test.Arbitrary () +import Util.Test.Gen -import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..)) -import Test.Util.QuickCheck (roundtripADTTest, roundtripTest) +import Test.Util.Hedgehog (roundtripTree) + -- Note: if we want to enforce a particular JSON format, we can extend -- these test with golden tests (it's easy with `hspec-golden-aeson`). --- For types with one constructor and/or without 'ToADTArbitrary' instance. test - :: forall a. (Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a, Typeable a) - => TestTree -test = roundtripTest @a encode eitherDecode - --- For types with 'ToADTArbitrary' instance. -testADT :: forall a. - (Show a, Eq a, ToADTArbitrary a, ToJSON a, FromJSON a, Typeable a) - => TestTree -testADT = roundtripADTTest @a encode eitherDecode + :: forall a. (Eq a, Show a, ToJSON a, FromJSON a, Typeable a) + => Gen a -> TestTree +test genA = roundtripTree @a genA encode eitherDecode test_Roundtrip :: [TestTree] test_Roundtrip = [ -- Core Tezos types - test @Timestamp - , test @Mutez + test @Timestamp genTimestamp + , test @Mutez genMutez -- Michelson types - , testADT @ExpandedOp + , test @StackFn genStackFn + , test @ExpandedOp genExpandedOp -- these are actually all the same thing (Annotation a), -- where a is a phantom type, -- but let's test them in case they -- ever change for some reason - , test @TypeAnn - , test @FieldAnn - , test @VarAnn + , test @TypeAnn genAnnotation + , test @FieldAnn genAnnotation + , test @VarAnn genAnnotation - , test @Contract - , testADT @(InstrAbstract ExpandedOp) - , test @Value - , test @(Elt ExpandedOp) + , test @Contract genContract + , test @(InstrAbstract ExpandedOp) (genInstrAbstract genExpandedOp) + , test @Value genValue + , test @(Elt ExpandedOp) (genElt genExpandedOp) ] diff --git a/test/Test/Serialization/Michelson.hs b/test/Test/Serialization/Michelson.hs --- a/test/Test/Serialization/Michelson.hs +++ b/test/Test/Serialization/Michelson.hs @@ -22,7 +22,7 @@ import qualified Michelson.Parser as Parser import Michelson.Test.Util import Michelson.Text -import Michelson.TypeCheck (HST(..), SomeInstr(..), SomeInstrOut(..), typeCheckList, getWTP) +import Michelson.TypeCheck (HST(..), SomeInstr(..), SomeInstrOut(..), getWTP, typeCheckList) import Michelson.Typed import Michelson.Untyped (noAnn) import Test.Util.Parser @@ -73,6 +73,18 @@ decodeHex (stripOptional0x hex) ?: error ("Invalid hex: " <> show hex) +-- | Dummy wrapper for the data needed to test an example scenario + its name. +data Example a = Example + { _eTestName :: String + , _eTestData :: a + } + +-- | Creates a list of example scenarios and labels them using their index. +examples :: [a] -> [Example a] +examples xs = + xs `zip` [1..] <&> + \(testData, index) -> Example ("Example #" <> show @String @Int index) testData + -- | Dummy wrapper for what do we test - pack or unpack. data TestMethod t = TestMethod { _tmName :: String @@ -101,21 +113,21 @@ allTestMethods = packTestMethods <> unpackTestMethods packSpecManual - :: (Show x, HasCallStack) - => String -> [TestMethod t] -> (x -> Value t) -> [(x, Text)] -> Spec + :: HasCallStack + => String -> [TestMethod t] -> (x -> Value t) -> [Example (x, Text)] -> Spec packSpecManual name testMethods toVal' suites = forM_ @[_] testMethods $ \(TestMethod mname method) -> describe mname $ - describe name $ forM_ suites $ \(x, h) -> - it (show x) $ method (toVal' x) h + describe name $ forM_ suites $ \(Example exampleName (x, hex)) -> + it exampleName $ method (toVal' x) hex packSpec :: forall x (t :: T). - ( IsoValue x, Show x, ToT x ~ t - , Typeable t, UnpackedValScope t + ( IsoValue x, ToT x ~ t + , UnpackedValScope t , HasCallStack ) - => [(x, Text)] + => [Example (x, Text)] -> Spec packSpec = packSpecManual typeName allTestMethods toVal where @@ -123,7 +135,7 @@ parsePackSpec :: forall (inp :: T) (out :: T). - (Each [Typeable, SingI] [inp, out], HasCallStack) + (Each '[KnownT] [inp, out], HasCallStack) => String -> [(Text, Text)] -> Spec @@ -131,7 +143,7 @@ parseUnpackOnlySpec :: forall (inp :: T) (out :: T). - (Each [Typeable, SingI] [inp, out], HasCallStack) + (Each '[KnownT] [inp, out], HasCallStack) => String -> [(Text, Text)] -> Spec @@ -139,7 +151,7 @@ parseVLamSpec :: forall (inp :: T) (out :: T). - (Each [Typeable, SingI] [inp, out], HasCallStack) + (Each '[KnownT] [inp, out], HasCallStack) => String -> [TestMethod ('TLambda inp out)] -> [(Text, Text)] @@ -190,64 +202,66 @@ -- Read it as "is packed as". (~:) :: a -> b -> (a, b) (~:) = (,) -infix 0 ~: +infixr 0 ~: intTest :: Spec intTest = packSpec @Integer - [ (-64, "0500c001") - , (-63, "05007f") - , (-2, "050042") - , (-1, "050041") - , (0, "050000") - , (1, "050001") - , (2, "050002") - , (63, "05003f") - , (64, "05008001") - , (65, "05008101") - , (-65, "0500c101") - , (127, "0500bf01") - , (128, "05008002") - , (129, "05008102") - , (-127, "0500ff01") - , (191, "0500bf02") - , (192, "05008003") - , (193, "05008103") - , (2028, "0500ac1f") - , (5000, "0500884e") - , (10000, "0500909c01") - , (20000, "0500a0b802") - , (-5000, "0500c84e") - , (-10000, "0500d09c01") - , (-20000, "0500e0b802") + [ Example "-64" (-64, "0500c001") + , Example "-63" (-63, "05007f") + , Example "-2" (-2, "050042") + , Example "-1" (-1, "050041") + , Example "0" (0, "050000") + , Example "1" (1, "050001") + , Example "2" (2, "050002") + , Example "63" (63, "05003f") + , Example "64" (64, "05008001") + , Example "65" (65, "05008101") + , Example "-65" (-65, "0500c101") + , Example "127" (127, "0500bf01") + , Example "128" (128, "05008002") + , Example "129" (129, "05008102") + , Example "-127" (-127, "0500ff01") + , Example "191" (191, "0500bf02") + , Example "192" (192, "05008003") + , Example "193" (193, "05008103") + , Example "2028" (2028, "0500ac1f") + , Example "5000" (5000, "0500884e") + , Example "10000" (10000, "0500909c01") + , Example "20000" (20000, "0500a0b802") + , Example "-5000" (-5000, "0500c84e") + , Example "-10000" (-10000, "0500d09c01") + , Example "-20000" (-20000, "0500e0b802") ] natTest :: Spec natTest = packSpec @Natural - [ (0, "050000") - , (1, "050001") - , (63, "05003f") - , (64, "05008001") - , (65, "05008101") - , (127, "0500bf01") - , (128, "05008002") - , (129, "05008102") - , (191, "0500bf02") - , (192, "05008003") - , (193, "05008103") + [ Example "0" (0, "050000") + , Example "1" (1, "050001") + , Example "63" (63, "05003f") + , Example "64" (64, "05008001") + , Example "65" (65, "05008101") + , Example "127" (127, "0500bf01") + , Example "128" (128, "05008002") + , Example "129" (129, "05008102") + , Example "191" (191, "0500bf02") + , Example "192" (192, "05008003") + , Example "193" (193, "05008103") ] stringTest :: Spec stringTest = packSpec - @MText - [ [mt|Hello World!|] ~: "05010000000c48656c6c6f20576f726c6421" - , [mt|HODL: Hold On for Dear Life|] + @MText $ + [ Example "Hello World!" $ [mt|Hello World!|] ~: "05010000000c48656c6c6f20576f726c6421" + , Example "HODL: Hold On for Dear Life" $ + [mt|HODL: Hold On for Dear Life|] ~: "05010000001b484f444c3a20486f6c64204f6e20666f722044656172204c696665" - , [mt|\n|] + , Example "Newline" $ + [mt|\n|] ~: "0501000000010a" ] @@ -255,8 +269,9 @@ bytesTest = packSpec @ByteString - [ "000123" ~: "050a00000006303030313233" - , "A rose by any other name would smell as sweet" + [ Example "Numerical" $ "000123" ~: "050a00000006303030313233" + , Example "Alphabetical" $ + "A rose by any other name would smell as sweet" ~: "050a0000002d4120726f736520627920616e79206f74686572206e616\ \d6520776f756c6420736d656c6c206173207377656574" ] @@ -265,39 +280,39 @@ mutezTest = packSpec @Mutez - [ (unsafeMkMutez 0 , "050000") - , (unsafeMkMutez 1 , "050001") - , (unsafeMkMutez 63 , "05003f") - , (unsafeMkMutez 64 , "05008001") - , (unsafeMkMutez 65 , "05008101") - , (unsafeMkMutez 127, "0500bf01") - , (unsafeMkMutez 128, "05008002") - , (unsafeMkMutez 129, "05008102") - , (unsafeMkMutez 191, "0500bf02") - , (unsafeMkMutez 192, "05008003") - , (unsafeMkMutez 193, "05008103") + [ Example "0" (unsafeMkMutez 0 , "050000") + , Example "1" (unsafeMkMutez 1 , "050001") + , Example "63" (unsafeMkMutez 63 , "05003f") + , Example "64" (unsafeMkMutez 64 , "05008001") + , Example "65" (unsafeMkMutez 65 , "05008101") + , Example "127" (unsafeMkMutez 127, "0500bf01") + , Example "128" (unsafeMkMutez 128, "05008002") + , Example "129" (unsafeMkMutez 129, "05008102") + , Example "191" (unsafeMkMutez 191, "0500bf02") + , Example "192" (unsafeMkMutez 192, "05008003") + , Example "193" (unsafeMkMutez 193, "05008103") ] boolTest :: Spec boolTest = packSpec @Bool - [ (True , "05030a") - , (False, "050303") + [ Example "True" $ True ~: "05030a" + , Example "False" $ False ~: "050303" ] keyHashTest :: Spec keyHashTest = do packSpec @KeyHash - [ ( leftToShowPanic $ parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" - , "050a000000150002298c03ed7d454a101eb7022bc95f7e5f41ac78" - ) + [ Example "KeyHash" $ + leftToShowPanic (parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") + ~: "050a000000150002298c03ed7d454a101eb7022bc95f7e5f41ac78" ] timestampTest :: Spec timestampTest = do - packSpec @Timestamp $ convertTimestamps + packSpec @Timestamp $ examples $ convertTimestamps [ (205027200, "050080dec3c301") , (1552564995, "0500838cd2c80b") ] @@ -306,7 +321,7 @@ addressTest :: Spec addressTest = do - packSpec @Address $ parseAddrs + packSpec @Address $ examples $ parseAddrs [ ( "tz1PYgf9fBGLXvwx8ag8sdwjLJzmyGdNiswM" , "050a0000001600002addb327dbca405f07aeef318bba0ec2f714a755" ) @@ -331,7 +346,7 @@ keyTest :: Spec keyTest = - packSpecManual "key" allTestMethods VKey + packSpecManual "key" allTestMethods VKey $ examples [ item "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" "050a00000021009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d" , item "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V" @@ -352,11 +367,11 @@ unitTest = packSpec @() - [() ~: "05030b"] + [Example "Unit" $ () ~: "05030b"] signatureTest :: Spec signatureTest = - packSpecManual "signature" allTestMethods VSignature + packSpecManual "signature" allTestMethods VSignature $ examples [ item "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8\ \ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb" "050a0000004091ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232d\ @@ -375,11 +390,11 @@ \032b3986588dadcf3bf3b549592f7b8ea1365273fbef5f4883c3430ed32e8ae24017be1" ] where - item sigStr sigBytes = ( leftToShowPanic $ parseSignature sigStr, sigBytes) + item sigStr sigBytes = (leftToShowPanic $ parseSignature sigStr, sigBytes) chainIdTest :: Spec chainIdTest = - packSpecManual "chain_id" allTestMethods VChainId + packSpecManual "chain_id" allTestMethods VChainId $ examples [ ( leftToShowPanic $ parseChainId "NetXUdfLh6Gm88t" , "0x050a00000004458aa837" @@ -390,12 +405,13 @@ optionTest = do packSpec @(Maybe Integer) - [ Just 123 ~: "05050900bb01" - , Nothing ~: "050306" + [ Example "Just" $ Just 123 ~: "05050900bb01" + , Example "Nothing" $ Nothing ~: "050306" ] packSpec @(Maybe MText) - [ Just [mt|Goodnight World!|] + [ Example "Just" $ + (Just [mt|Goodnight World!|]) ~: "0505090100000010476f6f646e6967687420576f726c6421" ] @@ -403,35 +419,35 @@ listTest = packSpec @[Integer] - [ [] ~: "050200000000" - , [1] ~: "0502000000020001" - , [1..3] ~: "050200000006000100020003" + [ Example "Empty list" $ [] ~: "050200000000" + , Example "Singleton list" $ [1] ~: "0502000000020001" + , Example "List with many elements" $ [1..3] ~: "050200000006000100020003" ] setTest :: Spec setTest = packSpec @(Set Integer) - [ [] ~: "050200000000" - , [1] ~: "0502000000020001" - , [0, 10, 24, 35, 100, 1000] ~: "05020000000e0000000a0018002300a40100a80f" + [ Example "Empty list" $ [] ~: "050200000000" + , Example "Singleton list" $ [1] ~: "0502000000020001" + , Example "List with many elements" $ [0, 10, 24, 35, 100, 1000] ~: "05020000000e0000000a0018002300a40100a80f" ] contractTest :: Spec contractTest = do - packSpecManual "simple contract" packTestMethods (addressToVContract @'TUnit) $ parseAddrs + packSpecManual "simple contract" packTestMethods (addressToVContract @'TUnit) $ examples $ parseAddrs $ [ "tz1PYgf9fBGLXvwx8ag8sdwjLJzmyGdNiswM" ~: "050a0000001600002addb327dbca405f07aeef318bba0ec2f714a755" , "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH" ~: "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b" ] - packSpecManual "non-unit contract" packTestMethods (addressToVContract @'TInt) $ parseAddrs + packSpecManual "non-unit contract" packTestMethods (addressToVContract @'TInt) $ examples $ parseAddrs $ [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB" ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200" ] - packSpecManual "contract with entrypoint" packTestMethods (mkEpVContract @'TInt) $ parseEpAddrs + packSpecManual "contract with entrypoint" packTestMethods (mkEpVContract @'TInt) $ examples $ parseEpAddrs [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB%" ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200" , "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB%abacaba" @@ -450,11 +466,13 @@ pairTest :: Spec pairTest = do packSpec - @(MText, Integer) + @(MText, Integer) $ + examples [ ([mt|Good Night!|], 5) ~: "050707010000000b476f6f64204e69676874210005" ] packSpec - @(Integer, (Integer, MText)) + @(Integer, (Integer, MText)) $ + examples [ (120, (5, [mt|What is that?|])) ~: "05070700b80107070005010000000d5768617420697320746861743f" ] @@ -463,22 +481,23 @@ orTest = packSpec @(Either MText Bool) - [ Left [mt|Error|] ~: "05050501000000054572726f72" - , Right True ~: "050508030a" + [ Example "Left" $ Left [mt|Error|] ~: "05050501000000054572726f72" + , Example "Right" $ Right True ~: "050508030a" ] mapTest :: Spec mapTest = do packSpec @(Map Integer MText) - [ [] ~: "050200000000" - , [(0, [mt|Hello|]), (1, [mt|Goodbye|]), (2, [mt|Goodnight|])] + [ Example "Empty map" $ [] ~: "050200000000" + , Example "Non-empty map" $ [(0, [mt|Hello|]), (1, [mt|Goodbye|]), (2, [mt|Goodnight|])] ~: "05020000003007040000010000000548656c6c6f07040001010000000\ \7476f6f64627965070400020100000009476f6f646e69676874" ] packSpec - @(Map MText (Integer, Bool)) + @(Map MText (Integer, Bool)) $ + examples [ [ ([mt|Tudor|], (123, True)) , ([mt|Lancaster|], (22323, False)) , ([mt|Stuart|], (-832988, True)) diff --git a/test/Test/Tezos/Address.hs b/test/Test/Tezos/Address.hs --- a/test/Test/Tezos/Address.hs +++ b/test/Test/Tezos/Address.hs @@ -13,16 +13,16 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) -import Tezos.Address (Address, formatAddress, parseAddress) +import Tezos.Address (formatAddress, genAddress, parseAddress) -import Test.Util.QuickCheck (ShowThroughBuild(..), aesonRoundtrip, roundtripTestSTB) +import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) test_Roundtrip :: [TestTree] test_Roundtrip = [ testGroup "parse . format ≡ pure" - [ roundtripTestSTB formatAddress parseAddress ] + [ roundtripTreeSTB genAddress formatAddress parseAddress ] , testGroup "JSON encoding/deconding" - [ aesonRoundtrip @Address ] + [ aesonRoundtrip genAddress ] ] test_parseAddress :: [TestTree] diff --git a/test/Test/Tezos/Core.hs b/test/Test/Tezos/Core.hs --- a/test/Test/Tezos/Core.hs +++ b/test/Test/Tezos/Core.hs @@ -12,7 +12,7 @@ import Test.HUnit ((@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import Test.Util.QuickCheck (ShowThroughBuild(..), aesonRoundtrip, roundtripTestSTB) +import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) import Test.Hspec (shouldBe, shouldSatisfy) import Test.Tasty (testGroup) @@ -56,9 +56,9 @@ test_ChainId_roundtrip :: [TestTree] test_ChainId_roundtrip = [ testGroup "parse . format ≡ pure" - [ roundtripTestSTB formatChainId parseChainId ] + [ roundtripTreeSTB genChainId formatChainId parseChainId ] , testGroup "JSON encoding/deconding" - [ aesonRoundtrip @ChainId ] + [ aesonRoundtrip genChainId ] ] test_Parse_ChainId :: [TestTree] diff --git a/test/Test/Tezos/Crypto.hs b/test/Test/Tezos/Crypto.hs --- a/test/Test/Tezos/Crypto.hs +++ b/test/Test/Tezos/Crypto.hs @@ -18,19 +18,19 @@ import Tezos.Crypto -import Test.Util.QuickCheck (aesonRoundtrip, roundtripTestSTB) +import Test.Util.Hedgehog (aesonRoundtrip, roundtripTreeSTB) test_Roundtrip :: [TestTree] test_Roundtrip = [ testGroup "parse . format ≡ pure" - [ roundtripTestSTB formatPublicKey parsePublicKey - , roundtripTestSTB formatSignature parseSignature - , roundtripTestSTB formatKeyHash parseKeyHash + [ roundtripTreeSTB genPublicKey formatPublicKey parsePublicKey + , roundtripTreeSTB genSignature formatSignature parseSignature + , roundtripTreeSTB genKeyHash formatKeyHash parseKeyHash ] , testGroup "JSON encoding/deconding" - [ aesonRoundtrip @PublicKey - , aesonRoundtrip @Signature - , aesonRoundtrip @KeyHash + [ aesonRoundtrip genPublicKey + , aesonRoundtrip genSignature + , aesonRoundtrip genKeyHash ] ] diff --git a/test/Test/Typecheck.hs b/test/Test/Typecheck.hs --- a/test/Test/Typecheck.hs +++ b/test/Test/Typecheck.hs @@ -12,7 +12,7 @@ , test_Roundtrip , test_StackRef , test_TCTypeError_display - , prop_ValueSeq_as_list + , hprop_ValueSeq_as_list , test_SELF , test_Value_contract ) where @@ -23,25 +23,27 @@ import Data.Singletons (SingI(..)) import Data.Typeable (typeRep) import Fmt (build, pretty) +import Hedgehog (Gen, Property, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.Hspec (expectationFailure) import Test.Hspec.Expectations (Expectation) import Test.HUnit (Assertion, assertFailure, (@?=)) -import Test.QuickCheck (Arbitrary, Property, arbitrary, forAll, property, total, within) -import Test.QuickCheck.Instances.Semigroup () import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit (testCase) -import Test.Tasty.QuickCheck (testProperty) import Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..), srcPos) import Michelson.Parser (utypeQ) import Michelson.Runtime (prepareContract) -import Michelson.Test.Gen () +import Michelson.Test (failedTest, meanTimeUpperBoundPropNF, sec, total) +import Michelson.Test.Gen (genValueInt, genValueTimestamp) import Michelson.Test.Import (ImportContractError(..), readContract) import Michelson.TypeCheck import qualified Michelson.Typed as T -import Michelson.Untyped (ParameterType(..), noAnn) +import Michelson.Untyped (ParameterType(..), noAnn, unsafeBuildEpName) import qualified Michelson.Untyped as Un -import Tezos.Address (Address(..), ContractHash, mkContractHashRaw) +import Tezos.Address (Address(..), ContractHash, mkContractHashHack) import Tezos.Core (Timestamp) import Util.IO (readFileUtf8) @@ -58,7 +60,7 @@ test_srcPosition :: [TestTree] test_srcPosition = - [ testProperty "Verify instruction position in a typecheck error" $ do + [ testCase "Verify instruction position in a typecheck error" $ do checkIllFile (inContractsDir "ill-typed/basic3.tz") $ \case TCFailedOnInstr (Un.CONS _) _ (IsSrcPos 8 6) _ (Just (AnnError _)) -> True _ -> False @@ -150,50 +152,52 @@ test_Roundtrip :: [TestTree] test_Roundtrip = [ testGroup "Value" - [ roundtripValue @Integer - , roundtripValue @Timestamp + [ roundtripValue @Integer genValueInt + , roundtripValue @Timestamp genValueTimestamp ] ] where roundtripValue :: forall (a :: Kind.Type). - ( Each [Typeable, SingI, T.HasNoOp] '[T.ToT a] - , Typeable a, Arbitrary (T.Value $ T.ToT a) + ( Each [T.KnownT, T.HasNoOp] '[T.ToT a] + , Typeable a ) - => TestTree - roundtripValue = - testProperty (show $ typeRep (Proxy @a)) $ - property $ \(val :: T.Value (T.ToT a)) -> - let uval = T.untypeValue val - runTC = runTypeCheckIsolated . usingReaderT (def @InstrCallStack) - in case runTC $ typeCheckValue uval of - Right got -> got @?= val - Left err -> expectationFailure $ - "Type check unexpectedly failed: " <> pretty err + => Gen (T.Value $ T.ToT a) + -> TestTree + roundtripValue genValue = + testProperty (show $ typeRep (Proxy @a)) $ property $ do + val :: T.Value (T.ToT a) <- forAll $ genValue + let uval = T.untypeValue val + runTC = runTypeCheckIsolated . usingReaderT (def @InstrCallStack) + case runTC $ typeCheckValue uval of + Right got -> got === val + Left err -> failedTest $ + "Type check unexpectedly failed: " <> pretty err test_StackRef :: [TestTree] test_StackRef = - [ testProperty "Typecheck fails when ref is out of bounds" $ + [ testProperty "Typecheck fails when ref is out of bounds" $ property $ do let instr = printStRef 2 hst = stackEl ::& stackEl ::& SNil - in case - runTypeCheck (error "no contract param") mempty $ - typeCheckList [Un.WithSrcEx def $ Un.PrimEx instr] hst - of - Left err -> total $ show @Text err - Right _ -> error "Typecheck unexpectedly succeded" - , testProperty "Typecheck time is reasonably bounded" $ within 1000 $ - -- Making code processing performance scale with code size looks like a - -- good property, so we'd like to avoid scenario when user tries to - -- access 100500-th element of stack and typecheck hangs as a result - let instr = printStRef 100000000000 - hst = stackEl ::& SNil - in case + case runTypeCheck (error "no contract param") mempty $ typeCheckList [Un.WithSrcEx def $ Un.PrimEx instr] hst - of - Left err -> total $ show @Text err - Right _ -> error "Typecheck unexpectedly succeded" + of + Left err -> void $ total err + Right _ -> failedTest "Typecheck unexpectedly succeded" + , testProperty "Typecheck time is reasonably bounded" $ + let hst = stackEl ::& SNil + run i = + case + runTypeCheck (error "no contract param") mempty $ + typeCheckList [Un.WithSrcEx def $ Un.PrimEx (printStRef i)] hst + of + Left err -> err + Right _ -> error "Typecheck unexpectedly succeded" + -- Making code processing performance scale with code size looks like a + -- good property, so we'd like to avoid scenario when user tries to + -- access 100500-th element of stack and typecheck hangs as a result + in meanTimeUpperBoundPropNF (sec 1) run 100000000000 ] where printStRef i = Un.EXT . Un.UPRINT $ Un.PrintComment [Right (Un.StackRef i)] @@ -222,14 +226,14 @@ @?= "Value type is never a valid `unit`" ] -prop_ValueSeq_as_list :: Property -prop_ValueSeq_as_list = - forAll @(NonEmpty Integer) arbitrary $ \l -> +hprop_ValueSeq_as_list :: Property +hprop_ValueSeq_as_list = property $ do + l <- forAll $ Gen.nonEmpty (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000)) let untypedValue = Un.ValueSeq $ Un.ValueInt <$> l typedValue = T.VList $ T.VInt <$> toList l runTypeCheckInstr = runTypeCheckIsolated . usingReaderT def - in runTypeCheckInstr (typeCheckValue untypedValue) == Right typedValue + runTypeCheckInstr (typeCheckValue untypedValue) === Right typedValue test_SELF :: [TestTree] test_SELF = @@ -265,9 +269,9 @@ res -> assertFailure $ "Unexpected result: " <> show res ] where - addr1' = mkContractHashRaw "123" - addr1 = T.EpAddress (ContractAddress addr1') (T.EpNameUnsafe "a") - addr2 = T.EpAddress (ContractAddress addr1') (T.EpNameUnsafe "q") + addr1' = mkContractHashHack "123" + addr1 = T.EpAddress (ContractAddress addr1') (unsafeBuildEpName "a") + addr2 = T.EpAddress (ContractAddress addr1') (unsafeBuildEpName "q") addrUVal1 = Un.ValueString $ T.mformatEpAddress addr1 addrUVal2 = Un.ValueString $ T.mformatEpAddress addr2 diff --git a/test/Test/Util/HUnit.hs b/test/Test/Util/HUnit.hs --- a/test/Test/Util/HUnit.hs +++ b/test/Test/Util/HUnit.hs @@ -9,7 +9,7 @@ ) where import Test.HUnit (Assertion, assertEqual) -import Test.Util.QuickCheck (ShowThroughBuild(..)) +import Test.Util.Hedgehog (ShowThroughBuild(..)) assertEqualBuild :: (HasCallStack, Eq a, Show (ShowThroughBuild a)) diff --git a/test/Test/Util/Hedgehog.hs b/test/Test/Util/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/Hedgehog.hs @@ -0,0 +1,91 @@ +-- SPDX-FileCopyrightText: 2020 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +{- +Copyright (c) 2017 IOHK + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +-} + +-- | Testing utilities to be used with Hedgehog + +module Test.Util.Hedgehog + ( ShowThroughBuild (..) + + -- * Roundtrip properties + , roundtripTree + , roundtripTreeSTB + , aesonRoundtrip + ) where + +import Data.Aeson (FromJSON(..), ToJSON(..)) +import qualified Data.Aeson as Aeson +import Fmt (Buildable, pretty) +import Test.Tasty (TestTree) +import qualified Text.Show (show) + +import Hedgehog (Gen) +import Michelson.Test.Util (roundtripTree) + +---------------------------------------------------------------------------- +-- 'Show'ing a value though 'Buildable' type class. +-- Useful because Hedgehog uses 'Show'. +---------------------------------------------------------------------------- + +newtype ShowThroughBuild a = STB + { unSTB :: a + } deriving newtype (Eq, Ord) + +instance {-# OVERLAPPABLE #-} Buildable a => Show (ShowThroughBuild a) where + show = pretty . unSTB + +instance Show (ShowThroughBuild ByteString) where + show = show . unSTB + +genShowThroughBuild :: Gen a -> Gen (ShowThroughBuild a) +genShowThroughBuild genA = STB <$> genA + + +---------------------------------------------------------------------------- +-- Roundtrip +---------------------------------------------------------------------------- + +-- | Version of 'roundtripTree' which shows values using 'Buildable' instance. +roundtripTreeSTB + :: forall x y err. + ( Show (ShowThroughBuild x) + , Show y + , Show (ShowThroughBuild err) + , Typeable x + , Eq x + , Eq err + ) + => Gen x + -> (x -> y) + -> (y -> Either err x) + -> TestTree +roundtripTreeSTB genX xToY yToX = roundtripTree (genShowThroughBuild genX) (xToY . unSTB) (bimap STB STB . yToX) + +aesonRoundtrip + :: forall x. + (Show (ShowThroughBuild x), ToJSON x, FromJSON x, Typeable x, Eq x) + => Gen x -> TestTree +aesonRoundtrip genX = roundtripTreeSTB genX (Aeson.encode @x) Aeson.eitherDecode diff --git a/test/Test/Util/QuickCheck.hs b/test/Test/Util/QuickCheck.hs deleted file mode 100644 --- a/test/Test/Util/QuickCheck.hs +++ /dev/null @@ -1,112 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - -{- -Copyright (c) 2017 IOHK - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. --} - --- | Testing utilities to be used with QuickCheck - -module Test.Util.QuickCheck - ( ShowThroughBuild (..) - - -- * Roundtrip properties - , roundtripTest - , roundtripADTTest - , roundtripTestSTB - , aesonRoundtrip - ) where - -import Data.Aeson (FromJSON(..), ToJSON(..)) -import qualified Data.Aeson as Aeson -import Data.Typeable (typeRep) -import Fmt (Buildable, pretty) -import Test.QuickCheck (Arbitrary, forAll, resize) -import Test.QuickCheck.Arbitrary.ADT - (ADTArbitrary(..), ConstructorArbitraryPair(..), ToADTArbitrary(..)) -import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (Property, testProperty, (.&&.), (===)) -import qualified Text.Show (show) - -import Michelson.Test.Util (roundtripTest) - ----------------------------------------------------------------------------- --- 'Show'ing a value though 'Buildable' type class. --- Useful because QuickCheck uses 'Show'. ----------------------------------------------------------------------------- - -newtype ShowThroughBuild a = STB - { unSTB :: a - } deriving newtype (Eq, Ord, Arbitrary) - -instance {-# OVERLAPPABLE #-} Buildable a => Show (ShowThroughBuild a) where - show = pretty . unSTB - -instance Show (ShowThroughBuild ByteString) where - show = show . unSTB - ----------------------------------------------------------------------------- --- Roundtrip ----------------------------------------------------------------------------- - --- | Version of 'roundtripTest' which shows values using 'Buildable' instance. -roundtripTestSTB :: - forall x y err. - ( Show (ShowThroughBuild x) - , Show (ShowThroughBuild err) - , Typeable x - , Arbitrary x - , Eq x - , Eq err - ) - => (x -> y) - -> (y -> Either err x) - -> TestTree -roundtripTestSTB xToY yToX = roundtripTest (xToY . unSTB) (bimap STB STB . yToX) - -roundtripADTTest :: - forall x y err. - ( Show x - , Show err - , Typeable x - , ToADTArbitrary x - , Eq x - , Eq err - ) - => (x -> y) - -> (y -> Either err x) - -> TestTree -roundtripADTTest xToY yToX = testProperty typeName prop - where - prop :: Property - prop = - forAll (resize 1 $ toADTArbitrary (Proxy @x)) $ \adt -> - foldr ((.&&.) . check . capArbitrary) z (adtCAPs adt) - typeName = show $ typeRep (Proxy @x) - check x = yToX (xToY x) === Right x - z = True === True - -aesonRoundtrip :: - forall x. (Show (ShowThroughBuild x), ToJSON x, FromJSON x, Typeable x, Arbitrary x, Eq x) - => TestTree -aesonRoundtrip = roundtripTestSTB (Aeson.encode @x) Aeson.eitherDecode diff --git a/test/Test/ValConversion.hs b/test/Test/ValConversion.hs --- a/test/Test/ValConversion.hs +++ b/test/Test/ValConversion.hs @@ -9,35 +9,43 @@ , unit_toVal ) where +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.HUnit (Assertion, (@?)) -import Test.QuickCheck (Arbitrary) import Test.Tasty (TestTree) +import Michelson.Test.Util (genEither, genTuple2) import Michelson.Text import Michelson.Typed (IsoValue(..), ToT, Value, Value'(..)) -import Test.Util.QuickCheck (roundtripTest) +import Test.Util.Hedgehog (roundtripTree) -- | TestTrees to test toVal / fromVal conversions (roundtrip) test_Roundtrip :: [TestTree] test_Roundtrip = - [ roundtrip @Integer - , roundtrip @Bool - , roundtrip @[Bool] - , roundtrip @(Maybe Integer) - , roundtrip @(Maybe (Maybe Integer)) - , roundtrip @(Either Bool Integer) - , roundtrip @(Set Integer) - , roundtrip @(Set Integer) - , roundtrip @(Set Bool) - , roundtrip @(Map Integer Integer) - , roundtrip @(Map Integer Bool) - , roundtrip @(Map Integer (Maybe (Either Bool Bool))) + [ roundtrip @Integer genInteger + , roundtrip @Bool Gen.bool + , roundtrip @[Bool] $ Gen.list (Range.linear 0 100) Gen.bool + , roundtrip @(Maybe Integer) $ Gen.maybe genInteger + , roundtrip @(Maybe (Maybe Integer)) $ Gen.maybe (Gen.maybe genInteger) + , roundtrip @(Either Bool Integer) $ genEither Gen.bool genInteger + , roundtrip @(Set Integer) $ Gen.set (Range.linear 0 100) genInteger + , roundtrip @(Set Bool) $ Gen.set (Range.linear 0 2) Gen.bool + , roundtrip @(Map Integer Integer) $ Gen.map (Range.linear 0 100) (genTuple2 genInteger genInteger) + , roundtrip @(Map Integer Bool) $ Gen.map (Range.linear 0 100) (genTuple2 genInteger Gen.bool) + , roundtrip @(Map Integer (Maybe (Either Bool Bool))) $ + Gen.map (Range.linear 0 100) $ + genTuple2 + genInteger + (Gen.maybe (genEither Gen.bool Gen.bool)) ] where + genInteger = Gen.integral (Range.linearFrom 0 (fromIntegral $ minBound @Int64) (fromIntegral $ maxBound @Word64)) + roundtrip :: forall a. - (Show a, Eq a, Arbitrary a, Typeable a, IsoValue a) => TestTree - roundtrip = roundtripTest @a @_ @Void toVal (Right . fromVal) + (Show a, Eq a, Typeable a, IsoValue a) => Gen a -> TestTree + roundtrip genA = roundtripTree @a @_ @Void genA toVal (Right . fromVal) unit_toVal :: Assertion unit_toVal = do @@ -56,7 +64,7 @@ $ (\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 @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)