morley 0.1.0.3 → 0.1.0.4
raw patch · 39 files changed
+901/−532 lines, 39 filesdep −syb
Dependencies removed: syb
Files
- README.md +4/−1
- app/Main.hs +8/−8
- morley.cabal +3/−6
- src/Michelson/Interpret.hs +14/−13
- src/Michelson/TypeCheck/Helpers.hs +29/−19
- src/Michelson/TypeCheck/Instr.hs +24/−25
- src/Michelson/TypeCheck/Types.hs +12/−11
- src/Michelson/TypeCheck/Value.hs +7/−6
- src/Michelson/Typed.hs +14/−1
- src/Michelson/Typed/Convert.hs +25/−22
- src/Michelson/Typed/Instr.hs +4/−1
- src/Michelson/Typed/Polymorphic.hs +0/−4
- src/Michelson/Untyped.hs +10/−1
- src/Michelson/Untyped/Aliases.hs +13/−0
- src/Michelson/Untyped/Instr.hs +32/−7
- src/Morley/Aliases.hs +0/−11
- src/Morley/Ext.hs +9/−9
- src/Morley/Macro.hs +70/−91
- src/Morley/Parser.hs +16/−13
- src/Morley/Runtime.hs +12/−11
- src/Morley/Runtime/GState.hs +1/−1
- src/Morley/Runtime/TxData.hs +4/−4
- src/Morley/Test.hs +52/−2
- src/Morley/Test/Dummy.hs +3/−3
- src/Morley/Test/Import.hs +3/−5
- src/Morley/Test/Integrational.hs +177/−64
- src/Morley/Types.hs +11/−25
- src/Tezos/Address.hs +9/−0
- test/Test/Arbitrary.hs +7/−7
- test/Test/Ext.hs +2/−2
- test/Test/Interpreter.hs +16/−1
- test/Test/Interpreter/CallSelf.hs +17/−20
- test/Test/Interpreter/EnvironmentSpec.hs +104/−0
- test/Test/Interpreter/StringCaller.hs +105/−46
- test/Test/Macro.hs +51/−61
- test/Test/Morley/Runtime.hs +13/−13
- test/Test/Parser.hs +9/−9
- test/Test/Serialization/Aeson.hs +8/−6
- test/Test/Typecheck.hs +3/−3
README.md view
@@ -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
app/Main.hs view
@@ -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
morley.cabal view
@@ -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
src/Michelson/Interpret.hs view
@@ -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
src/Michelson/TypeCheck/Helpers.hs view
@@ -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
src/Michelson/TypeCheck/Instr.hs view
@@ -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
src/Michelson/TypeCheck/Types.hs view
@@ -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
src/Michelson/TypeCheck/Value.hs view
@@ -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
src/Michelson/Typed.hs view
@@ -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
src/Michelson/Typed/Convert.hs view
@@ -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
src/Michelson/Typed/Instr.hs view
@@ -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)
src/Michelson/Typed/Polymorphic.hs view
@@ -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)
src/Michelson/Untyped.hs view
@@ -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
+ src/Michelson/Untyped/Aliases.hs view
@@ -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
src/Michelson/Untyped/Instr.hs view
@@ -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
− src/Morley/Aliases.hs
@@ -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
src/Morley/Ext.hs view
@@ -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
src/Morley/Macro.hs view
@@ -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
src/Morley/Parser.hs view
@@ -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
src/Morley/Runtime.hs view
@@ -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
src/Morley/Runtime/GState.hs view
@@ -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)
src/Morley/Runtime/TxData.hs view
@@ -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
src/Morley/Test.hs view
@@ -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
src/Morley/Test/Dummy.hs view
@@ -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
src/Morley/Test/Import.hs view
@@ -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 $
src/Morley/Test/Integrational.hs view
@@ -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
src/Morley/Types.hs view
@@ -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)
src/Tezos/Address.hs view
@@ -8,6 +8,7 @@ -- * Formatting , formatAddress , parseAddress+ , unsafeParseAddress ) where import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)@@ -84,6 +85,9 @@ , ")" ] +-- | Parse an address from its human-readable textual representation+-- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or+-- fail if it's invalid. parseAddress :: Text -> Either ParseAddressError Address parseAddress addressText = case parseKeyHash addressText of@@ -91,6 +95,11 @@ Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $ parseContractAddress addressText Right keyHash -> Right (KeyAddress keyHash)++-- | Partial version of 'parseAddress' which assumes that the address+-- is correct. Can be used in tests.+unsafeParseAddress :: HasCallStack => Text -> Address+unsafeParseAddress = either (error . pretty) id . parseAddress data ParseContractAddressError = ParseContractAddressWrongBase58Check
test/Test/Arbitrary.hs view
@@ -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
test/Test/Ext.hs view
@@ -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
test/Test/Interpreter.hs view
@@ -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
test/Test/Interpreter/CallSelf.hs view
@@ -10,14 +10,14 @@ import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Michelson.Typed-import Michelson.Untyped (OriginationOperation(..), mkContractAddress)+import 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
+ test/Test/Interpreter/EnvironmentSpec.hs view
@@ -0,0 +1,104 @@+-- | Tests for the 'environment.tz' contract++module Test.Interpreter.EnvironmentSpec+ ( environmentSpec+ ) where++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Test.QuickCheck (Arbitrary(..), choose)+import Test.QuickCheck.Instances.Text ()++import Michelson.Interpret (RemainingSteps(..))+import Michelson.Typed+import 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
test/Test/Interpreter/StringCaller.hs view
@@ -1,4 +1,6 @@--- | Tests for the 'stringCaller.tz' contract.+-- | Tests for the 'stringCaller.tz' contract and its interaction with+-- the '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"
test/Test/Macro.hs view
@@ -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 ]
test/Test/Morley/Runtime.hs view
@@ -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 ] } }
test/Test/Parser.hs view
@@ -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 ]
test/Test/Serialization/Aeson.hs view
@@ -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))
test/Test/Typecheck.hs view
@@ -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