diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -28,7 +28,10 @@ ## IV: Testing EDSL -Coming soon, see TM-77. +Testing EDSL makes it possible to write tests in Haskell. +It supports both integrational and unit tests. +Tests of both types can use static data or arbitrary data. +There is [a document](/docs/testingEDSL.md) with a detailed description of EDSL and a tutorial about its usage. ## Issue Tracker diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -17,7 +17,7 @@ import Michelson.Untyped hiding (OriginationOperation(..)) import qualified Michelson.Untyped as Un import Morley.Ext (typeCheckMorleyContract) -import Morley.Macro (expandFlattenContract, expandValue) +import Morley.Macro (expandContract, expandValue) import qualified Morley.Parser as P import Morley.Runtime (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer) @@ -37,7 +37,7 @@ data RunOptions = RunOptions { roContractFile :: !(Maybe FilePath) , roDBPath :: !FilePath - , roStorageValue :: !(Value Op) + , roStorageValue :: !Un.UntypedValue , roTxData :: !TxData , roVerbose :: !Bool , roNow :: !(Maybe Timestamp) @@ -53,7 +53,7 @@ , ooDelegate :: !(Maybe KeyHash) , ooSpendable :: !Bool , ooDelegatable :: !Bool - , ooStorageValue :: !(Value Op) + , ooStorageValue :: !Un.UntypedValue , ooBalance :: !Mutez , ooVerbose :: !Bool } @@ -219,12 +219,12 @@ maybeAddDefault pretty defaultValue <> help hInfo -valueOption :: String -> String -> Opt.Parser (Value Op) +valueOption :: String -> String -> Opt.Parser Un.UntypedValue valueOption name hInfo = option (eitherReader parseValue) $ long name <> help hInfo where - parseValue :: String -> Either String (Value Op) + parseValue :: String -> Either String Un.UntypedValue parseValue s = either (Left . mappend "Failed to parse value: " . show) (Right . expandValue) @@ -258,7 +258,7 @@ <*> valueOption "parameter" "Parameter of passed contract" <*> mutezOption (Just minBound) "amount" "Amout sent by a transaction" where - mkTxData :: Address -> Value Op -> Mutez -> TxData + mkTxData :: Address -> UntypedValue -> Mutez -> TxData mkTxData addr param amount = TxData { tdSenderAddress = addr @@ -292,12 +292,12 @@ Parse mFilename hasExpandMacros -> do contract <- readAndParseContract mFilename if hasExpandMacros - then pPrint $ expandFlattenContract contract + then pPrint $ expandContract contract else pPrint contract TypeCheck mFilename _hasVerboseFlag -> do michelsonContract <- prepareContract mFilename void $ either throwM pure $ - (typeCheckMorleyContract . fmap unOp) michelsonContract + typeCheckMorleyContract michelsonContract putTextLn "Contract is well-typed" Run RunOptions {..} -> do michelsonContract <- prepareContract roContractFile diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: morley -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Developer tools for the Michelson Language description: A library to make writing smart contracts in Michelson — the smart contract @@ -23,9 +23,6 @@ location: git@gitlab.com:camlcase-dev/morley.git library --- build-tool-depends: autoexporter:autoexporter - build-tools: autoexporter - hs-source-dirs: src default-language: Haskell2010 exposed-modules: Michelson.Interpret @@ -33,7 +30,6 @@ , Michelson.Typed , Michelson.Typed.Value , Michelson.Untyped - , Morley.Aliases , Morley.Default , Morley.Lexer , Morley.Macro @@ -70,6 +66,7 @@ , Michelson.Typed.Polymorphic , Michelson.Typed.Sing , Michelson.Typed.T + , Michelson.Untyped.Aliases , Michelson.Untyped.Annotation , Michelson.Untyped.Contract , Michelson.Untyped.Instr @@ -102,7 +99,6 @@ , parser-combinators >= 1.0.0 , directory , singletons - , syb , mtl , vinyl ghc-options: -Weverything @@ -226,6 +222,7 @@ , Test.Interpreter.CallSelf , Test.Interpreter.Compare , Test.Interpreter.Conditionals + , Test.Interpreter.EnvironmentSpec , Test.Interpreter.StringCaller , Test.Macro , Test.Ext diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs --- a/src/Michelson/Interpret.hs +++ b/src/Michelson/Interpret.hs @@ -56,7 +56,7 @@ -- ^ Number of steps after which execution unconditionally terminates. , ceBalance :: !Mutez -- ^ Current amount of mutez of the current contract. - , ceContracts :: Map Address (U.Contract U.Op) + , ceContracts :: Map Address U.UntypedContract -- ^ Mapping from existing contracts' addresses to their executable -- representation. , ceSelf :: !Address @@ -79,7 +79,7 @@ deriving instance Show MichelsonFailed -instance (ConversibleExt, Buildable U.Instr) => Buildable MichelsonFailed where +instance (ConversibleExt, Buildable U.ExpandedInstr) => Buildable MichelsonFailed where build = \case MichelsonFailedWith (v :: Val Instr t) -> @@ -104,9 +104,9 @@ | UnexpectedStorageType Text deriving (Generic) -deriving instance (Buildable U.Instr, Show s) => Show (InterpretUntypedError s) +deriving instance (Buildable U.ExpandedInstr, Show s) => Show (InterpretUntypedError s) -instance (ConversibleExt, Buildable U.Instr, Buildable s) => Buildable (InterpretUntypedError s) where +instance (ConversibleExt, Buildable U.ExpandedInstr, Buildable s) => Buildable (InterpretUntypedError s) where build = genericF data InterpretUntypedResult s where @@ -122,18 +122,18 @@ -- | Interpret a contract without performing any side effects. interpretUntyped - :: forall s . (ExtC, Aeson.ToJSON U.InstrExtU) + :: forall s . (ExtC, Aeson.ToJSON U.ExpandedInstrExtU) => TcExtHandler - -> U.Contract U.Op - -> U.Value U.Op - -> U.Value U.Op + -> U.UntypedContract + -> U.UntypedValue + -> U.UntypedValue -> InterpreterEnv s -> s -> Either (InterpretUntypedError s) (InterpretUntypedResult s) interpretUntyped typeCheckHandler U.Contract{..} paramU initStU env initState = do (SomeContract (instr :: Contract cp st) _ _) <- first IllTypedContract $ typeCheckContract typeCheckHandler - (U.Contract para stor (U.unOp <$> code)) + (U.Contract para stor code) paramV :::: ((_ :: Sing cp1), _) <- first IllTypedParam $ runTypeCheckT typeCheckHandler para $ typeCheckVal paramU (fromUType para) @@ -162,7 +162,7 @@ (Either MichelsonFailed ([Operation Instr], Val Instr st), InterpreterState s) interpret - :: (ExtC, Aeson.ToJSON U.InstrExtU, Typeable cp, Typeable st) + :: (ExtC, Aeson.ToJSON U.ExpandedInstrExtU, Typeable cp, Typeable st) => Contract cp st -> Val Instr cp -> Val Instr st @@ -213,7 +213,7 @@ -- | Function to change amount of remaining steps stored in State monad runInstr - :: (ExtC, Aeson.ToJSON U.InstrExtU, Typeable inp) + :: (ExtC, Aeson.ToJSON U.ExpandedInstrExtU, Typeable inp) => Instr inp out -> Rec (Val Instr) inp -> EvalOp state (Rec (Val Instr) out) @@ -229,14 +229,14 @@ runInstrNoGas :: forall a b state . - (ExtC, Aeson.ToJSON U.InstrExtU, Typeable a) + (ExtC, Aeson.ToJSON U.ExpandedInstrExtU, Typeable a) => T.Instr a b -> Rec (Val T.Instr) a -> EvalOp state (Rec (Val T.Instr) b) runInstrNoGas = runInstrImpl runInstrNoGas -- | Function to interpret Michelson instruction(s) against given stack. runInstrImpl :: forall state . - (ExtC, Aeson.ToJSON U.InstrExtU) + (ExtC, Aeson.ToJSON U.ExpandedInstrExtU) => (forall inp1 out1 . Typeable inp1 => Instr inp1 out1 -> Rec (Val Instr) inp1 @@ -252,6 +252,7 @@ runInstrImpl _ (Ext nop) r = do handler <- asks ieItHandler r <$ handler (nop, SomeItStack r) +runInstrImpl runner (Nested sq) r = runInstrImpl runner sq r runInstrImpl _ DROP (_ :& r) = pure $ r runInstrImpl _ DUP (a :& r) = pure $ a :& a :& r runInstrImpl _ SWAP (a :& b :& r) = pure $ b :& a :& r 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 @@ -150,7 +150,7 @@ checkEqT :: forall a b ts . (Typeable a, Typeable b, Typeable ts) - => Un.Instr + => Un.ExpandedInstr -> HST ts -> Text -> Either TCError (a :~: b) @@ -159,7 +159,7 @@ assertEqT :: forall a b ts . (Typeable a, Typeable b, Typeable ts) - => Un.Instr + => Un.ExpandedInstr -> HST ts -> Either TCError (a :~: b) assertEqT instr i = checkEqT instr i "unexpected" @@ -174,29 +174,39 @@ <> show (typeRep (Proxy @b)) ) pure eqT -typeCheckInstrErr :: Un.Instr -> SomeHST -> Text -> Either TCError a +typeCheckInstrErr :: Un.ExpandedInstr -> SomeHST -> Text -> Either TCError a typeCheckInstrErr = Left ... TCFailedOnInstr -typeCheckInstrErrM :: Un.Instr -> SomeHST -> Text -> TypeCheckT a +typeCheckInstrErrM :: Un.ExpandedInstr -> SomeHST -> Text -> TypeCheckT a typeCheckInstrErrM = throwError ... TCFailedOnInstr typeCheckImpl :: TcInstrHandler - -> [Un.Instr] + -> [Un.ExpandedOp] -> SomeHST -> TypeCheckT SomeInstr -typeCheckImpl tcInstr [a] t = tcInstr a t -typeCheckImpl tcInstr (p_ : (r : rs)) (SomeHST (a :: HST a)) = do - tcInstr p_ (SomeHST a) >>= \case - p ::: ((_ :: HST a'), (b :: HST b)) -> - typeCheckImpl tcInstr (r : rs) (SomeHST b) >>= \case - q ::: ((_ :: HST b'), c) -> do - Refl <- liftEither $ eqT' @a @a' `onLeft` TCOtherError - Refl <- liftEither $ eqT' @b @b' `onLeft` TCOtherError - pure $ (Seq p q) ::: (a, c) +typeCheckImpl tcInstr instrs t@(SomeHST (a :: HST a)) = + case instrs of + [Un.PrimEx i] -> tcInstr i t + (Un.SeqEx sq : rs) -> typeCheckImplDo (typeCheckImpl tcInstr sq) Nested rs + (Un.PrimEx p_ : rs) -> typeCheckImplDo (tcInstr p_) id rs + [] -> pure $ Nop ::: (a, a) + where + typeCheckImplDo + :: (SomeHST -> TypeCheckT SomeInstr) + -> (forall inp out . Instr inp out -> Instr inp out) + -> [Un.ExpandedOp] + -> TypeCheckT SomeInstr + typeCheckImplDo f wrap rs = + f t >>= \case + p ::: ((_ :: HST a'), (b :: HST b)) -> + typeCheckImpl tcInstr rs (SomeHST b) >>= \case + q ::: ((_ :: HST b'), c) -> do + Refl <- liftEither $ eqT' @a @a' `onLeft` TCOtherError + Refl <- liftEither $ eqT' @b @b' `onLeft` TCOtherError + pure $ Seq (wrap p) q ::: (a, c) + SiFail -> pure SiFail SiFail -> pure SiFail - SiFail -> pure SiFail -typeCheckImpl _ [] (SomeHST s) = pure $ Nop ::: (s, s) -------------------------------------------- -- Some generic instruction implementation @@ -206,7 +216,7 @@ memImpl :: forall (q :: CT) (c :: T) ts . (Typeable ts, Typeable q, Typeable (MemOpKey c), MemOp c) - => Un.Instr + => Un.ExpandedInstr -> HST ('Tc q ': c ': ts) -> VarAnn -> TcResult @@ -222,7 +232,7 @@ , Typeable (GetOpVal c) , SingI (GetOpVal c) ) - => Un.Instr + => Un.ExpandedInstr -> HST (getKey ': c ': rs) -> Sing (GetOpVal c) -> Notes (GetOpVal c) @@ -239,7 +249,7 @@ updImpl :: forall c updKey updParams rs . (UpdOp c, Typeable (UpdOpKey c), Typeable (UpdOpParams c)) - => Un.Instr + => Un.ExpandedInstr -> HST (updKey ': updParams ': c ': rs) -> TcResult updImpl instr i@(_ ::& _ ::& crs) = do 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 @@ -45,20 +45,19 @@ Lsl, Lsr, Lt, MapOp(..), Neg, Neq, Not, Notes(..), Notes'(..), Or, Sing(..), T(..), Val(..), Xor, converge, convergeAnns, extractNotes, fromUType, mkNotes, notesCase, orAnn, withSomeSingCT, withSomeSingT, ( # )) - import qualified Michelson.Untyped as Un import Michelson.Untyped.Annotation (VarAnn) typeCheckContract :: ExtC => TcExtHandler - -> Un.Contract Un.Instr + -> Un.UntypedContract -> Either TCError SomeContract typeCheckContract nh c = runTypeCheckT nh (Un.para c) $ typeCheckContractImpl c typeCheckContractImpl :: ExtC - => Un.Contract Un.Instr + => Un.UntypedContract -> TypeCheckT SomeContract typeCheckContractImpl (Un.Contract mParam mStorage pCode) = do code <- maybe (throwError $ TCOtherError "no instructions in contract code") @@ -98,7 +97,7 @@ -- | Like 'typeCheck', but for non-empty lists. typeCheckNE :: ExtC - => NonEmpty Un.Instr + => NonEmpty Un.ExpandedOp -> SomeHST -> TypeCheckT SomeInstr typeCheckNE (x :| xs) = typeCheckImpl typeCheckInstr (x : xs) @@ -113,7 +112,7 @@ -- As a second argument, @typeCheckList@ accepts input stack type representation. typeCheckList :: ExtC - => [Un.Instr] + => [Un.ExpandedOp] -> SomeHST -> TypeCheckT SomeInstr typeCheckList = typeCheckImpl typeCheckInstr @@ -132,7 +131,7 @@ -- error. typeCheckVal :: ExtC - => Un.Value Un.Op + => Un.UntypedValue -> T -> TypeCheckT SomeVal typeCheckVal = typeCheckValImpl typeCheckInstr @@ -301,7 +300,7 @@ typeCheckInstr instr@(Un.MAP vn mp) (SomeHST i@((STList v, ns, _vn) ::& rs) ) = do let vns = notesCase NStar (\(NTList _ v') -> v') ns - typeCheckList (Un.unOp <$> mp) + typeCheckList mp (SomeHST $ (v, vns, def) ::& rs) >>= \case SiFail -> pure SiFail someInstr@(_ ::: (_, (out :: HST out))) -> @@ -315,8 +314,7 @@ typeCheckInstr instr@(Un.MAP vn mp) (SomeHST i@((STMap k v, ns, _vn) ::& rs) ) = do let (kns, vns) = notesCase (def, NStar) (\(NTMap _ k' v') -> (k', v')) ns pns = mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns - typeCheckList (Un.unOp <$> mp) - (SomeHST $ ((STPair (STc k) v), pns, def) ::& rs) >>= \case + typeCheckList mp (SomeHST $ ((STPair (STc k) v), pns, def) ::& rs) >>= \case SiFail -> pure SiFail someInstr@(_ ::: (_, (out :: HST out))) -> case out of @@ -368,7 +366,7 @@ typeCheckInstr instr@(Un.LOOP is) (SomeHST i@((STc SCBool, _, _) ::& (rs :: HST rs)) ) = do - typeCheckList (fmap Un.unOp is) (SomeHST rs) >>= \case + typeCheckList is (SomeHST rs) >>= \case SiFail -> pure SiFail subI ::: ((_ :: HST rs'), (o :: HST o)) -> liftEither $ do Refl <- assertEqT @rs @rs' instr i @@ -387,7 +385,7 @@ ::& (rs :: HST rs)) ) = do let (an, bn, avn, bvn) = deriveNsOr ons ovn ait = (at, an, avn) ::& rs - typeCheckList (fmap Un.unOp is) (SomeHST ait) >>= \case + typeCheckList is (SomeHST ait) >>= \case SiFail -> pure SiFail subI ::: ((_ :: HST rs'), (o :: HST o)) -> liftEither $ do Refl <- assertEqT @(a ': rs) @rs' instr i @@ -425,7 +423,7 @@ "lambda is given argument with wrong type: " <> m typeCheckInstr instr@(Un.DIP is) (SomeHST i@(a ::& (s :: HST s))) = - typeCheckList (fmap Un.unOp is) (SomeHST s) >>= \case + typeCheckList is (SomeHST s) >>= \case SiFail -> pure SiFail subI ::: ((_ :: HST s'), t) -> liftEither $ do Refl <- assertEqT @s @s' instr i @@ -623,7 +621,7 @@ ::& (STc SCMutez, _, _) ::& ((_ :: Sing g), gn, _) ::& rs)) = do (SomeContract (contr :: Contract i' g') _ out) <- - flip withExceptT (typeCheckContractImpl $ fmap Un.unOp contract) + flip withExceptT (typeCheckContractImpl contract) (\err -> TCFailedOnInstr instr (SomeHST i) ("failed to type check contract: " <> show err)) liftEither $ do @@ -694,16 +692,16 @@ Instr bfi s' -> Instr (cond ': rs) s' ) - -> ([Un.Op] -> [Un.Op] -> Un.Instr) - -> [Un.Op] - -> [Un.Op] + -> ([Un.ExpandedOp] -> [Un.ExpandedOp] -> Un.ExpandedInstr) + -> [Un.ExpandedOp] + -> [Un.ExpandedOp] -> HST bti -> HST bfi -> HST (cond ': rs) -> TypeCheckT SomeInstr genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) = - liftA2 (,) (typeCheckList (Un.unOp <$> mbt) (SomeHST bti)) - (typeCheckList (Un.unOp <$> mbf) (SomeHST bfi)) >>= liftEither . \case + liftA2 (,) (typeCheckList mbt (SomeHST bti)) + (typeCheckList mbf (SomeHST bfi)) >>= liftEither . \case (p ::: ((_ :: HST pi), (po :: HST po)), q ::: ((_ :: HST qi), (qo :: HST qo))) -> do Refl <- assertEqT @bti @pi instr i Refl <- assertEqT @bfi @qi instr i @@ -731,7 +729,7 @@ , Typeable (MapOpInp c) , Typeable (MapOpRes c b) ) - => Un.Instr + => Un.ExpandedInstr -> SomeInstr -> HST (c ': rs) -> (forall v' . (Typeable v', SingI v') => @@ -761,13 +759,13 @@ ) => Sing (IterOpEl c) -> Notes (IterOpEl c) - -> Un.Instr - -> NonEmpty Un.Op + -> Un.ExpandedInstr + -> NonEmpty Un.ExpandedOp -> HST (c ': rs) -> TypeCheckT SomeInstr iterImpl et en instr mp i@((_, _, lvn) ::& rs) = do let evn = deriveVN "elt" lvn - typeCheckNE (fmap Un.unOp mp) (SomeHST ((et, en, evn) ::& rs)) >>= \case + typeCheckNE mp (SomeHST ((et, en, evn) ::& rs)) >>= \case SiFail -> pure SiFail subI ::: ((_ :: HST i), (o :: HST o)) -> liftEither $ do Refl <- assertEqT @i @(IterOpEl c ': rs) instr i @@ -781,14 +779,15 @@ , ExtC , SingI it, SingI ot ) - => Un.Instr - -> [Un.Op] -> VarAnn + => Un.ExpandedInstr + -> [Un.ExpandedOp] + -> VarAnn -> Sing it -> Notes it -> Sing ot -> Notes ot -> HST ts -> TypeCheckT SomeInstr lamImpl instr is vn it ins ot ons i = do - typeCheckList (fmap Un.unOp is) (SomeHST $ (it, ins, def) ::& SNil) >>= + typeCheckList is (SomeHST $ (it, ins, def) ::& SNil) >>= \case SiFail -> pure SiFail lam ::: ((_ :: HST li), (lo :: HST lo)) -> liftEither $ do 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 @@ -123,11 +123,11 @@ -- | Type check error data TCError = - TCFailedOnInstr U.Instr SomeHST Text - | TCFailedOnValue (U.Value U.Op) T Text + TCFailedOnInstr U.ExpandedInstr SomeHST Text + | TCFailedOnValue U.UntypedValue T Text | TCOtherError Text -instance Buildable U.Instr => Buildable TCError where +instance Buildable U.ExpandedInstr => Buildable TCError where build = \case TCFailedOnInstr instr (SomeHST t) custom -> "Error checking expression " +| instr @@ -140,22 +140,23 @@ TCOtherError e -> "Error occurred during type check: " +| e |+ "" -instance Buildable U.Instr => Show TCError where +instance Buildable U.ExpandedInstr => Show TCError where show = pretty -instance Buildable U.Instr => Exception TCError +instance Buildable U.ExpandedInstr => Exception TCError -- | State for type checking @nop@ -type TcExtFrames = [(U.InstrExtU, SomeHST)] +type TcExtFrames = [(U.ExpandedInstrExtU, SomeHST)] -- | Constraints on InstrExtT and untyped Instr -- which are required for type checking type ExtC = ( Show InstrExtT - , Eq U.InstrExtU + , Eq U.ExpandedInstrExtU , Typeable InstrExtT - , Buildable U.Instr - , ConversibleExt) + , Buildable U.ExpandedInstr + , ConversibleExt + ) type TypeCheckT a = ExceptT TCError @@ -165,7 +166,7 @@ -- TypeCheckT is used because inside -- inside of TEST_ASSERT could be PRINT/STACKTYPE/etc extended instructions. type TcExtHandler - = U.InstrExtU -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe InstrExtT) + = U.ExpandedInstrExtU -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe InstrExtT) -- | The typechecking state data TypeCheckEnv = TypeCheckEnv @@ -180,6 +181,6 @@ type TcResult = Either TCError SomeInstr type TcInstrHandler - = U.Instr + = U.ExpandedInstr -> SomeHST -> TypeCheckT SomeInstr 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 @@ -69,9 +69,9 @@ -- that is interpreted as input of wrong type and type check finishes with -- error. typeCheckValImpl - :: (Show InstrExtT, ConversibleExt, Eq Un.InstrExtU) + :: (Show InstrExtT, ConversibleExt, Eq Un.ExpandedInstrExtU) => TcInstrHandler - -> Un.Value Un.Op + -> Un.UntypedValue -> T -> TypeCheckT SomeVal typeCheckValImpl _ mv t@(Tc ct) = @@ -154,7 +154,7 @@ typeCheckValImpl tcDo v t@(TLambda mi mo) = do mp <- case v of Un.ValueNil -> pure [] - Un.ValueLambda mp -> pure $ fmap Un.unOp (toList mp) + Un.ValueLambda mp -> pure $ toList mp _ -> throwError $ TCFailedOnValue v t "" withSomeSingT mi $ \(it :: Sing it) -> @@ -183,12 +183,13 @@ typeCheckValImpl _ v t = throwError $ TCFailedOnValue v t "" typeCheckValsImpl - :: forall t . (Typeable t, Show InstrExtT, ConversibleExt, Eq Un.InstrExtU) + :: forall t . (Typeable t, Show InstrExtT, ConversibleExt, Eq Un.ExpandedInstrExtU) => TcInstrHandler - -> [Un.Value Un.Op] + -> [Un.UntypedValue] -> T -> TypeCheckT ([Val Instr t], Notes t) -typeCheckValsImpl tcDo mvs t = foldM check ([], NStar) mvs +typeCheckValsImpl tcDo mvs t = + fmap (first reverse) $ foldM check ([], NStar) mvs where check (res, ns) mv = do v :::: ((_ :: Sing t'), vns) <- typeCheckValImpl tcDo mv t diff --git a/src/Michelson/Typed.hs b/src/Michelson/Typed.hs --- a/src/Michelson/Typed.hs +++ b/src/Michelson/Typed.hs @@ -1,1 +1,14 @@ -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Michelson.Typed + ( module Exports + ) where + +import Michelson.Typed.Annotation as Exports +import Michelson.Typed.Arith as Exports +import Michelson.Typed.Convert as Exports +import Michelson.Typed.CValue as Exports +import Michelson.Typed.Extract as Exports +import Michelson.Typed.Instr as Exports +import Michelson.Typed.Polymorphic as Exports +import Michelson.Typed.Sing as Exports +import Michelson.Typed.T as Exports +import Michelson.Typed.Value as Exports diff --git a/src/Michelson/Typed/Convert.hs b/src/Michelson/Typed/Convert.hs --- a/src/Michelson/Typed/Convert.hs +++ b/src/Michelson/Typed/Convert.hs @@ -26,11 +26,11 @@ class Conversible ext1 ext2 where convert :: ext1 -> ext2 -type ConversibleExt = Conversible (ExtT Instr) (Un.ExtU Un.InstrAbstract Un.Op) +type ConversibleExt = Conversible (ExtT Instr) (Un.ExtU Un.InstrAbstract Un.ExpandedOp) convertContract :: forall param store . (SingI param, SingI store, ConversibleExt) - => Contract param store -> Un.Contract Un.Op + => Contract param store -> Un.UntypedContract convertContract contract = Un.Contract { para = toUType $ fromSingT (sing @param) @@ -43,7 +43,7 @@ -- -- VOp cannot be represented in @Value@ from untyped types, so calling this function -- on it will cause an error -unsafeValToValue :: (ConversibleExt, HasCallStack) => Val Instr t -> Un.Value Un.Op +unsafeValToValue :: (ConversibleExt, HasCallStack) => Val Instr t -> Un.UntypedValue unsafeValToValue = fromMaybe (error err) . valToOpOrValue where err = @@ -54,7 +54,7 @@ valToOpOrValue :: forall t . ConversibleExt => Val Instr t - -> Maybe (Un.Value Un.Op) + -> Maybe Un.UntypedValue valToOpOrValue = \case VC cVal -> Just $ cValToValue cVal VKey b -> Just $ Un.ValueString $ formatPublicKey b @@ -81,7 +81,7 @@ where valueList ctor = maybe Un.ValueNil ctor . nonEmpty -cValToValue :: CVal t -> Un.Value Un.Op +cValToValue :: CVal t -> Un.UntypedValue cValToValue cVal = case cVal of CvInt i -> Un.ValueInt i CvNat i -> Un.ValueInt $ toInteger i @@ -94,19 +94,22 @@ CvTimestamp t -> Un.ValueString $ show t CvAddress a -> Un.ValueString $ formatAddress a -instrToOps :: ConversibleExt => Instr inp out -> [Un.Op] -instrToOps instr = Un.Op <$> handleInstr instr +instrToOps :: ConversibleExt => Instr inp out -> [Un.ExpandedOp] +instrToOps instr = case instr of + Nested sq -> one $ Un.SeqEx $ instrToOps sq + i -> Un.PrimEx <$> handleInstr i where - handleInstr :: Instr inp out -> [Un.Instr] + handleInstr :: Instr inp out -> [Un.ExpandedInstr] handleInstr (Seq i1 i2) = handleInstr i1 <> handleInstr i2 handleInstr Nop = [] handleInstr (Ext nop) = [Un.EXT $ convert nop] + handleInstr (Nested _) = error "impossible" handleInstr DROP = [Un.DROP] handleInstr DUP = [Un.DUP Un.noAnn] handleInstr SWAP = [Un.SWAP] handleInstr i@(PUSH val) = handle i where - handle :: Instr inp1 (t ': s) -> [Un.Instr] + handle :: Instr inp1 (t ': s) -> [Un.ExpandedInstr] handle (PUSH _ :: Instr inp1 (t ': s)) = let value = unsafeValToValue val --- ^ safe because PUSH cannot have operation as argument @@ -114,7 +117,7 @@ handle _ = error "unexcepted call" handleInstr i@NONE = handle i where - handle :: Instr inp1 ('TOption a ': inp1) -> [Un.Instr] + handle :: Instr inp1 ('TOption a ': inp1) -> [Un.ExpandedInstr] handle (NONE :: Instr inp1 ('TOption a ': inp1)) = [Un.NONE Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))] handle _ = error "unexcepted call" @@ -126,13 +129,13 @@ handleInstr CDR = [Un.CDR Un.noAnn Un.noAnn] handleInstr i@LEFT = handle i where - handle :: Instr (a ': s) ('TOr a b ': s) -> [Un.Instr] + handle :: Instr (a ': s) ('TOr a b ': s) -> [Un.ExpandedInstr] handle (LEFT :: Instr (a ': s) ('TOr a b ': s)) = [Un.LEFT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @b))] handle _ = error "unexcepted call" handleInstr i@(RIGHT) = handle i where - handle :: Instr (b ': s) ('TOr a b ': s) -> [Un.Instr] + handle :: Instr (b ': s) ('TOr a b ': s) -> [Un.ExpandedInstr] handle (RIGHT :: Instr (b ': s) ('TOr a b ': s)) = [Un.RIGHT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))] handle _ = error "unexcepted call" @@ -140,7 +143,7 @@ handleInstr (IF_RIGHT i1 i2) = [Un.IF_RIGHT (instrToOps i1) (instrToOps i2)] handleInstr i@(NIL) = handle i where - handle :: Instr s ('TList p ': s) -> [Un.Instr] + handle :: Instr s ('TList p ': s) -> [Un.ExpandedInstr] handle (NIL :: Instr s ('TList p ': s)) = [Un.NIL Un.noAnn Un.noAnn (toUType $ fromSingT (sing @p))] handle _ = error "unexcepted call" @@ -149,13 +152,13 @@ handleInstr SIZE = [Un.SIZE Un.noAnn] handleInstr i@EMPTY_SET = handle i where - handle :: Instr s ('TSet e ': s) -> [Un.Instr] + handle :: Instr s ('TSet e ': s) -> [Un.ExpandedInstr] handle (EMPTY_SET :: Instr s ('TSet e ': s)) = [Un.EMPTY_SET Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @e)) Un.noAnn)] handle _ = error "unexcepted call" handleInstr i@EMPTY_MAP = handle i where - handle :: Instr s ('TMap a b ': s) -> [Un.Instr] + handle :: Instr s ('TMap a b ': s) -> [Un.ExpandedInstr] handle (EMPTY_MAP :: Instr s ('TMap a b ': s)) = [Un.EMPTY_MAP Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @a)) Un.noAnn) (toUType $ fromSingT (sing @b)) @@ -171,20 +174,20 @@ handleInstr (LOOP_LEFT op) = [Un.LOOP_LEFT (instrToOps op)] handleInstr i@(LAMBDA l) = handle i where - handle :: Instr s ('TLambda i o ': s) -> [Un.Instr] + handle :: Instr s ('TLambda i o ': s) -> [Un.ExpandedInstr] handle (LAMBDA _ :: Instr s ('TLambda i o ': s)) = [Un.LAMBDA Un.noAnn (toUType $ fromSingT (sing @i)) (toUType $ fromSingT (sing @i)) (convertLambdaBody l) ] handle _ = error "unexcepted call" - convertLambdaBody :: Val Instr ('TLambda i o) -> [Un.Op] + convertLambdaBody :: Val Instr ('TLambda i o) -> [Un.ExpandedOp] convertLambdaBody (VLam ops) = instrToOps ops handleInstr EXEC = [Un.EXEC Un.noAnn] handleInstr (DIP op) = [Un.DIP (instrToOps op)] handleInstr FAILWITH = [Un.FAILWITH] handleInstr i@(CAST) = handle i where - handle :: Instr (a ': s) (a ': s) -> [Un.Instr] + handle :: Instr (a ': s) (a ': s) -> [Un.ExpandedInstr] handle (CAST :: Instr (a ': s) (a ': s)) = [Un.CAST Un.noAnn (toUType $ fromSingT (sing @a))] handle _ = error "unexcepted call" @@ -192,7 +195,7 @@ handleInstr PACK = [Un.PACK Un.noAnn] handleInstr i@(UNPACK) = handle i where - handle :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) -> [Un.Instr] + handle :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) -> [Un.ExpandedInstr] handle (UNPACK :: Instr ('Tc 'CBytes ': s) ('TOption a ': s)) = [Un.UNPACK Un.noAnn (toUType $ fromSingT (sing @a))] handle _ = error "unexcepted call" @@ -224,7 +227,7 @@ handleInstr i@CONTRACT = handle i where handle :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s) - -> [Un.Instr] + -> [Un.ExpandedInstr] handle (CONTRACT :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)) = [Un.CONTRACT Un.noAnn (toUType $ fromSingT (sing @p))] handle _ = error "unexcepted call" @@ -236,7 +239,7 @@ where handle :: Instr ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash) ': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s) - ('TOperation ': 'Tc 'CAddress ': s) -> [Un.Instr] + ('TOperation ': 'Tc 'CAddress ': s) -> [Un.ExpandedInstr] handle (CREATE_CONTRACT2 ops :: Instr ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash) ': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s) @@ -265,5 +268,5 @@ -- We can also move this convertion to the place where `Instr` is defined, -- but then there will be a very large module (as we'll have to move a lot of -- stuff as well). -instance (ConversibleExt, Eq Un.InstrExtU) => Eq (Instr inp out) where +instance (ConversibleExt, Eq Un.ExpandedInstrExtU) => Eq (Instr inp out) where i1 == i2 = instrToOps i1 == instrToOps i2 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 @@ -55,8 +55,11 @@ -- | Nop operation. Missing in Michelson spec, added to parse construction -- like `IF {} { SWAP; DROP; }`. Nop :: Instr s s - Ext :: ExtT Instr -> Instr s s + -- | Nested wrapper is going to wrap a sequence of instructions with { }. + -- It is crucial because serialisation of a contract + -- depends on precise structure of its code. + Nested :: Instr inp out -> Instr inp out DROP :: Instr (a ': s) s DUP :: Instr (a ': s) (a ': a ': s) 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 @@ -137,10 +137,6 @@ evalConcat (VC (CvBytes b1)) (VC (CvBytes b2)) = (VC . CvBytes) (b1 <> b2) evalConcat' l = (VC . CvBytes) $ foldr (<>) mempty (map (\(VC (CvBytes b)) -> b) l) -instance ConcatOp ('TList t) where - evalConcat (VList l1) (VList l2) = VList $ l1 <> l2 - evalConcat' l = - VList $ concat $ map (\(VList l') -> l') l class SliceOp (c :: T) where evalSlice :: Natural -> Natural -> Val cp c -> Maybe (Val cp c) diff --git a/src/Michelson/Untyped.hs b/src/Michelson/Untyped.hs --- a/src/Michelson/Untyped.hs +++ b/src/Michelson/Untyped.hs @@ -1,1 +1,10 @@ -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Michelson.Untyped + ( module Exports + ) where + +import Michelson.Untyped.Aliases as Exports +import Michelson.Untyped.Annotation as Exports +import Michelson.Untyped.Contract as Exports +import Michelson.Untyped.Instr as Exports +import Michelson.Untyped.Type as Exports +import Michelson.Untyped.Value as Exports diff --git a/src/Michelson/Untyped/Aliases.hs b/src/Michelson/Untyped/Aliases.hs new file mode 100644 --- /dev/null +++ b/src/Michelson/Untyped/Aliases.hs @@ -0,0 +1,13 @@ +-- | Some simple aliases for Michelson types. + +module Michelson.Untyped.Aliases + ( UntypedContract + , UntypedValue + ) where + +import qualified Michelson.Untyped.Instr as Untyped +import qualified Michelson.Untyped.Value as Untyped +import qualified Michelson.Untyped.Contract as Untyped + +type UntypedValue = Untyped.Value Untyped.ExpandedOp +type UntypedContract = Untyped.Contract Untyped.ExpandedOp 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 @@ -4,10 +4,13 @@ module Michelson.Untyped.Instr ( InstrAbstract (..) - , Instr , Op (..) + , Instr + , ExpandedOp (..) + , ExpandedInstr , ExtU , InstrExtU + , ExpandedInstrExtU -- * Contract's address , OriginationOperation (..) @@ -19,6 +22,7 @@ import Data.Data (Data(..)) import qualified Data.Kind as K import Formatting.Buildable (Buildable) +import Fmt (Buildable(build), genericF) import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, VarAnn) import Michelson.Untyped.Contract (Contract) @@ -41,6 +45,25 @@ deriving instance Buildable Instr => Buildable Op ------------------------------------- +-- Types after macroexpander +------------------------------------- + +type ExpandedInstrExtU = ExtU InstrAbstract ExpandedOp +type ExpandedInstr = InstrAbstract ExpandedOp + +data ExpandedOp + = PrimEx ExpandedInstr + | SeqEx [ExpandedOp] + deriving stock (Generic) + +deriving instance Eq ExpandedInstr => Eq ExpandedOp +deriving instance Show ExpandedInstr => Show ExpandedOp +deriving instance Data ExpandedInstr => Data ExpandedOp + +instance Buildable ExpandedInstr => Buildable ExpandedOp where + build = genericF + +------------------------------------- -- Abstract instruction ------------------------------------- @@ -167,20 +190,20 @@ -- ^ Whether the contract is delegatable. , ooBalance :: !Mutez -- ^ Initial balance of the contract. - , ooStorage :: !(Value Op) + , ooStorage :: !(Value ExpandedOp) -- ^ Initial storage value of the contract. - , ooContract :: !(Contract Op) + , ooContract :: !(Contract ExpandedOp) -- ^ The contract itself. } deriving (Generic) -deriving instance Show (ExtU InstrAbstract Op) => Show OriginationOperation +deriving instance Show ExpandedInstrExtU => Show OriginationOperation -- | Compute address of a contract from its origination operation. -- -- 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 :: Aeson.ToJSON InstrExtU => OriginationOperation -> Address +mkContractAddress :: Aeson.ToJSON ExpandedInstrExtU => OriginationOperation -> Address mkContractAddress = mkContractAddressRaw . BSL.toStrict . Aeson.encode ---------------------------------------------------------------------------- @@ -189,7 +212,9 @@ instance Aeson.ToJSON Instr => Aeson.ToJSON Op instance Aeson.FromJSON Instr => Aeson.FromJSON Op +instance Aeson.ToJSON ExpandedInstr => Aeson.ToJSON ExpandedOp +instance Aeson.FromJSON ExpandedInstr => Aeson.FromJSON ExpandedOp instance (Aeson.ToJSON op, Aeson.ToJSON (ExtU InstrAbstract op)) => Aeson.ToJSON (InstrAbstract op) instance (Aeson.FromJSON op, Aeson.FromJSON (ExtU InstrAbstract op)) => Aeson.FromJSON (InstrAbstract op) -instance Aeson.FromJSON Op => Aeson.FromJSON OriginationOperation -instance Aeson.ToJSON Op => Aeson.ToJSON OriginationOperation +instance Aeson.FromJSON ExpandedOp => Aeson.FromJSON OriginationOperation +instance Aeson.ToJSON ExpandedOp => Aeson.ToJSON OriginationOperation diff --git a/src/Morley/Aliases.hs b/src/Morley/Aliases.hs deleted file mode 100644 --- a/src/Morley/Aliases.hs +++ /dev/null @@ -1,11 +0,0 @@ --- | Some simple aliases for Michelson types. - -module Morley.Aliases - ( UntypedContract - , UntypedValue - ) where - -import qualified Michelson.Untyped as Untyped - -type UntypedValue = Untyped.Value Untyped.Op -type UntypedContract = Untyped.Contract Untyped.Op diff --git a/src/Morley/Ext.hs b/src/Morley/Ext.hs --- a/src/Morley/Ext.hs +++ b/src/Morley/Ext.hs @@ -24,13 +24,13 @@ import Michelson.TypeCheck.Types (HST) import Michelson.Typed (Val, converge, extractNotes, mkUType) import qualified Michelson.Typed as T -import Michelson.Untyped (CT(..), InstrAbstract(..)) +import Michelson.Untyped (CT(..), InstrAbstract(..), UntypedContract, UntypedValue) import Morley.Types interpretMorleyUntyped - :: Contract Op - -> Value Op - -> Value Op + :: UntypedContract + -> UntypedValue + -> UntypedValue -> ContractEnv -> Either (InterpretUntypedError MorleyLogs) (InterpretUntypedResult MorleyLogs) interpretMorleyUntyped c v1 v2 cenv = @@ -46,10 +46,10 @@ interpretMorley c param initSt env = interpret c param initSt (InterpreterEnv env interpretHandler) def -typeCheckMorleyContract :: Contract Instr -> Either TCError SomeContract +typeCheckMorleyContract :: UntypedContract -> Either TCError SomeContract typeCheckMorleyContract = typeCheckContract typeCheckHandler -typeCheckHandler :: UExtInstr -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe ExtInstr) +typeCheckHandler :: ExpandedUExtInstr -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe ExtInstr) typeCheckHandler ext nfs hst@(SomeHST hs) = case ext of STACKTYPE s -> fitError $ const (nfs, Nothing) <$> checkStackType noBoundVars s hs @@ -58,7 +58,7 @@ UPRINT pc -> verifyPrint pc $> (nfs, Just $ PRINT pc) UTEST_ASSERT UTestAssert{..} -> do verifyPrint tassComment - si <- typeCheckList (unOp <$> tassInstrs) hst + si <- typeCheckList tassInstrs hst case si of SiFail -> thErr "TEST_ASSERT has to return Bool, but it's failed" instr ::: (_ :: HST inp, ((_ :: (Sing b, T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do @@ -109,9 +109,9 @@ | VarError Text StackFn | TypeMismatch StackTypePattern Int Text | TyVarMismatch Var Type StackTypePattern Int Text - | FnEndMismatch (Maybe (UExtInstr, SomeHST)) + | FnEndMismatch (Maybe (ExpandedUExtInstr, SomeHST)) | StkRestMismatch StackTypePattern SomeHST SomeHST Text - | UnexpectedUExt UExtInstr + | UnexpectedUExt ExpandedUExtInstr -- | Print error messages uextErrorText :: UExtError -> HST xs -> Text diff --git a/src/Morley/Macro.hs b/src/Morley/Macro.hs --- a/src/Morley/Macro.hs +++ b/src/Morley/Macro.hs @@ -1,7 +1,7 @@ module Morley.Macro ( -- * For utilities - expandFlattenContract + expandContract , expandValue -- * For parsing @@ -9,33 +9,32 @@ -- * Internals exported for tests , expand - , expandFlat + , expandList , expandPapair , expandUnpapair , expandCadr , expandSetCadr , expandMapCadr - , flatten ) where -import Generics.SYB (everywhere, mkT) +import Michelson.Untyped (UntypedContract, UntypedValue) import Morley.Types - (CadrStruct(..), Contract(..), Elt(..), ExpandedInstr, ExpandedOp(..), FieldAnn, Instr, - InstrAbstract(..), LetMacro(..), Macro(..), Op(..), PairStruct(..), ParsedOp(..), TypeAnn, + (CadrStruct(..), Contract(..), Elt(..), ExpandedOp(..), FieldAnn, + InstrAbstract(..), LetMacro(..), Macro(..), PairStruct(..), ParsedOp(..), TypeAnn, UExtInstrAbstract(..), Value(..), VarAnn, ann, noAnn) -expandFlat :: [ParsedOp] -> [Op] -expandFlat = fmap Op . concatMap flatten . fmap expand +expandList :: [ParsedOp] -> [ExpandedOp] +expandList = fmap expand -- | Expand and flatten and instructions in parsed contract. -expandFlattenContract :: Contract ParsedOp -> Contract Op -expandFlattenContract Contract {..} = - Contract para stor (expandFlat $ code) +expandContract :: Contract ParsedOp -> UntypedContract +expandContract Contract {..} = + Contract para stor (expandList $ code) -- Probably, some SYB can be used here -expandValue :: Value ParsedOp -> Value Op +expandValue :: Value ParsedOp -> UntypedValue expandValue = \case ValuePair l r -> ValuePair (expandValue l) (expandValue r) ValueLeft x -> ValueLeft (expandValue x) @@ -46,105 +45,85 @@ ValueMap eltList -> ValueMap (map expandElt eltList) ValueLambda opList -> maybe ValueNil ValueLambda $ - nonEmpty (expandFlat $ toList opList) - x -> fmap (unsafeCastPrim . expand) x + nonEmpty (expandList $ toList opList) + x -> fmap expand x -expandElt :: Elt ParsedOp -> Elt Op +expandElt :: Elt ParsedOp -> Elt ExpandedOp expandElt (Elt l r) = Elt (expandValue l) (expandValue r) -flatten :: ExpandedOp -> [Instr] -flatten (SEQ_EX s) = concatMap flatten s -flatten (PRIM_EX o) = [flattenInstr o] - -unsafeCastPrim :: ExpandedOp -> Op -unsafeCastPrim (PRIM_EX x) = Op (fmap unsafeCastPrim x) -unsafeCastPrim _ = error "unexpected constructor" - --- Here used SYB approach instead pattern matching --- flattenInstr (IF_NONE l r) = IF_NONE (concatMap flatten l) (concatMap flatten r) --- flattenInstr (IF_LEFT l r) = IF_LEFT (concatMap flatten l) (concatMap flatten r) --- ... -flattenInstr :: ExpandedInstr -> Instr -flattenInstr = fmap unsafeCastPrim . everywhere (mkT flattenOps) - where - flattenOps :: [ExpandedOp] -> [ExpandedOp] - flattenOps [] = [] - flattenOps (SEQ_EX s : xs) = s ++ flattenOps xs - flattenOps (x@(PRIM_EX _) : xs) = x : flattenOps xs - expand :: ParsedOp -> ExpandedOp -expand (MAC m) = SEQ_EX $ expandMacro m -expand (PRIM i) = PRIM_EX $ expand <$> i -expand (SEQ s) = SEQ_EX $ expand <$> s -expand (LMAC l) = SEQ_EX $ expandLetMac l +expand (Mac m) = SeqEx $ expandMacro m +expand (Prim i) = PrimEx $ expand <$> i +expand (Seq s) = SeqEx $ expand <$> s +expand (LMac l) = SeqEx $ expandLetMac l where expandLetMac :: LetMacro -> [ExpandedOp] expandLetMac LetMacro {..} = - [ PRIM_EX $ EXT (FN lmName lmSig) - , SEQ_EX $ expand <$> lmExpr - , PRIM_EX $ EXT FN_END + [ PrimEx $ EXT (FN lmName lmSig) + , SeqEx $ expand <$> lmExpr + , PrimEx $ EXT FN_END ] expandMacro :: Macro -> [ExpandedOp] expandMacro = \case - CMP i v -> [PRIM_EX (COMPARE v), xo i] - IFX i bt bf -> [xo i, PRIM_EX (IF (xp bt) (xp bf))] - IFCMP i v bt bf -> PRIM_EX <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)] - IF_SOME bt bf -> [PRIM_EX (IF_NONE (xp bf) (xp bt))] - FAIL -> PRIM_EX <$> [UNIT noAnn noAnn, FAILWITH] - ASSERT -> xol $ IF [] [MAC FAIL] - ASSERTX i -> [expand $ MAC $ IFX i [] [MAC FAIL]] - ASSERT_CMP i -> [expand $ MAC $ IFCMP i noAnn [] [MAC FAIL]] - ASSERT_NONE -> xol $ IF_NONE [] [MAC FAIL] - ASSERT_SOME -> xol $ IF_NONE [MAC FAIL] [] - ASSERT_LEFT -> xol $ IF_LEFT [] [MAC FAIL] - ASSERT_RIGHT -> xol $ IF_LEFT [MAC FAIL] [] + CMP i v -> [PrimEx (COMPARE v), xo i] + IFX i bt bf -> [xo i, PrimEx (IF (xp bt) (xp bf))] + IFCMP i v bt bf -> PrimEx <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)] + IF_SOME bt bf -> [PrimEx (IF_NONE (xp bf) (xp bt))] + FAIL -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH] + ASSERT -> xol $ IF [] [Mac FAIL] + ASSERTX i -> [expand $ Mac $ IFX i [] [Mac FAIL]] + ASSERT_CMP i -> [expand $ Mac $ IFCMP i noAnn [] [Mac FAIL]] + ASSERT_NONE -> xol $ IF_NONE [] [Mac FAIL] + ASSERT_SOME -> xol $ IF_NONE [Mac FAIL] [] + ASSERT_LEFT -> xol $ IF_LEFT [] [Mac FAIL] + ASSERT_RIGHT -> xol $ IF_LEFT [Mac FAIL] [] PAPAIR ps t v -> expand <$> expandPapair ps t v UNPAIR ps -> expand <$> expandUnpapair ps CADR c v f -> expand <$> expandCadr c v f SET_CADR c v f -> expand <$> expandSetCadr c v f MAP_CADR c v f ops -> expand <$> expandMapCadr c v f ops - DIIP 1 ops -> [PRIM_EX $ DIP (xp ops)] - DIIP n ops -> xol $ DIP [MAC $ DIIP (n - 1) ops] - DUUP 1 v -> [PRIM_EX $ DUP v] - DUUP n v -> [xo (DIP [MAC $ DUUP (n - 1) v]), PRIM_EX SWAP] + DIIP 1 ops -> [PrimEx $ DIP (xp ops)] + DIIP n ops -> xol $ DIP [Mac $ DIIP (n - 1) ops] + DUUP 1 v -> [PrimEx $ DUP v] + DUUP n v -> [xo (DIP [Mac $ DUUP (n - 1) v]), PrimEx SWAP] where xol = one . xo - xo = PRIM_EX . fmap expand + xo = PrimEx . fmap expand xp = fmap expand -- the correctness of type-annotation expansion is currently untested, as these -- expansions are not explicitly documented in the Michelson Specification expandPapair :: PairStruct -> TypeAnn -> VarAnn -> [ParsedOp] expandPapair ps t v = case ps of - P (F a) (F b) -> [PRIM $ PAIR t v (snd a) (snd b)] - P (F a) r -> PRIM <$> [ DIP [MAC $ PAPAIR r noAnn noAnn] + P (F a) (F b) -> [Prim $ PAIR t v (snd a) (snd b)] + P (F a) r -> Prim <$> [ DIP [Mac $ PAPAIR r noAnn noAnn] , PAIR t v (snd a) noAnn] - P l (F b) -> [ MAC $ PAPAIR l noAnn noAnn - , PRIM $ PAIR t v noAnn (snd b)] - P l r -> [ MAC $ PAPAIR l noAnn noAnn - , PRIM $ DIP [MAC $ PAPAIR r noAnn noAnn] - , PRIM $ PAIR t v noAnn noAnn] + P l (F b) -> [ Mac $ PAPAIR l noAnn noAnn + , Prim $ PAIR t v noAnn (snd b)] + P l r -> [ Mac $ PAPAIR l noAnn noAnn + , Prim $ DIP [Mac $ PAPAIR r noAnn noAnn] + , Prim $ PAIR t v noAnn noAnn] F _ -> [] -- Do nothing in this case. -- It's impossible from the structure of PairStruct and considered cases above, -- but if it accidentally happened let's just do nothing. expandUnpapair :: PairStruct -> [ParsedOp] expandUnpapair = \case - P (F (v,f)) (F (w,g)) -> PRIM <$> [ DUP noAnn + P (F (v,f)) (F (w,g)) -> Prim <$> [ DUP noAnn , CAR v f - , DIP [PRIM $ CDR w g]] - P (F (v, f)) r -> PRIM <$> [ DUP noAnn + , DIP [Prim $ CDR w g]] + P (F (v, f)) r -> Prim <$> [ DUP noAnn , CAR v f - , DIP [PRIM $ CDR noAnn noAnn, - MAC $ UNPAIR r]] - P l (F (v, f)) -> [ PRIM (DUP noAnn) - , PRIM (DIP [PRIM $ CDR v f]) - , PRIM $ CAR noAnn noAnn - , MAC $ UNPAIR l] - P l r -> [ MAC unpairOne - , PRIM $ DIP [MAC $ UNPAIR r] - , MAC $ UNPAIR l] + , DIP [Prim $ CDR noAnn noAnn, + Mac $ UNPAIR r]] + P l (F (v, f)) -> [ Prim (DUP noAnn) + , Prim (DIP [Prim $ CDR v f]) + , Prim $ CAR noAnn noAnn + , Mac $ UNPAIR l] + P l r -> [ Mac unpairOne + , Prim $ DIP [Mac $ UNPAIR r] + , Mac $ UNPAIR l] F _ -> [] -- Do nothing in this case. -- It's impossible from the structure of PairStruct and considered cases above, -- but if it accidentally happened let's just do nothing. @@ -155,22 +134,22 @@ expandCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] expandCadr cs v f = case cs of [] -> [] - A:[] -> [PRIM $ CAR v f] - D:[] -> [PRIM $ CDR v f] - A:css -> [PRIM $ CAR noAnn noAnn, MAC $ CADR css v f] - D:css -> [PRIM $ CDR noAnn noAnn, MAC $ CADR css v f] + [A] -> [Prim $ CAR v f] + [D] -> [Prim $ CDR v f] + A:css -> [Prim $ CAR noAnn noAnn, Mac $ CADR css v f] + D:css -> [Prim $ CDR noAnn noAnn, Mac $ CADR css v f] expandSetCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -expandSetCadr cs v f = PRIM <$> case cs of +expandSetCadr cs v f = Prim <$> case cs of [] -> [] - A:[] -> [DUP noAnn, CAR noAnn f, DROP, + [A] -> [DUP noAnn, CAR noAnn f, DROP, -- ↑ These operations just check that the left element of pair has %f CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")] - D:[] -> [DUP noAnn, CDR noAnn f, DROP, + [D] -> [DUP noAnn, CDR noAnn f, DROP, -- ↑ These operations just check that the right element of pair has %f CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f] - A:css -> [DUP noAnn, DIP [PRIM carN, MAC $ SET_CADR css noAnn f], cdrN, SWAP, pairN] - D:css -> [DUP noAnn, DIP [PRIM cdrN, MAC $ SET_CADR css noAnn f], carN, pairN] + A:css -> [DUP noAnn, DIP [Prim carN, Mac $ SET_CADR css noAnn f], cdrN, SWAP, pairN] + D:css -> [DUP noAnn, DIP [Prim cdrN, Mac $ SET_CADR css noAnn f], carN, pairN] where carN = CAR noAnn noAnn cdrN = CDR noAnn noAnn @@ -179,10 +158,10 @@ expandMapCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ParsedOp] expandMapCadr cs v f ops = case cs of [] -> [] - A:[] -> PRIM <$> [DUP noAnn, cdrN, DIP [PRIM $ CAR noAnn f, SEQ ops], SWAP, pairN] - D:[] -> concat [PRIM <$> [DUP noAnn, CDR noAnn f], [SEQ ops], PRIM <$> [SWAP, carN, pairN]] - A:css -> PRIM <$> [DUP noAnn, DIP [PRIM $ carN, MAC $ MAP_CADR css noAnn f ops], cdrN, SWAP, pairN] - D:css -> PRIM <$> [DUP noAnn, DIP [PRIM $ cdrN, MAC $ MAP_CADR css noAnn f ops], carN, pairN] + [A] -> Prim <$> [DUP noAnn, cdrN, DIP [Prim $ CAR noAnn f, Seq ops], SWAP, pairN] + [D] -> concat [Prim <$> [DUP noAnn, CDR noAnn f], [Seq ops], Prim <$> [SWAP, carN, pairN]] + A:css -> Prim <$> [DUP noAnn, DIP [Prim $ carN, Mac $ MAP_CADR css noAnn f ops], cdrN, SWAP, pairN] + D:css -> Prim <$> [DUP noAnn, DIP [Prim $ cdrN, Mac $ MAP_CADR css noAnn f ops], carN, pairN] where carN = CAR noAnn noAnn cdrN = CDR noAnn noAnn diff --git a/src/Morley/Parser.hs b/src/Morley/Parser.hs --- a/src/Morley/Parser.hs +++ b/src/Morley/Parser.hs @@ -8,6 +8,9 @@ , value , stackType , printComment + , bytesLiteral + , pushOp + , intLiteral ) where import Prelude hiding (many, note, some, try) @@ -22,7 +25,7 @@ import Text.Megaparsec (choice, customFailure, eitherP, many, manyTill, notFollowedBy, parse, satisfy, sepEndBy, some, - takeWhile1P, try) + takeWhileP, try) import Text.Megaparsec.Char (alphaNumChar, char, lowerChar, string, upperChar) import qualified Text.Megaparsec.Char.Lexer as L @@ -102,12 +105,12 @@ op' = do lms <- asks Mo.letMacros choice - [ (Mo.PRIM . Mo.EXT) <$> nopInstr - , Mo.LMAC <$> mkLetMac lms - , Mo.PRIM <$> prim - , Mo.MAC <$> macro + [ (Mo.Prim . Mo.EXT) <$> nopInstr + , Mo.LMac <$> mkLetMac lms + , Mo.Prim <$> prim + , Mo.Mac <$> macro , primOrMac - , Mo.SEQ <$> ops + , Mo.Seq <$> ops ] ops :: Parser [Mo.ParsedOp] @@ -221,7 +224,7 @@ valueInner :: Parser (Mo.Value Mo.ParsedOp) valueInner = choice $ - [ intLiteral, stringLiteral, bytesLiteral, unitValue + [ stringLiteral, bytesLiteral, intLiteral, unitValue , trueValue, falseValue, pairValue, leftValue, rightValue , someValue, noneValue, nilValue, seqValue, mapValue, lambdaValue , dataLetValue @@ -239,7 +242,7 @@ bytesLiteral :: Parser (Mo.Value a) bytesLiteral = try $ do symbol "0x" - hexdigits <- takeWhile1P Nothing Char.isHexDigit + hexdigits <- takeWhileP Nothing Char.isHexDigit let (bytes, remain) = B16.decode $ encodeUtf8 hexdigits if remain == "" then return . Mo.ValueBytes . Mo.InternalByteString $ bytes @@ -873,15 +876,15 @@ symbol' "IF" a <- eitherP cmpOp ops case a of - Left cmp -> Mo.MAC <$> (Mo.IFX cmp <$> ops <*> ops) - Right op -> Mo.PRIM <$> (Mo.IF op <$> ops) + Left cmp -> Mo.Mac <$> (Mo.IFX cmp <$> ops <*> ops) + Right op -> Mo.Prim <$> (Mo.IF op <$> ops) -- Some of the operations and macros have the same prefixes in their names -- So this case should be handled separately primOrMac :: Parser Mo.ParsedOp -primOrMac = ((Mo.MAC <$> ifCmpMac) <|> ifOrIfX) - <|> ((Mo.MAC <$> mapCadrMac) <|> (Mo.PRIM <$> mapOp)) - <|> (try (Mo.PRIM <$> pairOp) <|> Mo.MAC <$> pairMac) +primOrMac = ((Mo.Mac <$> ifCmpMac) <|> ifOrIfX) + <|> ((Mo.Mac <$> mapCadrMac) <|> (Mo.Prim <$> mapOp)) + <|> (try (Mo.Prim <$> pairOp) <|> Mo.Mac <$> pairMac) ------------------------------------------------------------------------------- -- Morley Instructions diff --git a/src/Morley/Runtime.hs b/src/Morley/Runtime.hs --- a/src/Morley/Runtime.hs +++ b/src/Morley/Runtime.hs @@ -39,10 +39,10 @@ import Michelson.Typed (CreateContract(..), Instr, Operation(..), TransferTokens(..), Val(..), convertContract, unsafeValToValue) -import Michelson.Untyped (Contract(..), Op(..), OriginationOperation(..), Value, mkContractAddress) -import Morley.Aliases (UntypedContract) +import Michelson.Untyped + (Contract(..), OriginationOperation(..), UntypedContract, UntypedValue, mkContractAddress) import Morley.Ext (interpretMorleyUntyped, typeCheckMorleyContract) -import Morley.Macro (expandFlattenContract) +import Morley.Macro (expandContract) import qualified Morley.Parser as P import Morley.Runtime.GState import Morley.Runtime.TxData @@ -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 |+ "" @@ -149,8 +150,8 @@ -- | Read a contract using 'readAndParseContract', expand and -- flatten. The contract is not type checked. -prepareContract :: Maybe FilePath -> IO (Contract Op) -prepareContract mFile = expandFlattenContract <$> readAndParseContract mFile +prepareContract :: Maybe FilePath -> IO UntypedContract +prepareContract mFile = expandContract <$> readAndParseContract mFile -- | Originate a contract. Returns the address of the originated -- contract. @@ -170,8 +171,8 @@ -> Word64 -> Mutez -> FilePath - -> Value Op - -> Contract Op + -> UntypedValue + -> UntypedContract -> TxData -> "verbose" :! Bool -> "dryRun" :! Bool @@ -292,7 +293,7 @@ -> Either InterpreterError InterpreterRes interpretOneOp _ remainingSteps _ gs (OriginateOp origination) = do void $ first IEIllTypedContract $ - typeCheckMorleyContract (unOp <$> ooContract origination) + typeCheckMorleyContract (ooContract origination) let originatorAddress = KeyAddress (ooManager origination) originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of Nothing -> Left (IEUnknownManager originatorAddress) @@ -372,7 +373,7 @@ , iurNewStorage = newValue , iurNewState = InterpreterState printedLogs newRemainingSteps } - <- first (IEInterpreterFailed contract) $ + <- first (IEInterpreterFailed addr) $ interpretMorleyUntyped contract (tdParameter txData) (csStorage cs) contractEnv let diff --git a/src/Morley/Runtime/GState.hs b/src/Morley/Runtime/GState.hs --- a/src/Morley/Runtime/GState.hs +++ b/src/Morley/Runtime/GState.hs @@ -34,7 +34,7 @@ import Formatting.Buildable (Buildable(build)) import System.IO.Error (IOError, isDoesNotExistError) -import Morley.Aliases (UntypedContract, UntypedValue) +import Michelson.Untyped (UntypedContract, UntypedValue) import Morley.Types () import Tezos.Address (Address(..)) import Tezos.Core (Mutez) diff --git a/src/Morley/Runtime/TxData.hs b/src/Morley/Runtime/TxData.hs --- a/src/Morley/Runtime/TxData.hs +++ b/src/Morley/Runtime/TxData.hs @@ -4,16 +4,16 @@ ( TxData (..) ) where -import Michelson.Untyped (Op, Value) -import Morley.Types (UExtInstr) +import Michelson.Untyped (UntypedValue) +import Morley.Types (ExpandedUExtInstr) import Tezos.Address (Address) import Tezos.Core (Mutez) -- | Data associated with a particular transaction. data TxData = TxData { tdSenderAddress :: !Address - , tdParameter :: !(Value Op) + , tdParameter :: !UntypedValue , tdAmount :: !Mutez } -deriving instance Show UExtInstr => Show TxData +deriving instance Show ExpandedUExtInstr => Show TxData diff --git a/src/Morley/Test.hs b/src/Morley/Test.hs --- a/src/Morley/Test.hs +++ b/src/Morley/Test.hs @@ -1,3 +1,53 @@ --- | Module, containing some utilities for testing Michelson contracts using +-- | Module containing some utilities for testing Michelson contracts using -- Haskell testing frameworks (hspec and QuickCheck in particular). -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +-- It's Morley testing EDSL. + +module Morley.Test + ( -- * Importing a contract + specWithContract + , specWithTypedContract + + -- * Unit testing + , ContractReturn + , ContractPropValidator + , contractProp + , contractPropVal + + -- * Integrational testing + -- ** Testing engine + , IntegrationalValidator + , SuccessValidator + , IntegrationalScenario + , integrationalTestExpectation + , integrationalTestProperty + , originate + , transfer + , validate + , setMaxSteps + , setNow + + -- ** Validators + , composeValidators + , composeValidatorsList + , expectAnySuccess + , expectStorageUpdate + , expectStorageUpdateConst + , expectBalance + , expectStorageConst + , expectGasExhaustion + , expectMichelsonFailed + + -- * Dummy values + , dummyContractEnv + + -- * Arbitrary data + , minTimestamp + , maxTimestamp + , midTimestamp + ) where + +import Morley.Test.Dummy +import Morley.Test.Gen +import Morley.Test.Import +import Morley.Test.Integrational +import Morley.Test.Unit diff --git a/src/Morley/Test/Dummy.hs b/src/Morley/Test/Dummy.hs --- a/src/Morley/Test/Dummy.hs +++ b/src/Morley/Test/Dummy.hs @@ -43,9 +43,9 @@ -- | 'OriginationOperation' with most data hardcoded to some -- reasonable values. Contract and initial values must be passed -- explicitly, because otherwise it hardly makes sense. -dummyOrigination :: - Value Op - -> Contract Op +dummyOrigination + :: UntypedValue + -> UntypedContract -> OriginationOperation dummyOrigination storage contract = OriginationOperation { ooManager = genesisKeyHash diff --git a/src/Morley/Test/Import.hs b/src/Morley/Test/Import.hs --- a/src/Morley/Test/Import.hs +++ b/src/Morley/Test/Import.hs @@ -15,7 +15,6 @@ import Michelson.TypeCheck (SomeContract(..), TCError) import Michelson.Typed (Contract) import qualified Michelson.Untyped as U -import Morley.Aliases (UntypedContract) import Morley.Ext (typeCheckMorleyContract) import Morley.Runtime (prepareContract) import Morley.Types (ParserException(..)) @@ -28,7 +27,7 @@ -- result will notify about problem). specWithContract :: (Typeable cp, Typeable st) - => FilePath -> ((UntypedContract, Contract cp st) -> Spec) -> Spec + => FilePath -> ((U.UntypedContract, Contract cp st) -> Spec) -> Spec specWithContract file execSpec = either errorSpec (describe ("Test contract " <> file) . execSpec) =<< runIO @@ -53,12 +52,11 @@ importContract :: forall cp st . (Typeable cp, Typeable st) - => FilePath -> IO (UntypedContract, Contract cp st) + => FilePath -> IO (U.UntypedContract, Contract cp st) importContract file = do contract <- mapException ICEParse $ prepareContract (Just file) SomeContract (instr :: Contract cp' st') _ _ - <- assertEither ICETypeCheck $ pure $ typeCheckMorleyContract $ - U.unOp <$> contract + <- assertEither ICETypeCheck $ pure $ typeCheckMorleyContract contract case (eqT @cp @cp', eqT @st @st') of (Just Refl, Just Refl) -> pure (contract, instr) (Nothing, _) -> throwM $ diff --git a/src/Morley/Test/Integrational.hs b/src/Morley/Test/Integrational.hs --- a/src/Morley/Test/Integrational.hs +++ b/src/Morley/Test/Integrational.hs @@ -1,142 +1,202 @@ -- | 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 + , 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 (assign, 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(..), UntypedContract, UntypedValue, mkContractAddress) 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 +---------------------------------------------------------------------------- + -- | 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 ()) +-- | A monad inside which integrational tests can be described using +-- do-notation. +type IntegrationalScenarioM = StateT InternalState (Except Text) + +-- | 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 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 (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 <$ 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 -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 = assign isNow +-- | Make all further interpreter calls (which are triggered by the +-- 'validate' function) use given gas limit. +setMaxSteps :: RemainingSteps -> IntegrationalScenarioM () +setMaxSteps = assign isMaxSteps + +putOperation :: InterpreterOp -> IntegrationalScenarioM () +putOperation op = isOperations <>= 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 +217,7 @@ -- For example: -- -- expectBalance bal addr `composeValidators` --- expectStorageConstant addr2 ValueUnit +-- expectStorageUpdateConst addr2 ValueUnit composeValidators :: SuccessValidator -> SuccessValidator @@ -165,8 +225,61 @@ 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 scenario initIS) + +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 diff --git a/src/Morley/Types.hs b/src/Morley/Types.hs --- a/src/Morley/Types.hs +++ b/src/Morley/Types.hs @@ -52,7 +52,7 @@ -- * Morley Expanded instruction types , ExpandedInstr , ExpandedOp (..) - , UExtInstr + , ExpandedUExtInstr -- * Michelson Instructions and Instruction Macros , PairStruct (..) @@ -95,9 +95,9 @@ import Michelson.Typed (instrToOps) import qualified Michelson.Typed as T import Michelson.Untyped - (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), ExtU, FieldAnn, Instr, - InstrAbstract(..), InternalByteString(..), Op(..), Parameter, Storage, T(..), Type(..), TypeAnn, - Value(..), VarAnn, ann, noAnn, unInternalByteString) + (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), ExpandedInstr, ExpandedOp (..), ExtU, + FieldAnn, Instr, InstrAbstract(..), InternalByteString(..), Op(..), Parameter, Storage, T(..), + Type(..), TypeAnn, Value(..), VarAnn, ann, noAnn, unInternalByteString) import Morley.Default (Default(..)) ------------------------------------- @@ -168,7 +168,7 @@ instance Buildable op => Buildable (UExtInstrAbstract op) where build = genericF --- TODO replace ParsedOp in UExtInstr with op +-- TODO replace ParsedOp in ExpandedUExtInstr with op -- to reflect Parsed, Epxanded and Flattened phase type instance ExtU InstrAbstract = UExtInstrAbstract @@ -185,10 +185,10 @@ -- | Unexpanded instructions produced directly by the @ops@ parser, which -- contains primitive Michelson Instructions, inline-able macros and sequences data ParsedOp - = PRIM ParsedInstr -- ^ Primitive Michelson instruction - | MAC Macro -- ^ Built-in Michelson macro defined by the specification - | LMAC LetMacro -- ^ User-defined macro with instructions to be inlined - | SEQ [ParsedOp] -- ^ A sequence of instructions + = Prim ParsedInstr -- ^ Primitive Michelson instruction + | Mac Macro -- ^ Built-in Michelson macro defined by the specification + | LMac LetMacro -- ^ User-defined macro with instructions to be inlined + | Seq [ParsedOp] -- ^ A sequence of instructions deriving (Eq, Show, Data, Generic) instance Buildable ParsedInstr where @@ -197,25 +197,11 @@ instance Buildable ParsedOp where build = genericF -------------------------------------- --- Types after macroexpander -------------------------------------- - -type ExpandedInstr = InstrAbstract ExpandedOp - -data ExpandedOp - = PRIM_EX ExpandedInstr - | SEQ_EX [ExpandedOp] - deriving stock (Eq, Show, Data, Generic) +type ExpandedUExtInstr = UExtInstrAbstract ExpandedOp instance Buildable ExpandedInstr where build = genericF -instance Buildable ExpandedOp where - build = genericF - -type UExtInstr = UExtInstrAbstract Op - instance Buildable Instr where build = genericF @@ -246,7 +232,7 @@ | PRINT PrintComment deriving (Show, Eq) -instance T.Conversible ExtInstr (UExtInstrAbstract Op) where +instance T.Conversible ExtInstr (UExtInstrAbstract ExpandedOp) where convert (PRINT pc) = UPRINT pc convert (TEST_ASSERT (TestAssert nm pc i)) = UTEST_ASSERT $ UTestAssert nm pc (instrToOps i) diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs --- a/src/Tezos/Address.hs +++ b/src/Tezos/Address.hs @@ -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 diff --git a/test/Test/Arbitrary.hs b/test/Test/Arbitrary.hs --- a/test/Test/Arbitrary.hs +++ b/test/Test/Arbitrary.hs @@ -14,9 +14,9 @@ import Michelson.Untyped (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), FieldAnn, InstrAbstract(..), - InternalByteString(..), Op(..), T(..), Type(..), TypeAnn, Value(..), VarAnn) + InternalByteString(..), ExpandedOp (..), T(..), Type(..), TypeAnn, Value(..), VarAnn) import Morley.Test () -import Morley.Types (StackTypePattern(..), TyVar(..), UExtInstr, UExtInstrAbstract(..), Var(..)) +import Morley.Types (StackTypePattern(..), TyVar(..), ExpandedUExtInstr, UExtInstrAbstract(..), Var(..)) import Tezos.Core (Mutez(..)) instance Arbitrary InternalByteString where @@ -31,13 +31,13 @@ instance Arbitrary StackTypePattern where arbitrary = oneof [pure StkEmpty, pure StkRest, StkCons <$> arbitrary <*> arbitrary] --- TODO extend Arbitrary UExtInstr with other constructors -instance Arbitrary UExtInstr where +-- TODO extend Arbitrary ExpandedUExtInstr with other constructors +instance Arbitrary ExpandedUExtInstr where arbitrary = oneof [STACKTYPE <$> arbitrary] -instance ToADTArbitrary Op -instance Arbitrary Op where - arbitrary = Op <$> arbitrary +instance ToADTArbitrary ExpandedOp +instance Arbitrary ExpandedOp where + arbitrary = PrimEx <$> arbitrary instance ToADTArbitrary Mutez diff --git a/test/Test/Ext.hs b/test/Test/Ext.hs --- a/test/Test/Ext.hs +++ b/test/Test/Ext.hs @@ -14,7 +14,7 @@ import Morley.Test (specWithTypedContract) import Morley.Test.Dummy (dummyContractEnv) import Morley.Types - (MorleyLogs(..), StackTypePattern(..), TyVar(..), UExtInstr, UExtInstrAbstract(..)) + (MorleyLogs(..), StackTypePattern(..), TyVar(..), ExpandedUExtInstr, UExtInstrAbstract(..)) interpretHandlerSpec :: Spec interpretHandlerSpec = describe "interpretHandler PRINT/TEST_ASSERT tests" $ @@ -75,7 +75,7 @@ nh (ni, si) = runTypeCheckT typeCheckHandler (Type TKey noAnn) $ typeCheckHandler ni [] si - runNopTest :: (UExtInstr, SomeHST) -> Bool -> Expectation + runNopTest :: (ExpandedUExtInstr, SomeHST) -> Bool -> Expectation runNopTest tcase correct = case (nh tcase, correct) of (Right _, False) -> expectationFailure $ "Test expected to fail but it passed" (Left e, True) -> expectationFailure $ "Test expected to pass but it failed with error: " <> show e diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs --- a/test/Test/Interpreter.hs +++ b/test/Test/Interpreter.hs @@ -8,7 +8,7 @@ import Test.QuickCheck (Property, label, (.&&.), (===)) import Michelson.Interpret (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps) -import Michelson.Typed (CT(..), CVal(..), Instr(..), T(..), Val(..), fromVal, toVal, ( # )) +import Michelson.Typed (CT(..), CVal(..), Instr(..), T(..), ToT, Val(..), fromVal, toVal, ( # )) import Morley.Ext (interpretMorley) import Morley.Test (ContractPropValidator, contractProp, specWithTypedContract) import Morley.Test.Dummy (dummyContractEnv) @@ -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 @@ -80,6 +82,19 @@ Right _ -> expectationFailure "expecting contract to fail" Left MichelsonGasExhaustion -> pass Left _ -> expectationFailure "expecting another failure reason" + + specWithTypedContract "contracts/add1_list.tz" $ \contract -> do + let + validate :: + [Integer] -> ContractPropValidator (ToT [Integer]) Property + validate param (res, _) = + case res of + Left failed -> failedProp $ + "add1_list unexpectedly failed: " <> pretty failed + Right (fromVal . snd -> finalStorage) -> + map succ param === finalStorage + prop "Random check" $ \param -> + contractProp contract (validate param) dummyContractEnv param param validateBasic1 :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property 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 @@ -10,14 +10,14 @@ import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Michelson.Typed -import Michelson.Untyped (OriginationOperation(..), mkContractAddress) +import Michelson.Untyped (UntypedContract) 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 diff --git a/test/Test/Interpreter/EnvironmentSpec.hs b/test/Test/Interpreter/EnvironmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Interpreter/EnvironmentSpec.hs @@ -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 Michelson.Untyped (UntypedContract, UntypedValue) +import qualified Michelson.Untyped as Untyped +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 = 20 + +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 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 @@ -1,4 +1,6 @@ --- | Tests for the 'stringCaller.tz' contract. +-- | Tests for the 'stringCaller.tz' contract and its interaction with +-- the 'failOrStoreAndTransfer.tz' contract. Both of them have comments describing +-- their behavior. module Test.Interpreter.StringCaller ( stringCallerSpec @@ -9,76 +11,133 @@ import Test.QuickCheck.Instances.Text () import Michelson.Typed -import Michelson.Untyped (OriginationOperation(..), mkContractAddress) +import Michelson.Untyped (UntypedContract) import qualified Michelson.Untyped as Untyped -import Morley.Aliases (UntypedContract, UntypedValue) -import Morley.Runtime (InterpreterOp(..), TxData(..)) 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 stringCallerSpec = parallel $ specWithContract "contracts/stringCaller.tz" $ \stringCaller -> - specWithContract "contracts/idString.tz" $ \idString -> - specImpl stringCaller idString + specWithContract "contracts/failOrStoreAndTransfer.tz" $ \failOrStoreAndTransfer -> + specImpl stringCaller failOrStoreAndTransfer specImpl :: (UntypedContract, Contract ('Tc 'CString) ('Tc 'CAddress)) -> (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)) +specImpl (uStringCaller, _stringCaller) (uFailOrStore, _failOrStoreAndTransfer) = do + let scenario = integrationalScenario uStringCaller uFailOrStore + let prefix = + "stringCaller calls failOrStoreAndTransfer and updates its storage with " + let suffix = + " and properly updates balances. But fails if failOrStoreAndTransfer's" + <> " balance is ≥ 1000 and NOW is ≥ 500" + it (prefix <> "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 (prefix <> "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 failOrStoreAndTransfer str = do + let + initFailOrStoreBalance = unsafeMkMutez 900 + initStringCallerBalance = unsafeMkMutez 500 - stringCallerOrigination :: OriginationOperation - stringCallerOrigination = - dummyOrigination (Untyped.ValueString $ formatAddress idStringAddress) - uStringCaller - originateStringCaller = OriginateOp stringCallerOrigination - stringCallerAddress = mkContractAddress stringCallerOrigination + -- Originate both contracts + failOrStoreAndTransferAddress <- + originate failOrStoreAndTransfer (Untyped.ValueString "hello") initFailOrStoreBalance + stringCallerAddress <- + originate stringCaller + (Untyped.ValueString $ formatAddress failOrStoreAndTransferAddress) + 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 failOrStoreAndTransfer + 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 'failOrStoreAndTransfer' + do + let + -- `stringCaller.tz` transfers 300 mutez. + -- 'failOrStoreAndTransfer.tz' transfers 5 tokens. + -- Also 100 tokens are transferred from the genesis address. + expectedStringCallerBalance = unsafeMkMutez (500 - 300 + 100) + expectedFailOrStoreBalance = unsafeMkMutez (900 + 300 - 5) + expectedConstAddrBalance = unsafeMkMutez 5 - -- `stringCaller.tz` transfers 2 mutez. - expectedIdStringBalance = - ooBalance idStringOrigination `unsafeAddMutez` unsafeMkMutez 2 + updatesValidator :: SuccessValidator + updatesValidator = composeValidatorsList + [ expectStorageUpdateConst failOrStoreAndTransferAddress newValue + , expectBalance failOrStoreAndTransferAddress expectedFailOrStoreBalance + , 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 failOrStoreAndTransfer should fail + -- because its balance is greater than 1000. + void $ validate (Left $ expectMichelsonFailed failOrStoreAndTransferAddress) + + -- We can also send tokens from failOrStoreAndTransfer to tz1 address directly + let + txDataToConst = TxData + { tdSenderAddress = failOrStoreAndTransferAddress + , tdParameter = Untyped.ValueUnit + , tdAmount = unsafeMkMutez 200 + } + transfer txDataToConst constAddr + + -- Let's check balance of failOrStoreAndTransfer and tz1 address. + -- We transferred 200 tokens from failOrStoreAndTransferAddress to constAddr. + do + let + expectedFailOrStoreBalance = unsafeMkMutez (900 + 300 - 5 - 200) + expectedConstAddrBalance = unsafeMkMutez (5 + 200) + + updatesValidator :: SuccessValidator + updatesValidator = composeValidatorsList + [ expectBalance failOrStoreAndTransferAddress expectedFailOrStoreBalance + , expectBalance constAddr expectedConstAddrBalance + ] + + void $ validate (Right updatesValidator) + + -- 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 @Int 600) + transferToStringCaller + validate (Left $ expectMichelsonFailed stringCallerAddress) + +-- Address hardcoded in 'failOrStoreAndTransfer.tz'. +constAddr :: Address +constAddr = unsafeParseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU" diff --git a/test/Test/Macro.hs b/test/Test/Macro.hs --- a/test/Test/Macro.hs +++ b/test/Test/Macro.hs @@ -2,8 +2,7 @@ ( spec ) where -import qualified Data.List.NonEmpty as NE - +import Michelson.Untyped (UntypedValue) import Morley.Macro import Morley.Types import Test.Hspec (Expectation, Spec, describe, it, shouldBe) @@ -11,25 +10,25 @@ spec :: Spec spec = describe "Macros tests" $ do it "expand test" expandTest - it "expandFlat test" expandFlatTest it "papair test" expandPapairTest it "unpapair test" expandUnpapairTest it "expandCadr test" expandCadrTest it "expandSetCadr test" expandSetCadrTest it "expandMapCadr test" expandMapCadrTest it "mapLeaves test" mapLeavesTest - it "flatten test" flattenTest it "expandValue test" expandValueTest expandPapairTest :: Expectation expandPapairTest = do - expandPapair pair n n `shouldBe` [PRIM $ PAIR n n n n] + expandPapair pair n n `shouldBe` [Prim $ PAIR n n n n] expandPapair (P leaf pair) n n `shouldBe` - [PRIM $ DIP [MAC $ PAPAIR pair n n], PRIM $ PAIR n n n n] - expandFlat [MAC $ PAPAIR (P pair leaf) n n] `shouldBe` - Op <$> [PAIR n n n n, PAIR n n n n] - expandFlat [MAC $ PAPAIR (P pair pair) n n] `shouldBe` - Op <$> [PAIR n n n n, DIP [Op $ PAIR n n n n], PAIR n n n n] + [Prim $ DIP [Mac $ PAPAIR pair n n], Prim $ PAIR n n n n] + expandList [Mac $ PAPAIR (P pair leaf) n n] `shouldBe` + [SeqEx [SeqEx [PrimEx $ PAIR n n n n], PrimEx $ PAIR n n n n]] + expandList [Mac $ PAPAIR (P pair pair) n n] `shouldBe` + [SeqEx [SeqEx [PrimEx (PAIR n n n n)], + PrimEx (DIP [SeqEx [PrimEx (PAIR n n n n)]]), + PrimEx (PAIR n n n n)]] where n = noAnn leaf = F (n, n) @@ -38,25 +37,35 @@ expandUnpapairTest :: Expectation expandUnpapairTest = do expandUnpapair pair `shouldBe` - [PRIM $ DUP n, PRIM $ CAR n n, PRIM $ DIP [PRIM $ CDR n n]] - expandFlat [MAC $ UNPAIR $ P leaf pair] `shouldBe` - Op <$> [DUP n, CAR n n, DIP $ Op <$> [CDR n n, DUP n, CAR n n, DIP [Op $ CDR n n]]] - expandFlat [MAC $ UNPAIR $ P pair leaf] `shouldBe` - Op <$> [DUP n, DIP [Op $ CDR n n], CAR n n, DUP n, CAR n n, DIP [Op $ CDR n n]] - expandFlat [MAC $ UNPAIR $ P pair pair] `shouldBe` - fmap Op ( expandP ++ [DIP $ Op <$> expandP] ++ expandP) + [Prim $ DUP n, Prim $ CAR n n, Prim $ DIP [Prim $ CDR n n]] + expandList [Mac $ UNPAIR $ P leaf pair] `shouldBe` + [SeqEx [PrimEx (DUP n), + PrimEx (CAR n n), + PrimEx (DIP [PrimEx (CDR n n), + SeqEx [PrimEx (DUP n), + PrimEx (CAR n n), + PrimEx (DIP [PrimEx (CDR n n)])]])]] + expandList [Mac $ UNPAIR $ P pair leaf] `shouldBe` + [SeqEx [PrimEx (DUP n), + PrimEx (DIP [PrimEx (CDR n n)]), + PrimEx (CAR n n), + SeqEx [PrimEx (DUP n), + PrimEx (CAR n n), + PrimEx (DIP [PrimEx (CDR n n)])]]] + expandList [Mac $ UNPAIR $ P pair pair] `shouldBe` + [SeqEx $ one expandP ++ [PrimEx $ DIP $ one expandP] ++ one expandP] where - expandP = [DUP n, CAR n n, DIP [Op $ CDR n n]] + expandP = SeqEx $ PrimEx <$> [DUP n, CAR n n, DIP [PrimEx $ CDR n n]] n = noAnn leaf = F (n, n) pair = P leaf leaf expandCadrTest :: Expectation expandCadrTest = do - expandCadr (A:[]) v f `shouldBe` [PRIM $ CAR v f] - expandCadr (D:[]) v f `shouldBe` [PRIM $ CDR v f] - expandCadr (A:xs) v f `shouldBe` [PRIM $ CAR n n, MAC $ CADR xs v f] - expandCadr (D:xs) v f `shouldBe` [PRIM $ CDR n n, MAC $ CADR xs v f] + expandCadr ([A]) v f `shouldBe` [Prim $ CAR v f] + expandCadr ([D]) v f `shouldBe` [Prim $ CDR v f] + expandCadr (A:xs) v f `shouldBe` [Prim $ CAR n n, Mac $ CADR xs v f] + expandCadr (D:xs) v f `shouldBe` [Prim $ CDR n n, Mac $ CADR xs v f] where v = ann "var" f = ann "field" @@ -65,14 +74,14 @@ expandSetCadrTest :: Expectation expandSetCadrTest = do - expandSetCadr [A] v f `shouldBe` PRIM <$> [ DUP noAnn, CAR noAnn f, DROP + expandSetCadr [A] v f `shouldBe` Prim <$> [ DUP noAnn, CAR noAnn f, DROP , CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")] - expandSetCadr [D] v f `shouldBe` PRIM <$> [ DUP noAnn, CDR noAnn f, DROP + expandSetCadr [D] v f `shouldBe` Prim <$> [ DUP noAnn, CDR noAnn f, DROP , CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f] expandSetCadr (A:xs) v f `shouldBe` - PRIM <$> [DUP noAnn, DIP [PRIM carN, MAC $ SET_CADR xs noAnn f], cdrN, SWAP, pairN] + Prim <$> [DUP noAnn, DIP [Prim carN, Mac $ SET_CADR xs noAnn f], cdrN, SWAP, pairN] expandSetCadr (D:xs) v f `shouldBe` - PRIM <$> [DUP noAnn, DIP [PRIM cdrN, MAC $ SET_CADR xs noAnn f], carN, pairN] + Prim <$> [DUP noAnn, DIP [Prim cdrN, Mac $ SET_CADR xs noAnn f], carN, pairN] where v = ann "var" f = ann "field" @@ -84,19 +93,19 @@ expandMapCadrTest :: Expectation expandMapCadrTest = do expandMapCadr [A] v f ops `shouldBe` - PRIM <$> [DUP noAnn, cdrN, DIP [PRIM $ CAR noAnn f, SEQ ops], SWAP, pairN] + Prim <$> [DUP noAnn, cdrN, DIP [Prim $ CAR noAnn f, Seq ops], SWAP, pairN] expandMapCadr [D] v f ops `shouldBe` - concat [PRIM <$> [DUP noAnn, CDR noAnn f], [SEQ ops], PRIM <$> [SWAP, carN, pairN]] + concat [Prim <$> [DUP noAnn, CDR noAnn f], [Seq ops], Prim <$> [SWAP, carN, pairN]] expandMapCadr (A:xs) v f ops `shouldBe` - PRIM <$> [DUP noAnn, DIP [PRIM $ carN, MAC $ MAP_CADR xs noAnn f ops], cdrN, SWAP, pairN] + Prim <$> [DUP noAnn, DIP [Prim $ carN, Mac $ MAP_CADR xs noAnn f ops], cdrN, SWAP, pairN] expandMapCadr (D:xs) v f ops `shouldBe` - PRIM <$> [DUP noAnn, DIP [PRIM $ cdrN, MAC $ MAP_CADR xs noAnn f ops], carN, pairN] + Prim <$> [DUP noAnn, DIP [Prim $ cdrN, Mac $ MAP_CADR xs noAnn f ops], carN, pairN] where v = ann "var" f = ann "field" n = noAnn xs = [A, D] - ops = [PRIM $ DUP n] + ops = [Prim $ DUP n] carN = CAR noAnn noAnn cdrN = CDR noAnn noAnn pairN = PAIR noAnn v noAnn noAnn @@ -116,35 +125,16 @@ leaf v' f' = F (ann v', ann f') pair = P (F (n, n)) (F (n, n)) -flattenTest :: Expectation -flattenTest = do - flatten (SEQ_EX [PRIM_EX $ SWAP, PRIM_EX $ SWAP]) `shouldBe` - [SWAP, SWAP] - flatten (SEQ_EX [SEQ_EX [SEQ_EX [PRIM_EX $ SWAP], PRIM_EX $ SWAP], PRIM_EX $ SWAP]) `shouldBe` - [SWAP, SWAP, SWAP] - -expandFlatTest :: Expectation -expandFlatTest = do - expandFlat [papair] `shouldBe` Op <$> [DIP [Op $ PAIR n n n n], PAIR n n n n] - expandFlat [diiiip] `shouldBe` Op <$> [DIP [Op $ DIP [Op $ DIP [Op $ DIP[Op $ SWAP]]]]] - where - n = noAnn - papair :: ParsedOp - papair = - MAC (PAPAIR (P (F (n, n)) (P (F (n, n)) (F (n, n)))) n n) - diiiip :: ParsedOp - diiiip = MAC (DIIP 4 [PRIM SWAP]) - expandTest :: Expectation expandTest = do expand diip `shouldBe` expandedDiip - expand (PRIM $ IF [diip] [diip]) `shouldBe` (PRIM_EX $ IF [expandedDiip] [expandedDiip]) - expand (SEQ [diip, diip]) `shouldBe` (SEQ_EX $ [expandedDiip, expandedDiip]) + expand (Prim $ IF [diip] [diip]) `shouldBe` (PrimEx $ IF [expandedDiip] [expandedDiip]) + expand (Seq [diip, diip]) `shouldBe` (SeqEx $ [expandedDiip, expandedDiip]) where diip :: ParsedOp - diip = MAC (DIIP 2 [PRIM SWAP]) + diip = Mac (DIIP 2 [Prim SWAP]) expandedDiip :: ExpandedOp - expandedDiip = SEQ_EX [PRIM_EX (DIP [SEQ_EX [PRIM_EX (DIP [PRIM_EX SWAP])]])] + expandedDiip = SeqEx [PrimEx (DIP [SeqEx [PrimEx (DIP [PrimEx SWAP])]])] expandValueTest :: Expectation expandValueTest = do @@ -155,21 +145,21 @@ parsedPair :: Value ParsedOp parsedPair = ValuePair (ValueInt 5) (ValueInt 5) - expandedPair :: Value Op + expandedPair :: UntypedValue expandedPair = ValuePair (ValueInt 5) (ValueInt 5) parsedPapair :: Value ParsedOp parsedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) - expandedPapair :: Value Op + expandedPapair :: UntypedValue expandedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) parsedLambdaWithMac :: Value ParsedOp parsedLambdaWithMac = ValueLambda $ - one (MAC (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)) + one (Mac (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)) - expandedLambdaWithMac :: Value Op - expandedLambdaWithMac = ValueLambda . NE.fromList $ - [ Op {unOp = DIP [Op {unOp = PAIR noAnn noAnn noAnn noAnn}]} - , Op {unOp = PAIR noAnn noAnn noAnn noAnn} + expandedLambdaWithMac :: UntypedValue + expandedLambdaWithMac = ValueLambda . one $ SeqEx + [ PrimEx $ DIP [SeqEx $ one $ PrimEx $ PAIR noAnn noAnn noAnn noAnn] + , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] diff --git a/test/Test/Morley/Runtime.hs b/test/Test/Morley/Runtime.hs --- a/test/Test/Morley/Runtime.hs +++ b/test/Test/Morley/Runtime.hs @@ -43,10 +43,10 @@ -- -- This type is mostly used for testing purposes. data ContractAux = ContractAux - { caContract :: !(Contract Op) + { caContract :: !UntypedContract , caEnv :: !ContractEnv - , caStorage :: !(Value Op) - , caParameter :: !(Value Op) + , caStorage :: !UntypedValue + , caParameter :: !UntypedValue } data UnexpectedFailed = @@ -75,7 +75,7 @@ ] (addr,) <$> interpreterPure dummyNow dummyMaxSteps initGState interpreterOps where - toNewStorage :: InterpretUntypedResult MorleyLogs -> Value Op + toNewStorage :: InterpretUntypedResult MorleyLogs -> UntypedValue toNewStorage InterpretUntypedResult {..} = unsafeValToValue iurNewStorage handleResult :: (Address, InterpreterRes) -> Expectation @@ -99,7 +99,7 @@ isAlreadyOriginated (Left (IEAlreadyOriginated {})) = True isAlreadyOriginated _ = False -failsToOriginateIllTyped :: Value Op -> Contract Op -> Expectation +failsToOriginateIllTyped :: UntypedValue -> UntypedContract -> Expectation failsToOriginateIllTyped initialStorage illTypedContract = simpleTest ops isIllTypedContract where @@ -128,14 +128,14 @@ , caParameter = ValueString "aaa" } where - contract :: Contract Op + contract :: UntypedContract contract = Contract { para = Type tstring noAnn , stor = Type tbool noAnn , code = - [ Op $ CDR noAnn noAnn - , Op $ NIL noAnn noAnn $ Type TOperation noAnn - , Op $ PAIR noAnn noAnn noAnn noAnn + [ PrimEx $ CDR noAnn noAnn + , PrimEx $ NIL noAnn noAnn $ Type TOperation noAnn + , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] } @@ -143,10 +143,10 @@ contractAux2 = contractAux1 { caContract = (caContract contractAux1) { code = - [ Op $ CDR noAnn noAnn - , Op $ NOT noAnn - , Op $ NIL noAnn noAnn $ Type TOperation noAnn - , Op $ PAIR noAnn noAnn noAnn noAnn + [ PrimEx $ CDR noAnn noAnn + , PrimEx $ NOT noAnn + , PrimEx $ NIL noAnn noAnn $ Type TOperation noAnn + , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] } } diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs --- a/test/Test/Parser.hs +++ b/test/Test/Parser.hs @@ -43,7 +43,7 @@ (Right Mo.ValueNil) P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe` (Right . Mo.ValueLambda $ NE.fromList - [Mo.PRIM (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))] + [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 $ NE.fromList @@ -65,28 +65,28 @@ ifParsersTest :: Expectation ifParsersTest = do P.parseNoEnv P.ops "" "{IF {} {};}" `shouldBe` - (Prelude.Right [Mo.PRIM $ Mo.IF [] []]) + (Prelude.Right [Mo.Prim $ Mo.IF [] []]) P.parseNoEnv P.ops "" "{IFEQ {} {};}" `shouldBe` - (Prelude.Right [Mo.MAC $ Mo.IFX (Mo.EQ noAnn) [] []]) + (Prelude.Right [Mo.Mac $ Mo.IFX (Mo.EQ noAnn) [] []]) P.parseNoEnv P.ops "" "{IFCMPEQ {} {};}" `shouldBe` - (Prelude.Right [Mo.MAC $ Mo.IFCMP (Mo.EQ noAnn) noAnn [] []]) + (Prelude.Right [Mo.Mac $ Mo.IFCMP (Mo.EQ noAnn) noAnn [] []]) mapParsersTest :: Expectation mapParsersTest = do parseNoEnv P.ops "" "{MAP {};}" `shouldBe` - (Prelude.Right [Mo.PRIM $ Mo.MAP noAnn []]) + (Prelude.Right [Mo.Prim $ Mo.MAP noAnn []]) parseNoEnv P.ops "" "{MAP_CAR {};}" `shouldBe` - (Prelude.Right [Mo.MAC $ Mo.MAP_CADR [Mo.A] noAnn noAnn []]) + (Prelude.Right [Mo.Mac $ Mo.MAP_CADR [Mo.A] noAnn noAnn []]) pairParsersTest :: Expectation pairParsersTest = do P.parseNoEnv P.ops "" "{PAIR;}" `shouldBe` - Prelude.Right [Mo.PRIM $ PAIR noAnn noAnn noAnn noAnn] + Prelude.Right [Mo.Prim $ PAIR noAnn noAnn noAnn noAnn] P.parseNoEnv P.ops "" "{PAIR %a;}" `shouldBe` - Prelude.Right [MAC $ PAPAIR (P (F (noAnn, Mo.ann "a")) (F (noAnn,noAnn))) noAnn noAnn] + Prelude.Right [Mac $ PAPAIR (P (F (noAnn, Mo.ann "a")) (F (noAnn,noAnn))) noAnn noAnn] P.parseNoEnv P.ops "" "{PAPAIR;}" `shouldBe` Prelude.Right - [MAC $ + [Mac $ PAPAIR (P (F (noAnn,noAnn)) (P (F (noAnn,noAnn)) (F (noAnn,noAnn)))) noAnn noAnn ] 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,7 +7,9 @@ import Test.Hspec (Spec) import Test.QuickCheck (Arbitrary) -import Michelson.Untyped (Contract, Elt, FieldAnn, InstrAbstract, Op, TypeAnn, Value, VarAnn) +import Michelson.Untyped + (Elt, FieldAnn, InstrAbstract, TypeAnn, UntypedContract, UntypedValue, + VarAnn, ExpandedOp) import Tezos.Core (Mutez, Timestamp) import Test.Arbitrary () @@ -37,7 +39,7 @@ test (Proxy @Mutez) -- Michelson types - testADT (Proxy @Op) + testADT (Proxy @ExpandedOp) -- these are actually all the same thing (Annotation a), -- where a is a phantom type, @@ -47,7 +49,7 @@ test (Proxy @FieldAnn) test (Proxy @VarAnn) - test (Proxy @(Contract Op)) - testADT (Proxy @(InstrAbstract Op)) - test (Proxy @(Value Op)) - test (Proxy @(Elt Op)) + test (Proxy @UntypedContract) + testADT (Proxy @(InstrAbstract ExpandedOp)) + test (Proxy @UntypedValue) + test (Proxy @(Elt ExpandedOp)) diff --git a/test/Test/Typecheck.hs b/test/Test/Typecheck.hs --- a/test/Test/Typecheck.hs +++ b/test/Test/Typecheck.hs @@ -4,7 +4,7 @@ import Test.Hspec (Expectation, Spec, describe, expectationFailure, it) -import Michelson.Untyped (Contract(..), Op(..)) +import Michelson.Untyped (UntypedContract) import Morley.Ext (typeCheckMorleyContract) import Morley.Runtime (prepareContract) @@ -16,14 +16,14 @@ it "Reports errors on contracts examples from contracts/ill-typed" badContractsTest where doTC = either (Left . displayException) (\_ -> pure ()) . - typeCheckMorleyContract . fmap unOp + typeCheckMorleyContract goodContractsTest = mapM_ (checkFile doTC True) =<< getWellTypedContracts badContractsTest = mapM_ (checkFile doTC False) =<< getIllTypedContracts -checkFile :: (Contract Op -> Either String ()) -> Bool -> FilePath -> Expectation +checkFile :: (UntypedContract -> Either String ()) -> Bool -> FilePath -> Expectation checkFile doTypeCheck wellTyped file = do c <- prepareContract (Just file) case doTypeCheck c of