morley 0.1.0.1 → 0.1.0.2
raw patch · 20 files changed
+615/−225 lines, 20 filesdep +aeson-pretty
Dependencies added: aeson-pretty
Files
- README.md +22/−23
- morley.cabal +7/−3
- src/Michelson/TypeCheck/Helpers.hs +12/−0
- src/Michelson/TypeCheck/Value.hs +48/−25
- src/Michelson/Typed/Convert.hs +9/−5
- src/Michelson/Untyped/Value.hs +7/−5
- src/Morley/Macro.hs +4/−1
- src/Morley/Parser.hs +25/−14
- src/Morley/Parser/Helpers.hs +9/−0
- src/Morley/Runtime.hs +4/−3
- src/Morley/Runtime/GState.hs +7/−1
- src/Morley/Test/Integrational.hs +201/−64
- src/Tezos/Address.hs +9/−0
- test/Test/Arbitrary.hs +12/−13
- test/Test/Interpreter.hs +2/−0
- test/Test/Interpreter/CallSelf.hs +16/−19
- test/Test/Interpreter/EnvironmentSpec.hs +104/−0
- test/Test/Interpreter/StringCaller.hs +100/−43
- test/Test/Macro.hs +5/−3
- test/Test/Parser.hs +12/−3
README.md view
@@ -5,31 +5,30 @@ ## I: A reimplementation of the Michelson Language in Haskell -- `Michelson.Untyped`: Simple data types representing Michelson smart- contracts and expresions. We use word `Untyped` to reflect that- Michelson type of corresponding Haskel values is not statically known- (e. g. there is a `Value` type which is basically dynamically typed).-- `Michelson.Typed`: These modules contain more advanced types comparing to- `Michelson.Untyped` with similar semantics. These types use `GADTs` GHC- extension and in this representation Michelson type of each value and- instruction is statically known. There are also some utilities to use this- advanced machinery.-- `Michelson.TypeCheck`: A typechecker that validates ADT's that conform to- Michelson's typing rules.-- `Michelson.Intepreter`: An intepreter for Michelson contracts which doesn't- perform any side effects.-- `Morley.Types`: Types for macros, syntactic sugar, and interpreter directives.-- `Morley.Parser` A parser to turn a `.tz` file into an ADT.-- `Morley.Runtime`: An interpreter that executes a well-typed Morley smart- contract in a sandbox.+It consists of the following parts: -## II: Testing tools (TBD)+- `Tezos.*` hierarchy is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts, but is used not only by Michelson.+- `Michelson.Untyped` and `Michelson.Typed` hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](/docs/michelsonTypes.md).+- `Michelson.TypeCheck`: A typechecker that validates Michelson contracts according to Michelson's typing rules. Essentially it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](/docs/morleyTypechecker.md).+- `Michelson.Intepreter`: An intepreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](/docs/morleyInterpreter.md).+- `Morley.Types`: Types for macros, syntactic sugar and other extensions described in the next chapter.+- `Morley.Parser` A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT.+- `Morley.Runtime`: A high-level interface to Morley functionality, see [morleyRuntime.md](/docs/morleyRuntime.md). -- `Morley.REPL`: An interactive REPL with stack visualization.-- `Morley.QuickCheck`: QuickCheck generators for arbitary Michelson `Value`s,- `LAMBDA`s and `Contract`s.-- `Morley.Sandbox`: Simulating a more realistic network environment, multiple- smart contracts in the same sandbox.+## II: Morley extensions++The Morley Language is a superset of the Michelson language, which means that each Michelson contract is also a valid Morley contract but not vice versa.+There are several extensions which make it more convenient to write Michelson contracts and test them.+See [the document](/docs/morleyLanguage.md) about these extensions.+Also there is a transpiler from Morley to Michelson.++## III: Morley-to-Michelson transpiler++Coming soon, see TM-58.++## IV: Testing EDSL++Coming soon, see TM-77. ## Issue Tracker
morley.cabal view
@@ -1,18 +1,18 @@+cabal-version: 2.4 name: morley-version: 0.1.0.1+version: 0.1.0.2 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. homepage: https://gitlab.com/camlcase-dev/morley-license: AGPL-3+license: AGPL-3.0-or-later license-file: LICENSE author: camlCase, Serokell maintainer: john@camlcase.io copyright: 2018 camlCase, 2019 Tocqueville Group category: Language build-type: Simple-cabal-version: >=1.18 bug-reports: https://issues.serokell.io/issues/TM extra-doc-files: CONTRIBUTING.md , README.md@@ -38,6 +38,7 @@ , Morley.Ext , Morley.Parser , Morley.Parser.Annotations+ , Morley.Parser.Helpers , Morley.Runtime , Morley.Runtime.GState , Morley.Runtime.TxData@@ -75,6 +76,7 @@ build-depends: aeson , aeson-options+ , aeson-pretty , base-noprelude >= 4.7 && < 5 , base16-bytestring , base58-bytestring@@ -151,6 +153,7 @@ executable morley hs-source-dirs: app main-is: Main.hs+ autogen-modules: Paths_morley other-modules: Paths_morley default-language: Haskell2010 build-depends: base-noprelude >= 4.7 && < 5@@ -221,6 +224,7 @@ , Test.Interpreter.CallSelf , Test.Interpreter.Compare , Test.Interpreter.Conditionals+ , Test.Interpreter.EnvironmentSpec , Test.Interpreter.StringCaller , Test.Macro , Test.Ext
src/Michelson/TypeCheck/Helpers.hs view
@@ -8,6 +8,7 @@ , convergeHSTEl , convergeHST + , ensureDistinctAsc , eqT' , assertEqT , checkEqT@@ -38,6 +39,7 @@ import Data.Singletons (SingI(sing)) import qualified Data.Text as T import Data.Typeable ((:~:)(..), eqT, typeRep)+import Fmt ((+||), (||+)) import Michelson.TypeCheck.Types import Michelson.Typed@@ -135,6 +137,16 @@ -------------------------------------------- -- Typechecker auxiliary --------------------------------------------++-- | Check whether elements go in strictly ascending order and+-- return the original list (to keep only one pass on the original list).+ensureDistinctAsc :: (Ord a, Show a) => [a] -> Either Text [a]+ensureDistinctAsc = \case+ (e1 : e2 : l) ->+ if e1 < e2+ then (e1 :) <$> ensureDistinctAsc (e2 : l)+ else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ""+ l -> Right l checkEqT :: forall a b ts . (Typeable a, Typeable b, Typeable ts)
src/Michelson/TypeCheck/Value.hs view
@@ -111,49 +111,72 @@ withSomeSingT vt $ \vst -> pure $ VOption Nothing :::: (STOption vst, NStar) -typeCheckValImpl tcDo (Un.ValueSeq mels) (TList vt) =+typeCheckValImpl _ Un.ValueNil (TList vt) =+ withSomeSingT vt $ \vst ->+ pure $ VList [] :::: (STList vst, mkNotes $ NTList def NStar)++typeCheckValImpl tcDo (Un.ValueSeq (toList -> mels)) (TList vt) = withSomeSingT vt $ \vst -> do (els, ns) <- typeCheckValsImpl tcDo mels vt pure $ VList els :::: (STList vst, mkNotes $ NTList def ns) -typeCheckValImpl _ (Un.ValueSeq mels) (TSet vt) =+typeCheckValImpl _ Un.ValueNil (TSet vt) =+ withSomeSingCT vt $ \vst ->+ pure $ VSet S.empty :::: (STSet vst, NStar)++typeCheckValImpl _ sq@(Un.ValueSeq (toList -> mels)) (TSet vt) = withSomeSingCT vt $ \vst -> do els <- liftEither $ typeCheckCVals mels vt `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc vt) $ "wrong type of set element: " <> err- pure $ VSet (S.fromList els) :::: (STSet vst, NStar)+ elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc els+ `onLeft` TCFailedOnValue sq (Tc vt)+ pure $ VSet elsS :::: (STSet vst, NStar) -typeCheckValImpl tcDo (Un.ValueMap mels) (TMap kt vt) =+typeCheckValImpl _ Un.ValueNil (TMap kt vt) = withSomeSingT vt $ \vst -> withSomeSingCT kt $ \kst -> do+ let ns = mkNotes $ NTMap def def NStar+ pure $ VMap M.empty :::: (STMap kst vst, ns)++typeCheckValImpl tcDo sq@(Un.ValueMap (toList -> mels)) (TMap kt vt) =+ withSomeSingT vt $ \vst ->+ withSomeSingCT kt $ \kst -> do ks <- liftEither $ typeCheckCVals (map (\(Un.Elt k _) -> k) mels) kt `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc kt) $ "wrong type of map key: " <> err (vals, vns) <- typeCheckValsImpl tcDo (map (\(Un.Elt _ v) -> v) mels) vt let ns = mkNotes $ NTMap def def vns- pure $ VMap (M.fromList $ zip ks vals) :::: (STMap kst vst, ns)+ ksS <- liftEither $ ensureDistinctAsc ks+ `onLeft` TCFailedOnValue sq (Tc kt)+ pure $ VMap (M.fromDistinctAscList $ zip ksS vals) :::: (STMap kst vst, ns) -typeCheckValImpl tcDo v@(Un.ValueLambda (fmap Un.unOp -> mp)) t@(TLambda mi mo) =+typeCheckValImpl tcDo v t@(TLambda mi mo) = do+ mp <- case v of+ Un.ValueNil -> pure []+ Un.ValueLambda mp -> pure $ fmap Un.unOp (toList mp)+ _ -> throwError $ TCFailedOnValue v t ""+ withSomeSingT mi $ \(it :: Sing it) ->- withSomeSingT mo $ \(ot :: Sing ot) ->- typeCheckImpl tcDo mp (SomeHST $ (it, NStar, def) ::& SNil) >>= \case- SiFail -> pure $ VLam FAILWITH :::: (STLambda it ot, NStar)- lam ::: ((li :: HST li), (lo :: HST lo)) -> do- Refl <- liftEither $ eqT' @li @'[ it ] `onLeft` unexpectedErr- case (eqT' @'[ ot ] @lo, SomeHST lo, SomeHST li) of- (Right Refl,- SomeHST ((_, ons, _) ::& SNil :: HST lo'),- SomeHST ((_, ins, _) ::& SNil :: HST li')) -> do- Refl <- liftEither $ eqT' @lo @lo' `onLeft` unexpectedErr- Refl <- liftEither $ eqT' @li @li' `onLeft` unexpectedErr- let ns = mkNotes $ NTLambda def ins ons- pure $ VLam lam :::: (STLambda it ot, ns)- (Right _, _, _) ->- throwError $ TCFailedOnValue v t- "wrong output type of lambda's value (wrong stack size)"- (Left m, _, _) ->- throwError $ TCFailedOnValue v t $- "wrong output type of lambda's value: " <> m+ withSomeSingT mo $ \(ot :: Sing ot) ->+ typeCheckImpl tcDo mp (SomeHST $ (it, NStar, def) ::& SNil) >>= \case+ SiFail -> pure $ VLam FAILWITH :::: (STLambda it ot, NStar)+ lam ::: ((li :: HST li), (lo :: HST lo)) -> do+ Refl <- liftEither $ eqT' @li @'[ it ] `onLeft` unexpectedErr+ case (eqT' @'[ ot ] @lo, SomeHST lo, SomeHST li) of+ (Right Refl,+ SomeHST ((_, ons, _) ::& SNil :: HST lo'),+ SomeHST ((_, ins, _) ::& SNil :: HST li')) -> do+ Refl <- liftEither $ eqT' @lo @lo' `onLeft` unexpectedErr+ Refl <- liftEither $ eqT' @li @li' `onLeft` unexpectedErr+ let ns = mkNotes $ NTLambda def ins ons+ pure $ VLam lam :::: (STLambda it ot, ns)+ (Right _, _, _) ->+ throwError $ TCFailedOnValue v t+ "wrong output type of lambda's value (wrong stack size)"+ (Left m, _, _) ->+ throwError $ TCFailedOnValue v t $+ "wrong output type of lambda's value: " <> m where unexpectedErr m = TCFailedOnValue v t ("unexpected " <> m)
src/Michelson/Typed/Convert.hs view
@@ -62,20 +62,24 @@ VSignature b -> Just $ Un.ValueString $ formatSignature b VOption (Just x) -> Un.ValueSome <$> valToOpOrValue x VOption Nothing -> Just $ Un.ValueNone- VList l -> Un.ValueSeq <$> mapM valToOpOrValue l- VSet s -> Just $ Un.ValueSeq $ map cValToValue $ toList s+ VList l -> valueList Un.ValueSeq <$> mapM valToOpOrValue l+ VSet s -> Just $ valueList Un.ValueSeq $ map cValToValue $ toList s VOp _op -> Nothing VContract b -> Just $ Un.ValueString $ formatAddress b VPair (l, r) -> Un.ValuePair <$> valToOpOrValue l <*> valToOpOrValue r VOr (Left x) -> Un.ValueLeft <$> valToOpOrValue x VOr (Right x) -> Un.ValueRight <$> valToOpOrValue x- VLam ops -> Just $ Un.ValueLambda $ instrToOps ops+ VLam ops ->+ Just $ maybe Un.ValueNil Un.ValueLambda $+ nonEmpty (instrToOps ops) VMap m ->- fmap Un.ValueMap . forM (Map.toList m) $ \(k, v) ->+ fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) -> Un.Elt (cValToValue k) <$> valToOpOrValue v VBigMap m ->- fmap Un.ValueMap . forM (Map.toList m) $ \(k, v) ->+ fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) -> Un.Elt (cValToValue k) <$> valToOpOrValue v+ where+ valueList ctor = maybe Un.ValueNil ctor . nonEmpty cValToValue :: CVal t -> Un.Value Un.Op cValToValue cVal = case cVal of
src/Michelson/Untyped/Value.hs view
@@ -31,11 +31,12 @@ | ValueRight (Value op) | ValueSome (Value op) | ValueNone- | ValueSeq [Value op]+ | ValueNil+ | ValueSeq (NonEmpty $ Value op) -- ^ A sequence of elements: can be a list or a set. -- We can't distinguish lists and sets during parsing.- | ValueMap [Elt op]- | ValueLambda [op]+ | ValueMap (NonEmpty $ Elt op)+ | ValueLambda (NonEmpty op) deriving stock (Eq, Show, Functor, Data, Generic) data Elt op = Elt (Value op) (Value op)@@ -63,12 +64,13 @@ ValueRight v -> "(Right " +| v |+ ")" ValueSome v -> "(Some " +| v |+ ")" ValueNone -> "None"+ ValueNil -> "{}" ValueSeq vs -> buildList vs ValueMap els -> buildList els ValueLambda ops -> buildList ops where- buildList :: Buildable a => [a] -> Builder- buildList items =+ buildList :: Buildable a => NonEmpty a -> Builder+ buildList (toList -> items) = "{" <> mconcat (intersperse "; " $ map Buildable.build items) <> "}"
src/Morley/Macro.hs view
@@ -41,9 +41,12 @@ ValueLeft x -> ValueLeft (expandValue x) ValueRight x -> ValueRight (expandValue x) ValueSome x -> ValueSome (expandValue x)+ ValueNil -> ValueNil ValueSeq valueList -> ValueSeq (map expandValue valueList) ValueMap eltList -> ValueMap (map expandElt eltList)- ValueLambda opList -> ValueLambda (expandFlat $ opList)+ ValueLambda opList ->+ maybe ValueNil ValueLambda $+ nonEmpty (expandFlat $ toList opList) x -> fmap (unsafeCastPrim . expand) x expandElt :: Elt ParsedOp -> Elt Op
src/Morley/Parser.hs view
@@ -29,6 +29,7 @@ import Morley.Lexer import qualified Morley.Macro as Macro import Morley.Parser.Annotations+import Morley.Parser.Helpers import Morley.Types (CustomParserException(..), ParsedOp(..), Parser, ParserException(..)) import qualified Morley.Types as Mo @@ -97,18 +98,24 @@ where ti = snd <$> (lexeme $ typeInner (pure Mo.noAnn)) -ops :: Parser [Mo.ParsedOp]-ops = do+op' :: Parser Mo.ParsedOp+op' = do lms <- asks Mo.letMacros- let op' = choice [ (Mo.PRIM . Mo.EXT) <$> nopInstr- , Mo.LMAC <$> mkLetMac lms- , Mo.PRIM <$> prim- , Mo.MAC <$> macro- , primOrMac- , Mo.SEQ <$> ops- ]- braces $ sepEndBy op' semicolon+ choice+ [ (Mo.PRIM . Mo.EXT) <$> nopInstr+ , Mo.LMAC <$> mkLetMac lms+ , Mo.PRIM <$> prim+ , Mo.MAC <$> macro+ , primOrMac+ , Mo.SEQ <$> ops+ ] +ops :: Parser [Mo.ParsedOp]+ops = braces $ sepEndBy op' semicolon++ops1 :: Parser (NonEmpty Mo.ParsedOp)+ops1 = braces $ sepEndBy1 op' semicolon+ ------------------------------------------------------------------------------- -- Let block -------------------------------------------------------------------------------@@ -216,7 +223,8 @@ valueInner = choice $ [ intLiteral, stringLiteral, bytesLiteral, unitValue , trueValue, falseValue, pairValue, leftValue, rightValue- , someValue, noneValue, seqValue, mapValue, lambdaValue, dataLetValue+ , someValue, noneValue, nilValue, seqValue, mapValue, lambdaValue+ , dataLetValue ] dataLetValue :: Parser (Mo.Value ParsedOp)@@ -302,17 +310,20 @@ noneValue :: Parser (Mo.Value ParsedOp) noneValue = do symbol "None"; return Mo.ValueNone +nilValue :: Parser (Mo.Value ParsedOp)+nilValue = Mo.ValueNil <$ (try $ braces pass)+ lambdaValue :: Parser (Mo.Value ParsedOp)-lambdaValue = Mo.ValueLambda <$> ops+lambdaValue = Mo.ValueLambda <$> ops1 seqValue :: Parser (Mo.Value ParsedOp)-seqValue = Mo.ValueSeq <$> (try $ braces $ sepEndBy value semicolon)+seqValue = Mo.ValueSeq <$> (try $ braces $ sepEndBy1 value semicolon) eltValue :: Parser (Mo.Elt ParsedOp) eltValue = do void $ symbol "Elt"; Mo.Elt <$> value <*> value mapValue :: Parser (Mo.Value ParsedOp)-mapValue = Mo.ValueMap <$> (try $ braces $ sepEndBy eltValue semicolon)+mapValue = Mo.ValueMap <$> (try $ braces $ sepEndBy1 eltValue semicolon) ------------------------------------------------------------------------------- -- Types
+ src/Morley/Parser/Helpers.hs view
@@ -0,0 +1,9 @@+module Morley.Parser.Helpers+ ( sepEndBy1+ ) where++import qualified Data.List.NonEmpty as NE+import qualified Text.Megaparsec as P++sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)+sepEndBy1 = fmap NE.fromList ... P.sepEndBy1
src/Morley/Runtime.hs view
@@ -94,7 +94,7 @@ data InterpreterError = IEUnknownContract !Address -- ^ The interpreted contract hasn't been originated.- | IEInterpreterFailed !(Contract Op)+ | IEInterpreterFailed !Address !(InterpretUntypedError MorleyLogs) -- ^ Interpretation of Michelson contract failed. | IEAlreadyOriginated !Address@@ -116,7 +116,8 @@ build = \case IEUnknownContract addr -> "The contract is not originated " +| addr |+ ""- IEInterpreterFailed _ err -> "Michelson interpreter failed: " +| err |+ ""+ IEInterpreterFailed addr err ->+ "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ "" IEAlreadyOriginated addr cs -> "The following contract is already originated: " +| addr |+ ", " +| cs |+ ""@@ -372,7 +373,7 @@ , iurNewStorage = newValue , iurNewState = InterpreterState printedLogs newRemainingSteps }- <- first (IEInterpreterFailed contract) $+ <- first (IEInterpreterFailed addr) $ interpretMorleyUntyped contract (tdParameter txData) (csStorage cs) contractEnv let
src/Morley/Runtime/GState.hs view
@@ -25,6 +25,7 @@ import Control.Lens (at) import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Aeson import Data.Aeson.Options (defaultOptions) import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString.Lazy as LBS@@ -132,7 +133,12 @@ -- | Write 'GState' to a file. writeGState :: FilePath -> GState -> IO ()-writeGState fp gs = LBS.writeFile fp (Aeson.encode gs)+writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs)+ where+ config =+ Aeson.defConfig+ { Aeson.confTrailingNewline = True+ } -- | Updates that can be applied to 'GState'. data GStateUpdate
src/Morley/Test/Integrational.hs view
@@ -1,142 +1,206 @@ -- | Utilities for integrational testing.+-- Example tests can be found in the 'morley-test' test suite. module Morley.Test.Integrational- ( IntegrationalValidator+ (+ -- * Re-exports+ TxData (..)++ -- * Testing engine+ , TestOperation (..)+ , IntegrationalValidator , SuccessValidator+ , IntegrationalScenario , integrationalTestExpectation , integrationalTestProperty- , simplerIntegrationalTestExpectation- , simplerIntegrationalTestProperty+ , originate+ , transfer+ , validate+ , setMaxSteps+ , setNow -- * Validators , composeValidators- , expectStorageValue- , expectStorageConstant+ , composeValidatorsList+ , expectAnySuccess+ , expectStorageUpdate+ , expectStorageUpdateConst , expectBalance+ , expectStorageConst , expectGasExhaustion+ , expectMichelsonFailed ) where -import Control.Lens (at)+import Control.Lens (at, makeLenses, (.=), (<>=))+import Control.Monad.Except (Except, runExcept, throwError) import qualified Data.List as List import Fmt (blockListF, pretty, (+|), (|+)) import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Property) import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps)-import Morley.Aliases (UntypedValue)+import Michelson.Untyped (OriginationOperation(..), mkContractAddress)+import Morley.Aliases (UntypedContract, UntypedValue) import Morley.Runtime (InterpreterError(..), InterpreterOp(..), InterpreterRes(..), interpreterPure) import Morley.Runtime.GState+import Morley.Runtime.TxData import Morley.Test.Dummy import Morley.Test.Util (failedProp, succeededProp) import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp) +----------------------------------------------------------------------------+-- Some internals (they are here because TH makes our very existence much harder)+----------------------------------------------------------------------------++data InternalState = InternalState+ { _isMaxSteps :: !RemainingSteps+ , _isNow :: !Timestamp+ , _isGState :: !GState+ , _isOperations :: ![InterpreterOp]+ -- ^ Operations to be interpreted when 'TOValidate' is encountered.+ }++makeLenses ''InternalState++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- | Operations supported by this testing engine.+-- Each operation has a corresponding top-level function where its semantics is defined.+-- Usually you shouldn't use this type directly.+data TestOperation+ = TOInterpreterOp !InterpreterOp+ | TOValidate !IntegrationalValidator+ | TOSetMaxSteps !RemainingSteps+ | TOSetNow !Timestamp+ -- | 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 (InterpreterError -> Bool) SuccessValidator +-- | Validator for integrational testing that expects successful execution. type SuccessValidator = (GState -> [GStateUpdate] -> Either Text ()) +type IntegrationalScenarioState = [TestOperation]++-- | A monad inside which integrational tests can be described using+-- do-notation.+type IntegrationalScenarioM = State IntegrationalScenarioState++-- | 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+ -- | Integrational test that executes given operations and validates -- them using given validator. It can fail using 'Expectation' -- capability.-integrationalTestExpectation ::- Timestamp -> RemainingSteps -> [InterpreterOp] -> IntegrationalValidator -> Expectation+-- It starts with 'initGState' and some reasonable dummy values for+-- gas limit and current timestamp. You can update blockchain state+-- by performing some operations.+integrationalTestExpectation :: IntegrationalScenario -> Expectation integrationalTestExpectation = integrationalTest (maybe pass (expectationFailure . toString)) --- | Integrational test that executes given operations and validates--- them using given validator. It can fail using 'Property'--- capability. It can be used with QuickCheck's @forAll@ to make a+-- | Integrational test similar to 'integrationalTestExpectation'.+-- It can fail using 'Property' capability.+-- It can be used with QuickCheck's @forAll@ to make a -- property-based test with arbitrary data.-integrationalTestProperty ::- Timestamp -> RemainingSteps -> [InterpreterOp] -> IntegrationalValidator -> Property+integrationalTestProperty :: IntegrationalScenario -> Property integrationalTestProperty = integrationalTest (maybe succeededProp failedProp) --- | 'integrationalTestExpectation' which uses dummy now and max steps.-simplerIntegrationalTestExpectation :: [InterpreterOp] -> IntegrationalValidator -> Expectation-simplerIntegrationalTestExpectation =- integrationalTestExpectation dummyNow dummyMaxSteps+-- | Originate a contract with given initial storage and balance. Its+-- address is returned.+originate ::+ UntypedContract -> UntypedValue -> Mutez -> IntegrationalScenarioM Address+originate contract value balance =+ mkContractAddress origination <$ putOperation (TOInterpreterOp originateOp)+ where+ origination = (dummyOrigination value contract) {ooBalance = balance}+ originateOp = OriginateOp origination --- | 'integrationalTestProperty' which uses dummy now and max steps.-simplerIntegrationalTestProperty :: [InterpreterOp] -> IntegrationalValidator -> Property-simplerIntegrationalTestProperty =- integrationalTestProperty dummyNow dummyMaxSteps+-- | Transfer tokens to given address.+transfer :: TxData -> Address -> IntegrationalScenarioM ()+transfer txData destination =+ putOperation (TOInterpreterOp $ TransferOp destination txData) -integrationalTest ::- (Maybe Text -> res)- -> Timestamp- -> RemainingSteps- -> [InterpreterOp]- -> IntegrationalValidator- -> res-integrationalTest howToFail now maxSteps operations validator =- validateResult- howToFail- validator- (interpreterPure now maxSteps initGState operations)+-- | Execute all operations that were added to the scenarion since+-- last 'validate' call. If validator fails, the execution will be aborted.+validate :: IntegrationalValidator -> IntegrationalScenario+validate validator = Validated <$ putOperation (TOValidate validator) -validateResult ::- (Maybe Text -> res)- -> IntegrationalValidator- -> Either InterpreterError InterpreterRes- -> res-validateResult howToFail validator result =- case (validator, result) of- (Left validateError, Left err)- | validateError err -> doNotFail- (_, Left err) ->- doFail $ "Unexpected interpreter error: " <> pretty err- (Left _, Right _) ->- doFail $ "Interpreter unexpectedly didn't fail"- (Right validateUpdates, Right ir)- | Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) ->- doFail $- "Updates are incorrect: " +| bad |+ ". Updates are: \n" +|- blockListF (_irUpdates ir) |+ ""- | otherwise -> doNotFail- where- doNotFail = howToFail Nothing- doFail = howToFail . Just+-- | Make all further interpreter calls (which are triggered by the+-- 'validate' function) use given timestamp as the current one.+setNow :: Timestamp -> IntegrationalScenarioM ()+setNow = putOperation . TOSetNow +-- | Make all further interpreter calls (which are triggered by the+-- 'validate' function) use given gas limit.+setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()+setMaxSteps = putOperation . TOSetMaxSteps++putOperation :: TestOperation -> IntegrationalScenarioM ()+putOperation op = id <>= one op+ ---------------------------------------------------------------------------- -- Validators to be used within 'IntegrationalValidator' ---------------------------------------------------------------------------- +-- | 'SuccessValidator' that always passes.+expectAnySuccess :: SuccessValidator+expectAnySuccess _ _ = pass+ -- | Check that storage value is updated for given address. Takes a -- predicate that is used to check the value. -- -- It works even if updates are not filtered (i. e. a value can be -- updated more than once).-expectStorageValue ::+expectStorageUpdate :: Address -> (UntypedValue -> Either Text ()) -> SuccessValidator-expectStorageValue addr predicate _ updates =+expectStorageUpdate addr predicate _ updates = case List.find checkAddr (reverse updates) of Nothing -> Left $ "Storage of " +| addr |+ " is not updated" Just (GSSetStorageValue _ val) -> first (("Storage of " +| addr |+ "is updated incorrectly: ") <>) $ predicate val -- 'checkAddr' ensures that only 'GSSetStorageValue' can be found- Just _ -> error "expectStorageValue: internal error"+ Just _ -> error "expectStorageUpdate: internal error" where checkAddr (GSSetStorageValue addr' _) = addr' == addr checkAddr _ = False --- | Like 'expectStorageValue', but expects a constant.-expectStorageConstant ::+-- | Like 'expectStorageUpdate', but expects a constant.+expectStorageUpdateConst :: Address -> UntypedValue -> SuccessValidator-expectStorageConstant addr expected =- expectStorageValue addr predicate+expectStorageUpdateConst addr expected =+ expectStorageUpdate addr predicate where predicate val | val == expected = pass | otherwise = Left $ "expected " +| expected |+ "" +-- | Check that eventually address has some particular storage value.+expectStorageConst :: Address -> UntypedValue -> SuccessValidator+expectStorageConst addr expected gs _ =+ case gsAddresses gs ^. at addr of+ Just (ASContract cs)+ | csStorage cs == expected -> pass+ | otherwise ->+ Left $ intro +| "its storage is " +| csStorage cs |+ ""+ Just (ASSimple {}) ->+ Left $ intro +| "it's a simple address"+ Nothing -> Left $ intro +| "it's unknown"+ where+ intro = "Expected " +| addr |+ " to have storage " +| expected |+ ", but "+ -- | Check that eventually address has some particular balance. expectBalance :: Address -> Mutez -> SuccessValidator expectBalance addr balance gs _ =@@ -157,7 +221,7 @@ -- For example: -- -- expectBalance bal addr `composeValidators`--- expectStorageConstant addr2 ValueUnit+-- expectStorageUpdateConst addr2 ValueUnit composeValidators :: SuccessValidator -> SuccessValidator@@ -165,8 +229,81 @@ composeValidators val1 val2 gState updates = val1 gState updates >> val2 gState updates +-- | Compose a list of success validators.+composeValidatorsList :: [SuccessValidator] -> SuccessValidator+composeValidatorsList = foldl' composeValidators expectAnySuccess++-- | Check that interpreter failed due to gas exhaustion. expectGasExhaustion :: InterpreterError -> Bool expectGasExhaustion = \case IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True _ -> False++-- | Expect that interpretation of contract with given address ended+-- with [FAILED].+expectMichelsonFailed :: Address -> InterpreterError -> Bool+expectMichelsonFailed addr =+ \case+ IEInterpreterFailed failedAddr (RuntimeFailure {}) -> addr == failedAddr+ _ -> False++----------------------------------------------------------------------------+-- Implementation of the testing engine+----------------------------------------------------------------------------++initIS :: InternalState+initIS = InternalState+ { _isNow = dummyNow+ , _isMaxSteps = dummyMaxSteps+ , _isGState = initGState+ , _isOperations = mempty+ }++integrationalTest ::+ (Maybe Text -> res)+ -> IntegrationalScenario+ -> res+integrationalTest howToFail scenario =+ howToFail $ leftToMaybe $ runExcept (runStateT integrationalTestDo initIS)+ where+ operations = execState scenario []+ integrationalTestDo :: StateT InternalState (Except Text) ()+ integrationalTestDo = mapM_ integrationalTestStep operations++integrationalTestStep :: TestOperation -> StateT InternalState (Except Text) ()+integrationalTestStep =+ \case+ TOInterpreterOp intOp -> isOperations <>= one intOp+ TOValidate validator -> do+ now <- use isNow+ maxSteps <- use isMaxSteps+ gState <- use isGState+ ops <- use isOperations+ mUpdatedGState <-+ lift $ validateResult validator $ interpreterPure now maxSteps gState ops+ isOperations .= mempty+ whenJust mUpdatedGState $ \newGState -> isGState .= newGState+ TOSetNow newNow -> isNow .= newNow+ TOSetMaxSteps newMaxSteps -> isMaxSteps .= newMaxSteps++validateResult ::+ IntegrationalValidator+ -> Either InterpreterError InterpreterRes+ -> Except Text (Maybe GState)+validateResult validator result =+ case (validator, result) of+ (Left validateError, Left err)+ | validateError err -> pure Nothing+ (_, Left err) ->+ doFail $ "Unexpected interpreter error: " <> pretty err+ (Left _, Right _) ->+ doFail $ "Interpreter unexpectedly didn't fail"+ (Right validateUpdates, Right ir)+ | Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) ->+ doFail $+ "Updates are incorrect: " +| bad |+ ". Updates are: \n" +|+ blockListF (_irUpdates ir) |+ ""+ | otherwise -> pure $ Just $ _irGState ir+ where+ doFail = throwError
src/Tezos/Address.hs view
@@ -8,6 +8,7 @@ -- * Formatting , formatAddress , parseAddress+ , unsafeParseAddress ) where import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)@@ -84,6 +85,9 @@ , ")" ] +-- | Parse an address from its human-readable textual representation+-- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or+-- fail if it's invalid. parseAddress :: Text -> Either ParseAddressError Address parseAddress addressText = case parseKeyHash addressText of@@ -91,6 +95,11 @@ Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $ parseContractAddress addressText Right keyHash -> Right (KeyAddress keyHash)++-- | Partial version of 'parseAddress' which assumes that the address+-- is correct. Can be used in tests.+unsafeParseAddress :: HasCallStack => Text -> Address+unsafeParseAddress = either (error . pretty) id . parseAddress data ParseContractAddressError = ParseContractAddressWrongBase58Check
test/Test/Arbitrary.hs view
@@ -7,8 +7,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Test.QuickCheck (Arbitrary(..), Gen, choose, elements, listOf, oneof, vector)+import Test.QuickCheck (Arbitrary(..), Gen, choose, elements, listOf, oneof, suchThatMap, vector) import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..))+import Test.QuickCheck.Instances.Semigroup () import Test.QuickCheck.Instances.Text () import Michelson.Untyped@@ -55,6 +56,12 @@ smallSize :: Gen Int smallSize = choose (0, 3) +smallList :: Arbitrary a => Gen [a]+smallList = smallSize >>= vector++smallList1 :: Arbitrary a => Gen (NonEmpty a)+smallList1 = smallList `suchThatMap` nonEmpty+ instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Contract op) instance (Arbitrary op) => Arbitrary (Contract op) where arbitrary = Contract <$> arbitrary <*> arbitrary <*> arbitrary@@ -204,18 +211,10 @@ , ValueRight <$> arbitrary , ValueSome <$> arbitrary , pure ValueNone- , (do size1 <- smallSize- l1 <- vector size1- pure $ ValueSeq l1- )- , (do size1 <- smallSize- l1 <- vector size1- pure $ ValueMap l1- )- , (do size1 <- smallSize- l1 <- vector size1- pure $ ValueLambda l1- )+ , pure ValueNil+ , ValueSeq <$> smallList1+ , ValueMap <$> smallList1+ , ValueLambda <$> smallList1 ] instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Elt op)
test/Test/Interpreter.hs view
@@ -18,6 +18,7 @@ import Test.Interpreter.CallSelf (selfCallerSpec) import Test.Interpreter.Compare (compareSpec) import Test.Interpreter.Conditionals (conditionalsSpec)+import Test.Interpreter.EnvironmentSpec (environmentSpec) import Test.Interpreter.StringCaller (stringCallerSpec) spec :: Spec@@ -62,6 +63,7 @@ conditionalsSpec stringCallerSpec selfCallerSpec+ environmentSpec specWithTypedContract "contracts/steps_to_quota_test1.tz" $ \contract -> do it "Amount of steps should reduce" $ do
test/Test/Interpreter/CallSelf.hs view
@@ -10,14 +10,14 @@ import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Michelson.Typed-import Michelson.Untyped (OriginationOperation(..), mkContractAddress) import qualified Michelson.Untyped as Untyped import Morley.Aliases (UntypedContract)-import Morley.Runtime (InterpreterOp(..), TxData(..)) import Morley.Runtime.GState import Morley.Test (ContractPropValidator, contractProp, specWithContract) import Morley.Test.Dummy import Morley.Test.Integrational+import Tezos.Address (Address)+import Tezos.Core (unsafeMkMutez) selfCallerSpec :: Spec selfCallerSpec =@@ -69,8 +69,7 @@ prop propertyDescription $ forAll genFixture $ \fixture ->- integrationalTestProperty dummyNow (fMaxSteps fixture)- (operations fixture) (integValidator fixture)+ integrationalTestProperty (integrationalScenario uSelfCaller fixture) where -- Environment for unit test unitContractEnv = dummyContractEnv@@ -85,26 +84,24 @@ "it fails due to gas limit if the number is large, otherwise the " <> "storage is updated to the number of calls" - operations :: Fixture -> [InterpreterOp]- operations fixture = [originateOp, transferOp fixture]-- origination :: OriginationOperation- origination = dummyOrigination (Untyped.ValueInt 0) uSelfCaller- address = mkContractAddress origination- originateOp = OriginateOp origination-- txData :: Fixture -> TxData- txData fixture = TxData+integrationalScenario :: UntypedContract -> Fixture -> IntegrationalScenario+integrationalScenario uSelfCaller fixture = do+ setMaxSteps (fMaxSteps fixture)+ address <- originate uSelfCaller (Untyped.ValueInt 0) (unsafeMkMutez 1)+ let+ txData :: TxData+ txData = TxData { tdSenderAddress = genesisAddress , tdParameter = Untyped.ValueInt (fromIntegral $ fParameter fixture) , tdAmount = minBound }- transferOp fixture = TransferOp address (txData fixture)-- integValidator :: Fixture -> IntegrationalValidator- integValidator fixture+ transfer txData address+ validate (validator address)+ where+ validator :: Address -> IntegrationalValidator+ validator address | fExpectSuccess fixture = let expectedStorage = Untyped.ValueInt (fromIntegral $ fParameter fixture)- in Right $ expectStorageConstant address expectedStorage+ in Right $ expectStorageUpdateConst address expectedStorage | otherwise = Left expectGasExhaustion
+ test/Test/Interpreter/EnvironmentSpec.hs view
@@ -0,0 +1,104 @@+-- | Tests for the 'environment.tz' contract++module Test.Interpreter.EnvironmentSpec+ ( environmentSpec+ ) where++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Test.QuickCheck (Arbitrary(..), choose)+import Test.QuickCheck.Instances.Text ()++import Michelson.Interpret (RemainingSteps(..))+import Michelson.Typed+import qualified Michelson.Untyped as Untyped+import Morley.Aliases (UntypedContract, UntypedValue)+import Morley.Runtime.GState+import Morley.Test (specWithContract)+import Morley.Test.Integrational+import Tezos.Address+import Tezos.Core++environmentSpec :: Spec+environmentSpec =+ specWithContract "contracts/environment.tz" specImpl++data Fixture = Fixture+ { fNow :: !Timestamp+ , fMaxSteps :: !RemainingSteps+ , fPassOriginatedAddress :: !Bool+ , fBalance :: !Mutez+ , fAmount :: !Mutez+ } deriving (Show)++instance Arbitrary Fixture where+ arbitrary = do+ fNow <- timestampFromSeconds @Int <$> choose (100000, 111111)+ fMaxSteps <- RemainingSteps <$> choose (1000, 1200)+ fPassOriginatedAddress <- arbitrary+ fBalance <- unsafeMkMutez <$> choose (1, 1234)+ fAmount <- unsafeMkMutez <$> choose (1, 42)+ return Fixture {..}++shouldExpectFailed :: Fixture -> Bool+shouldExpectFailed fixture =+ or+ [ fBalance fixture > unsafeMkMutez 1000+ , fNow fixture < timestampFromSeconds @Int 100500+ , fPassOriginatedAddress fixture+ , fAmount fixture < unsafeMkMutez 15+ ]++shouldReturn :: Fixture -> UntypedValue+shouldReturn fixture+ | fMaxSteps fixture - consumedGas > 1000 = Untyped.ValueTrue+ | otherwise = Untyped.ValueFalse+ where+ consumedGas = 24++specImpl ::+ (UntypedContract, Contract ('Tc 'CAddress) ('Tc 'CBool))+ -> Spec+specImpl (uEnvironment, _environment) = do+ let scenario = integrationalScenario uEnvironment+ modifyMaxSuccess (min 12) $+ prop description $+ integrationalTestExpectation . scenario+ where+ 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"++integrationalScenario :: UntypedContract -> Fixture -> IntegrationalScenario+integrationalScenario contract fixture = do+ -- First of all let's set desired gas limit and NOW+ setNow $ fNow fixture+ setMaxSteps $ fMaxSteps fixture++ -- Then let's originated the 'environment.tz' contract+ environmentAddress <-+ originate contract Untyped.ValueFalse (fBalance fixture)++ -- And transfer tokens to it+ let+ param+ | fPassOriginatedAddress fixture = environmentAddress+ | otherwise = genesisAddress+ txData = TxData+ { tdSenderAddress = genesisAddress+ , tdParameter = Untyped.ValueString (formatAddress param)+ , tdAmount = fAmount fixture+ }+ 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 environmentAddress+ | otherwise =+ Right $ expectStorageConst environmentAddress $ shouldReturn fixture+ validate validator
test/Test/Interpreter/StringCaller.hs view
@@ -1,4 +1,6 @@--- | Tests for the 'stringCaller.tz' contract.+-- | Tests for the 'stringCaller.tz' contract and its interaction with+-- the 'idString.tz' contract. Both of them have comments describing+-- their behavior. module Test.Interpreter.StringCaller ( stringCallerSpec@@ -9,15 +11,12 @@ import Test.QuickCheck.Instances.Text () import Michelson.Typed-import Michelson.Untyped (OriginationOperation(..), mkContractAddress) import qualified Michelson.Untyped as Untyped-import Morley.Aliases (UntypedContract, UntypedValue)-import Morley.Runtime (InterpreterOp(..), TxData(..))+import Morley.Aliases (UntypedContract) import Morley.Runtime.GState import Morley.Test (specWithContract)-import Morley.Test.Dummy import Morley.Test.Integrational-import Tezos.Address (formatAddress)+import Tezos.Address import Tezos.Core stringCallerSpec :: Spec@@ -32,53 +31,111 @@ -> (UntypedContract, Contract ('Tc 'CString) ('Tc 'CString)) -> Spec specImpl (uStringCaller, _stringCaller) (uIdString, _idString) = do- it "stringCaller calls idString and updates its storage with a constant" $- simplerIntegrationalTestExpectation- (operations newValueConstant)- (Right (updatesValidator newValueConstant))+ let scenario = integrationalScenario uStringCaller uIdString+ let suffix =+ " and properly updates balances. But fails if idString's balance is ≥ \+ \1000 and NOW is ≥ 500"+ it ("stringCaller calls idString and updates its storage with a constant"+ <> suffix) $+ integrationalTestExpectation (scenario constStr) -- The test is trivial, so it's kinda useless to run it many times modifyMaxSuccess (const 2) $- prop "stringCaller calls idString and updates its storage with an arbitrary value" $- \(Untyped.ValueString -> newValue) -> simplerIntegrationalTestProperty- (operations newValue)- (Right (updatesValidator newValue))+ prop ("stringCaller calls idString and updates its storage with an arbitrary value"+ <> suffix) $+ \str -> integrationalTestProperty (scenario str) where- newValueConstant = Untyped.ValueString "caller"+ constStr = "caller" - idStringOrigination :: OriginationOperation- idStringOrigination =- dummyOrigination (Untyped.ValueString "hello") uIdString- originateIdString = OriginateOp idStringOrigination- idStringAddress = mkContractAddress idStringOrigination+integrationalScenario :: UntypedContract -> UntypedContract -> Text -> IntegrationalScenario+integrationalScenario stringCaller idString str = do+ let+ initIdStringBalace = unsafeMkMutez 900+ initStringCallerBalance = unsafeMkMutez 500 - stringCallerOrigination :: OriginationOperation- stringCallerOrigination =- dummyOrigination (Untyped.ValueString $ formatAddress idStringAddress)- uStringCaller- originateStringCaller = OriginateOp stringCallerOrigination- stringCallerAddress = mkContractAddress stringCallerOrigination+ -- Originate both contracts+ idStringAddress <-+ originate idString (Untyped.ValueString "hello") initIdStringBalace+ stringCallerAddress <-+ originate stringCaller (Untyped.ValueString $ formatAddress idStringAddress)+ initStringCallerBalance - txData :: UntypedValue -> TxData- txData newValue = TxData+ -- NOW = 500, so stringCaller shouldn't fail+ setNow (timestampFromSeconds @Int 500)++ -- Transfer 100 tokens to stringCaller, it should transfer 300 tokens+ -- to idString+ let+ newValue = Untyped.ValueString str+ txData = TxData { tdSenderAddress = genesisAddress , tdParameter = newValue- , tdAmount = minBound+ , tdAmount = unsafeMkMutez 100 }- transferToStringCaller newValue =- TransferOp stringCallerAddress (txData newValue)+ transferToStringCaller = transfer txData stringCallerAddress+ transferToStringCaller - operations newValue =- [ originateIdString- , originateStringCaller- , transferToStringCaller newValue- ]+ -- Execute operations and check balances and storage of 'idString'+ do+ let+ -- `stringCaller.tz` transfers 300 mutez.+ -- 'idString.tz' transfers 5 tokens.+ -- Also 100 tokens are transferred from the genesis address.+ expectedStringCallerBalance = unsafeMkMutez (500 - 300 + 100)+ expectedIdStringBalance = unsafeMkMutez (900 + 300 - 5)+ expectedConstAddrBalance = unsafeMkMutez 5 - -- `stringCaller.tz` transfers 2 mutez.- expectedIdStringBalance =- ooBalance idStringOrigination `unsafeAddMutez` unsafeMkMutez 2+ updatesValidator :: SuccessValidator+ updatesValidator = composeValidatorsList+ [ expectStorageUpdateConst idStringAddress newValue+ , expectBalance idStringAddress expectedIdStringBalance+ , expectBalance stringCallerAddress expectedStringCallerBalance+ , expectBalance constAddr expectedConstAddrBalance+ ]+ validate (Right updatesValidator) - updatesValidator :: UntypedValue -> SuccessValidator- updatesValidator newValue =- expectStorageConstant idStringAddress newValue `composeValidators`- expectBalance idStringAddress expectedIdStringBalance+ -- Now let's transfer 100 tokens to stringCaller again.+ transferToStringCaller++ -- This time execution should fail, because idString should fail+ -- because its balance is greater than 1000.+ void $ validate (Left $ expectMichelsonFailed idStringAddress)++ -- We can also send tokens from idString to tz1 address directly+ let+ txDataToConst = TxData+ { tdSenderAddress = idStringAddress+ , tdParameter = Untyped.ValueUnit+ , tdAmount = unsafeMkMutez 200+ }+ transfer txDataToConst constAddr++ -- Let's check balance of idString and tz1 address+ do+ let+ expectedIdStringBalance = unsafeMkMutez (900 + 300 - 5 - 200)+ expectedConstAddrBalance = unsafeMkMutez (5 + 200)++ updatesValidator :: SuccessValidator+ updatesValidator = composeValidatorsList+ [ expectBalance idStringAddress expectedIdStringBalance+ , expectBalance constAddr expectedConstAddrBalance+ ]++ void $ validate (Right updatesValidator)++ -- Now we can transfer to stringCaller again and it should succeed+ -- this time, because the balance of idString 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 @Int 600)+ transferToStringCaller+ validate (Left $ expectMichelsonFailed stringCallerAddress)++-- Address hardcoded in 'idString.tz'.+constAddr :: Address+constAddr = unsafeParseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"
test/Test/Macro.hs view
@@ -2,6 +2,8 @@ ( spec ) where +import qualified Data.List.NonEmpty as NE+ import Morley.Macro import Morley.Types import Test.Hspec (Expectation, Spec, describe, it, shouldBe)@@ -163,11 +165,11 @@ expandedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) parsedLambdaWithMac :: Value ParsedOp- parsedLambdaWithMac = ValueLambda- [MAC (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)]+ parsedLambdaWithMac = ValueLambda $+ one (MAC (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)) expandedLambdaWithMac :: Value Op- expandedLambdaWithMac = ValueLambda+ expandedLambdaWithMac = ValueLambda . NE.fromList $ [ Op {unOp = DIP [Op {unOp = PAIR noAnn noAnn noAnn noAnn}]} , Op {unOp = PAIR noAnn noAnn noAnn noAnn} ]
test/Test/Parser.hs view
@@ -2,6 +2,7 @@ ( spec ) where +import qualified Data.List.NonEmpty as NE import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy) import Text.Megaparsec (parse) @@ -38,12 +39,20 @@ valueParserTest :: Expectation valueParserTest = do+ P.parseNoEnv P.value "" "{}" `shouldBe`+ (Right Mo.ValueNil) P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe`- (Right $ Mo.ValueLambda [Mo.PRIM (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))])+ (Right . Mo.ValueLambda $ NE.fromList+ [Mo.PRIM (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))]+ ) P.parseNoEnv P.value "" "{1; 2}" `shouldBe`- (Right $ Mo.ValueSeq [Mo.ValueInt 1, Mo.ValueInt 2])+ (Right . Mo.ValueSeq $ NE.fromList+ [Mo.ValueInt 1, Mo.ValueInt 2]+ ) P.parseNoEnv P.value "" "{Elt 1 2; Elt 3 4}" `shouldBe`- (Right $ Mo.ValueMap [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)])+ (Right . Mo.ValueMap $ NE.fromList+ [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]+ ) stringLiteralTest :: Expectation stringLiteralTest = do