morley 0.1.0.5 → 0.2.0
raw patch · 23 files changed
+578/−173 lines, 23 filesdep +hex-textdep +wl-pprint-text
Dependencies added: hex-text, wl-pprint-text
Files
- README.md +6/−1
- app/Main.hs +15/−0
- morley.cabal +6/−1
- src/Michelson/Interpret.hs +5/−2
- src/Michelson/Printer.hs +15/−0
- src/Michelson/Printer/Util.hs +67/−0
- src/Michelson/TypeCheck/Types.hs +1/−1
- src/Michelson/Typed/Value.hs +34/−0
- src/Michelson/Untyped/Annotation.hs +22/−9
- src/Michelson/Untyped/Contract.hs +10/−3
- src/Michelson/Untyped/Instr.hs +109/−10
- src/Michelson/Untyped/Type.hs +77/−42
- src/Michelson/Untyped/Value.hs +31/−30
- src/Morley/Macro.hs +9/−6
- src/Morley/Runtime.hs +46/−21
- src/Morley/Test.hs +12/−0
- src/Morley/Test/Import.hs +43/−25
- src/Morley/Test/Integrational.hs +1/−0
- src/Morley/Types.hs +33/−15
- test/Spec.hs +2/−0
- test/Test/Interpreter/EnvironmentSpec.hs +3/−3
- test/Test/Macro.hs +4/−4
- test/Test/Printer/Michelson.hs +27/−0
README.md view
@@ -24,7 +24,12 @@ ## III: Morley-to-Michelson transpiler -Coming soon, see TM-58.+Morley-to-Michelson transpiler can be used to produce a Michelson contract from Morley contract.+You should use it if you want to develop contracts in Morley and submit them to Tezos network.+Workflow is the following:++1. If your contract is called `foo.mtz`, use `morley print --contract foo.mtz > foo.tz`. Note that normally you should not use `morley` directly, you should use `morley.sh` or `stack exec -- morley`. See usage instructions below.+2. After that you can use existing Tezos tools to deploy your contract. You can also typecheck or interpreter it using reference implementation. If you are not familiar with Tezos tooling, please read [Tezos documentation](http://tezos.gitlab.io/zeronet/index.html) or [Michelson tutoriral](https://gitlab.com/camlcase-dev/michelson-tutorial). ## IV: Testing EDSL
app/Main.hs view
@@ -15,6 +15,7 @@ import Paths_morley (version) import Text.Pretty.Simple (pPrint) +import Michelson.Printer (printUntypedContract) import Michelson.Untyped hiding (OriginationOperation(..)) import qualified Michelson.Untyped as Un import Morley.Ext (typeCheckMorleyContract)@@ -30,6 +31,7 @@ data CmdLnArgs = Parse (Maybe FilePath) Bool+ | Print (Maybe FilePath) | TypeCheck (Maybe FilePath) Bool | Run !RunOptions | Originate !OriginateOptions@@ -72,6 +74,7 @@ argParser :: Opt.Parser CmdLnArgs argParser = subparser $ parseSubCmd <>+ printSubCmd <> typecheckSubCmd <> runSubCmd <> originateSubCmd <>@@ -92,6 +95,12 @@ (uncurry TypeCheck <$> typecheckOptions) "Typecheck passed contract" + printSubCmd =+ mkCommandParser "print"+ (Print <$> printOptions)+ ("Parse a Morley contract and print corresponding Michelson " <>+ "contract that can be parsed the OCaml reference client")+ runSubCmd = mkCommandParser "run" (Run <$> runOptions) $@@ -139,6 +148,9 @@ defaultBalance :: Mutez defaultBalance = unsafeMkMutez 4000000 + printOptions :: Opt.Parser (Maybe FilePath)+ printOptions = contractFileOption+ runOptions :: Opt.Parser RunOptions runOptions = RunOptions@@ -296,6 +308,9 @@ if hasExpandMacros then pPrint $ expandContract contract else pPrint contract+ Print mFilename -> do+ contract <- prepareContract mFilename+ putStrLn $ printUntypedContract contract TypeCheck mFilename _hasVerboseFlag -> do michelsonContract <- prepareContract mFilename void $ either throwM pure $
morley.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: morley-version: 0.1.0.5+version: 0.2.0 synopsis: Developer tools for the Michelson Language description: A library to make writing smart contracts in Michelson — the smart contract@@ -26,6 +26,8 @@ hs-source-dirs: src default-language: Haskell2010 exposed-modules: Michelson.Interpret+ , Michelson.Printer+ , Michelson.Printer.Util , Michelson.TypeCheck , Michelson.Typed , Michelson.Typed.Value@@ -86,6 +88,7 @@ , data-default , fmt , formatting+ , hex-text , hspec , lens , megaparsec >= 7.0.0@@ -103,6 +106,7 @@ , singletons , mtl , vinyl+ , wl-pprint-text ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists@@ -230,6 +234,7 @@ , Test.Ext , Test.Morley.Runtime , Test.Parser+ , Test.Printer.Michelson , Test.Serialization.Aeson , Test.Tezos.Address , Test.Tezos.Crypto
src/Michelson/Interpret.hs view
@@ -79,7 +79,7 @@ deriving instance Show MichelsonFailed -instance (ConversibleExt, Buildable U.ExpandedInstr) => Buildable MichelsonFailed where+instance (ConversibleExt) => Buildable MichelsonFailed where build = \case MichelsonFailedWith (v :: Val Instr t) ->@@ -106,7 +106,7 @@ deriving instance (Buildable U.ExpandedInstr, Show s) => Show (InterpretUntypedError s) -instance (ConversibleExt, Buildable U.ExpandedInstr, Buildable s) => Buildable (InterpretUntypedError s) where+instance (ConversibleExt, Buildable s) => Buildable (InterpretUntypedError s) where build = genericF data InterpretUntypedResult s where@@ -120,6 +120,8 @@ } -> InterpretUntypedResult s +deriving instance Show s => Show (InterpretUntypedResult s)+ -- | Interpret a contract without performing any side effects. interpretUntyped :: forall s . (ExtC, Aeson.ToJSON U.ExpandedInstrExtU)@@ -219,6 +221,7 @@ -> EvalOp state (Rec (Val Instr) out) runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r runInstr i@Nop r = runInstrImpl runInstr i r+runInstr i@(Nested _) r = runInstrImpl runInstr i r runInstr i r = do rs <- gets isRemainingSteps if rs == 0
+ src/Michelson/Printer.hs view
@@ -0,0 +1,15 @@+module Michelson.Printer+ ( RenderDoc(..)+ , printDoc+ , printUntypedContract+ ) where++import qualified Data.Text.Lazy as TL++import Michelson.Printer.Util (RenderDoc(..), printDoc)+import qualified Michelson.Untyped as Un++-- | Convert an untyped contract into a textual representation which+-- will be accepted by the OCaml reference client.+printUntypedContract :: (RenderDoc op) => Un.Contract op -> TL.Text+printUntypedContract = printDoc . renderDoc
+ src/Michelson/Printer/Util.hs view
@@ -0,0 +1,67 @@+module Michelson.Printer.Util+ ( RenderDoc(..)+ , printDoc+ , renderOps+ , renderOpsList+ , spaces+ , wrapInParens+ , buildRenderDoc+ ) where++import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Builder (Builder)+import Text.PrettyPrint.Leijen.Text+ (Doc, SimpleDoc, braces, displayB, displayT, hcat, isEmpty, parens, punctuate, renderOneLine,+ semi, space, vcat, (<+>))++-- | Generalize converting a type into a+-- Text.PrettyPrint.Leijen.Text.Doc. Used to pretty print Michelson code+-- and define Fmt.Buildable instances.+class RenderDoc a where+ renderDoc :: a -> Doc+ -- | Whether a value can be represented in Michelson code.+ -- Normally either all values of some type are renderable or not renderable.+ -- However, in case of instructions we have extra instructions which should+ -- not be rendered.+ -- Note: it's not suficcient to just return 'mempty' for such instructions,+ -- because sometimes we want to print lists of instructions and we need to+ -- ignore them complete (to avoid putting redundant separators).+ isRenderable :: a -> Bool+ isRenderable _ = True++-- | Convert 'Doc' to 'Text' with a line width of 80.+printDoc :: Doc -> LT.Text+printDoc = displayT . doRender++-- | Generic way to render the different op types that get passed+-- to a contract.+renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc+renderOps oneLine = renderOpsList oneLine . toList++spacecat :: NonEmpty Doc -> Doc+spacecat = foldr (<+>) mempty+ +renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc+renderOpsList oneLine ops =+ braces $ cat' $ punctuate semi (renderDoc <$> filter isRenderable ops)+ where+ cat' = if oneLine then maybe "" spacecat . nonEmpty else vcat++-- | Create a specific number of spaces.+spaces :: Int -> Doc+spaces x = hcat $ replicate x space++-- | Wrap documents in parentheses if there are two or more in the list.+wrapInParens :: NonEmpty Doc -> Doc+wrapInParens ds =+ if (length $ filter (not . isEmpty) (toList ds)) > 1+ then parens $ foldr (<+>) mempty ds+ else foldr (<+>) mempty ds++-- | Turn something that is instance of `RenderDoc` into a `Builder`.+-- It's formatted the same way as `printDoc` formats docs.+buildRenderDoc :: RenderDoc a => a -> Builder+buildRenderDoc = displayB . doRender . renderDoc++doRender :: Doc -> SimpleDoc+doRender = renderOneLine
src/Michelson/TypeCheck/Types.hs view
@@ -127,7 +127,7 @@ | TCFailedOnValue U.UntypedValue T Text | TCOtherError Text -instance Buildable U.ExpandedInstr => Buildable TCError where+instance Buildable TCError where build = \case TCFailedOnInstr instr (SomeHST t) custom -> "Error checking expression " +| instr
src/Michelson/Typed/Value.hs view
@@ -19,6 +19,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Singletons (SingI)+import Fmt (Buildable(build), (+|), (|+)) import Michelson.EqParam import Michelson.Typed.CValue (CVal(..), FromCVal, ToCVal, fromCVal, toCVal)@@ -42,6 +43,14 @@ => CreateContract instr t cp st -> Operation instr +instance Buildable (Operation instr) where+ build =+ \case+ OpTransferTokens tt -> build tt+ OpSetDelegate sd -> build sd+ OpCreateAccount ca -> build ca+ OpCreateContract cc -> build cc+ deriving instance Show (Operation instr) instance Eq (Operation instr) where op1 == op2 = case (op1, op2) of@@ -60,10 +69,20 @@ , ttContract :: !(Val instr ('TContract p)) } deriving (Show, Eq) +instance Buildable (TransferTokens instr p) where+ build TransferTokens {..} =+ "Transfer " +| ttAmount |+ " tokens to " +| destAddr |+ ""+ where+ destAddr = case ttContract of VContract addr -> addr+ data SetDelegate = SetDelegate { sdMbKeyHash :: !(Maybe KeyHash) } deriving (Show, Eq) +instance Buildable SetDelegate where+ build (SetDelegate mbDelegate) =+ "Set delegate to " <> maybe "<nobody>" build mbDelegate+ data CreateAccount = CreateAccount { caManager :: !KeyHash , caDelegate :: !(Maybe KeyHash)@@ -71,6 +90,13 @@ , caBalance :: !Mutez } deriving (Show, Eq) +instance Buildable CreateAccount where+ build CreateAccount {..} =+ "Create a new account with manager " +| caManager |++ " and delegate " +| maybe "<nobody>" build caDelegate |++ ", spendable: " +| caSpendable |++ " and balance = " +| caBalance |+ ""+ data CreateContract instr t cp st = ( Show (instr (ContractInp cp st) (ContractOut st)) , Eq (instr (ContractInp cp st) (ContractOut st))@@ -84,6 +110,14 @@ , ccStorageVal :: !(Val instr t) , ccContractCode :: !(instr (ContractInp cp st) (ContractOut st)) }++instance Buildable (CreateContract instr t cp st) where+ build CreateContract {..} =+ "Create a new contract with manager " +| ccManager |++ " and delegate " +| maybe "<nobody>" build ccDelegate |++ ", spendable: " +| ccSpendable |++ ", delegatable: " +| ccDelegatable |++ " and balance = " +| ccBalance |+ "" deriving instance Show (CreateContract instr t cp st) deriving instance Eq (CreateContract instr t cp st)
src/Michelson/Untyped/Annotation.hs view
@@ -20,9 +20,12 @@ import Data.Data (Data(..)) import Data.Default (Default(..)) import qualified Data.Text as T-import Fmt (Buildable(build), Builder, (+|), (|+))+import Fmt (Buildable(build))+import Text.PrettyPrint.Leijen.Text (Doc, textStrict) import qualified Text.Show +import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)+ newtype Annotation tag = Annotation T.Text deriving stock (Eq, Data, Functor, Generic) deriving newtype (IsString)@@ -47,19 +50,29 @@ type FieldAnn = Annotation FieldTag type VarAnn = Annotation VarTag ++instance RenderDoc TypeAnn where+ renderDoc = renderAnnotation ":"++instance RenderDoc FieldAnn where+ renderDoc = renderAnnotation "%"++instance RenderDoc VarAnn where+ renderDoc = renderAnnotation "@"++renderAnnotation :: Doc -> Annotation tag -> Doc+renderAnnotation prefix a@(Annotation text)+ | a == noAnn = ""+ | otherwise = prefix <> (textStrict text)+ instance Buildable TypeAnn where- build = buildAnnotation ":"+ build = buildRenderDoc instance Buildable FieldAnn where- build = buildAnnotation "%"+ build = buildRenderDoc instance Buildable VarAnn where- build = buildAnnotation "@"--buildAnnotation :: Builder -> Annotation tag -> Builder-buildAnnotation prefix a@(Annotation text)- | a == noAnn = ""- | otherwise = prefix +| text |+ ""+ build = buildRenderDoc noAnn :: Annotation a noAnn = Annotation ""
src/Michelson/Untyped/Contract.hs view
@@ -10,9 +10,10 @@ import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.Data (Data(..))-import Fmt (genericF) import Formatting.Buildable (Buildable(build))+import Text.PrettyPrint.Leijen.Text (nest, semi, (<$$>), (<+>)) +import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOpsList) import Michelson.Untyped.Type (Type) type Parameter = Type@@ -23,7 +24,13 @@ , code :: [op] } deriving stock (Eq, Show, Functor, Data, Generic) -instance Buildable op => Buildable (Contract op) where- build = genericF+instance (RenderDoc op) => RenderDoc (Contract op) where+ renderDoc (Contract parameter storage code) =+ "parameter" <+> renderDoc parameter <> semi <$$>+ "storage" <+> renderDoc storage <> semi <$$>+ "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi)++instance RenderDoc op => Buildable (Contract op) where+ build = buildRenderDoc deriveJSON defaultOptions ''Contract
src/Michelson/Untyped/Instr.hs view
@@ -21,13 +21,15 @@ import qualified Data.ByteString.Lazy as BSL import Data.Data (Data(..)) import qualified Data.Kind as K-import Formatting.Buildable (Buildable)-import Fmt (Buildable(build), genericF)+import Fmt (Buildable(build), (+|), (|+))+import Prelude hiding (EQ, GT, LT)+import Text.PrettyPrint.Leijen.Text (braces, nest, (<$$>), (<+>)) +import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOpsList, spaces) import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, VarAnn)-import Michelson.Untyped.Contract (Contract)+import Michelson.Untyped.Contract (Contract(..)) import Michelson.Untyped.Type (Comparable, Type)-import Michelson.Untyped.Value (Value)+import Michelson.Untyped.Value (Value(..)) import Tezos.Address (Address, mkContractAddressRaw) import Tezos.Core (Mutez) import Tezos.Crypto (KeyHash)@@ -39,10 +41,10 @@ type Instr = InstrAbstract Op newtype Op = Op {unOp :: Instr} deriving stock (Generic)+ deriving newtype (RenderDoc, Buildable) deriving instance Eq (ExtU InstrAbstract Op) => Eq Op deriving instance Show (ExtU InstrAbstract Op) => Show Op-deriving instance Buildable Instr => Buildable Op ------------------------------------- -- Types after macroexpander@@ -60,9 +62,17 @@ deriving instance Show ExpandedInstr => Show ExpandedOp deriving instance Data ExpandedInstr => Data ExpandedOp -instance Buildable ExpandedInstr => Buildable ExpandedOp where- build = genericF+instance RenderDoc ExpandedOp where+ renderDoc (PrimEx i) = renderDoc i+ renderDoc (SeqEx i) = renderOpsList True i+ isRenderable =+ \case PrimEx i -> isRenderable i+ _ -> True +instance Buildable ExpandedOp where+ build (PrimEx expandedInstr) = "<PrimEx: "+|expandedInstr|+">"+ build (SeqEx expandedOps) = "<SeqEx: "+|expandedOps|+">"+ ------------------------------------- -- Abstract instruction -------------------------------------@@ -166,9 +176,98 @@ deriving instance Functor (ExtU InstrAbstract) => Functor InstrAbstract deriving instance (Data op, Data (ExtU InstrAbstract op)) => Data (InstrAbstract op) --- deriving instance (Buildable op, Buildable (ExtU InstrAbstract op)) => Buildable (InstrAbstract op)--- instance Buildable op => Buildable (InstrAbstract op) where--- build = genericF+instance (RenderDoc op) => RenderDoc (InstrAbstract op) where+ renderDoc = \case+ EXT _ -> ""+ DROP -> "DROP"+ DUP va -> "DUP" <+> renderDoc va+ SWAP -> "SWAP"+ PUSH va t v -> "PUSH" <+> renderDoc va <+> renderDoc t <+> renderDoc v+ SOME ta va fa -> "SOME" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa+ NONE ta va fa t -> "NONE" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa <+> renderDoc t+ UNIT ta va -> "UNIT" <+> renderDoc ta <+> renderDoc va+ IF_NONE x y -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)+ PAIR ta va fa1 fa2 -> "PAIR" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2+ CAR va fa -> "CAR" <+> renderDoc va <+> renderDoc fa+ CDR va fa -> "CDR" <+> renderDoc va <+> renderDoc fa+ LEFT ta va fa1 fa2 t -> "LEFT" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2 <+> renderDoc t+ RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2 <+> renderDoc t+ IF_LEFT x y -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)+ IF_RIGHT x y -> "IF_RIGHT" <+> nest 10 (renderOps x) <$$> spaces 9 <> nest 10 (renderOps y)+ NIL ta va t -> "NIL" <+> renderDoc ta <+> renderDoc va <+> renderDoc t+ CONS va -> "CONS" <+> renderDoc va+ IF_CONS x y -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)+ SIZE va -> "SIZE" <+> renderDoc va+ EMPTY_SET ta va t -> "EMPTY_SET" <+> renderDoc ta <+> renderDoc va <+> renderDoc t+ EMPTY_MAP ta va c t -> "EMPTY_MAP" <+> renderDoc ta <+> renderDoc va <+> renderDoc c <+> renderDoc t+ MAP va s -> "MAP" <+> renderDoc va <$$> spaces 4 <> nest 5 (renderOps s)+ ITER s -> "ITER" <+> nest 6 (renderOps s)+ MEM va -> "MEM" <+> renderDoc va+ GET va -> "GET" <+> renderDoc va+ UPDATE -> "UPDATE"+ IF x y -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y)+ LOOP s -> "LOOP" <+> nest 6 (renderOps s)+ LOOP_LEFT s -> "LOOP_LEFT" <+> nest 11 (renderOps s)+ LAMBDA va t r s -> "LAMBDA" <+> renderDoc va <+> renderDoc t <+> renderDoc r <$$> spaces 7 <> nest 8 (renderOps s)+ EXEC va -> "EXEC" <+> renderDoc va+ DIP s -> "DIP" <+> nest 5 (renderOps s)+ FAILWITH -> "FAILWITH"+ CAST va t -> "CAST" <+> renderDoc va <+> renderDoc t+ RENAME va -> "RENAME" <+> renderDoc va+ PACK va -> "PACK" <+> renderDoc va+ UNPACK va t -> "UNPACK" <+> renderDoc va <+> renderDoc t+ CONCAT va -> "CONCAT" <+> renderDoc va+ SLICE va -> "SLICE" <+> renderDoc va+ ISNAT va -> "ISNAT" <+> renderDoc va+ ADD va -> "ADD" <+> renderDoc va+ SUB va -> "SUB" <+> renderDoc va+ MUL va -> "MUL" <+> renderDoc va+ EDIV va -> "EDIV" <+> renderDoc va+ ABS va -> "ABS" <+> renderDoc va+ NEG -> "NEG"+ LSL va -> "LSL" <+> renderDoc va+ LSR va -> "LSR" <+> renderDoc va+ OR va -> "OR" <+> renderDoc va+ AND va -> "AND" <+> renderDoc va+ XOR va -> "XOR" <+> renderDoc va+ NOT va -> "NOT" <+> renderDoc va+ COMPARE va -> "COMPARE" <+> renderDoc va+ EQ va -> "EQ" <+> renderDoc va+ NEQ va -> "NEQ" <+> renderDoc va+ LT va -> "LT" <+> renderDoc va+ GT va -> "GT" <+> renderDoc va+ LE va -> "LE" <+> renderDoc va+ GE va -> "GE" <+> renderDoc va+ INT va -> "INT" <+> renderDoc va+ SELF va -> "SELF" <+> renderDoc va+ CONTRACT va t -> "CONTRACT" <+> renderDoc va <+> renderDoc t+ TRANSFER_TOKENS va -> "TRANSFER_TOKENS" <+> renderDoc va+ SET_DELEGATE va -> "SET_DELEGATE" <+> renderDoc va+ CREATE_ACCOUNT va1 va2 -> "CREATE_ACCOUNT" <+> renderDoc va1 <+> renderDoc va2+ CREATE_CONTRACT va1 va2 -> "CREATE_CONTRACT" <+> renderDoc va1 <+> renderDoc va2+ CREATE_CONTRACT2 va1 va2 contract -> "CREATE_CONTRACT" <+> renderDoc va1 <+> renderDoc va2 <$$> braces (renderDoc contract)+ IMPLICIT_ACCOUNT va -> "IMPLICIT_ACCOUNT" <+> renderDoc va+ NOW va -> "NOW" <+> renderDoc va+ AMOUNT va -> "AMOUNT" <+> renderDoc va+ BALANCE va -> "BALANCE" <+> renderDoc va+ CHECK_SIGNATURE va -> "CHECK_SIGNATURE" <+> renderDoc va+ SHA256 va -> "SHA256" <+> renderDoc va+ SHA512 va -> "SHA512" <+> renderDoc va+ BLAKE2B va -> "BLAKE2B" <+> renderDoc va+ HASH_KEY va -> "HASH_KEY" <+> renderDoc va+ STEPS_TO_QUOTA va -> "STEPS_TO_QUOTA" <+> renderDoc va+ SOURCE va -> "SOURCE" <+> renderDoc va+ SENDER va -> "SENDER" <+> renderDoc va+ ADDRESS va -> "ADDRESS" <+> renderDoc va+ where+ renderOps = renderOpsList True++ isRenderable = \case+ EXT {} -> False+ _ -> True++instance (RenderDoc op) => Buildable (InstrAbstract op) where+ build = buildRenderDoc ---------------------------------------------------------------------------- -- Contract's address computation
src/Michelson/Untyped/Type.hs view
@@ -45,11 +45,11 @@ import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.Data (Data(..))-import Data.Text.Lazy.Builder (Builder)-import Fmt ((+|), (|+)) import Formatting.Buildable (Buildable(build))+import Text.PrettyPrint.Leijen.Text (Doc, parens, (<+>)) -import Michelson.Untyped.Annotation+import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, wrapInParens)+import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, TypeAnn) import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp) import Tezos.Crypto (KeyHash)@@ -58,17 +58,85 @@ data Type = Type T TypeAnn deriving (Eq, Show, Data, Generic) +instance RenderDoc Comparable where+ renderDoc (Comparable ct ta) = renderDoc ct <+> renderDoc ta++instance RenderDoc Type where+ renderDoc (Type t ta) = renderType t (Just ta) Nothing++instance RenderDoc T where+ renderDoc t = renderType t Nothing Nothing++-- Ordering between different kinds of annotations is not significant,+-- but ordering among annotations of the same kind is. Annotations+-- of a same kind must be grouped together.+-- (prim @v :t %x arg1 arg2 ...)+-- these are equivalent+-- PAIR :t @my_pair %x %y+-- PAIR %x %y :t @my_pair+renderType :: T -> Maybe TypeAnn -> Maybe FieldAnn -> Doc+renderType t mta mfa =+ let rta = case mta of Just ta -> renderDoc ta; Nothing -> ""+ rfa = case mfa of Just fa -> renderDoc fa; Nothing -> "" in+ case t of+ Tc ct -> wrapInParens $ renderDoc ct :| [rta, rfa]+ TKey -> wrapInParens $ "key" :| [rta, rfa]+ TUnit -> wrapInParens $ "unit" :| [rta, rfa]+ TSignature -> wrapInParens $ "signature" :| [rta, rfa]+ TOperation -> wrapInParens $ "operation" :| [rta, rfa]+ TOption fa1 (Type t1 ta1) ->+ parens ("option" <+> rta <+> rfa+ <+> renderType t1 (Just ta1) (Just fa1))+ TList (Type t1 ta1) -> parens ("list" <+> rta <+> rfa <+> renderType t1 (Just ta1) Nothing)+ TSet (Comparable ct1 ta1) -> parens ("set" <+> rta <+> rfa <+> renderType (Tc ct1) (Just ta1) Nothing)+ TContract (Type t1 ta1) -> parens ("contract" <+> rta <+> rfa <+> renderType t1 (Just ta1) Nothing)++ TPair fa1 fa2 (Type t1 ta1) (Type t2 ta2) ->+ parens ("pair" <+> rta <+> rfa+ <+> (renderType t1 (Just ta1) (Just fa1))+ <+> (renderType t2 (Just ta2) (Just fa2)))++ TOr fa1 fa2 (Type t1 ta1) (Type t2 ta2) ->+ parens ("or" <+> rta <+> rfa+ <+> (renderType t1 (Just ta1) (Just fa1))+ <+> (renderType t2 (Just ta2) (Just fa2)))++ TLambda (Type t1 ta1) (Type t2 ta2) ->+ parens ("lambda" <+> rta <+> rfa+ <+> (renderType t1 (Just ta1) Nothing)+ <+> (renderType t2 (Just ta2) Nothing))++ TMap (Comparable ct1 ta1) (Type t2 ta2) ->+ parens ("map" <+> rta <+> rfa+ <+> (renderType (Tc ct1) (Just ta1) Nothing)+ <+> (renderType t2 (Just ta2) Nothing))++ TBigMap (Comparable ct1 ta1) (Type t2 ta2) ->+ parens ("big_map" <+> rta <+> rfa+ <+> (renderType (Tc ct1) (Just ta1) Nothing)+ <+> (renderType t2 (Just ta2) Nothing))++instance RenderDoc CT where+ renderDoc = \case+ CInt -> "int"+ CNat -> "nat"+ CString -> "string"+ CMutez -> "mutez"+ CBool -> "bool"+ CKeyHash -> "key_hash"+ CTimestamp -> "timestamp"+ CBytes -> "bytes"+ CAddress -> "address"+ instance Buildable Type where- build (Type t a) = t |+ " " +| a |+ ""+ build = buildRenderDoc -- Annotated Comparable Sub-type data Comparable = Comparable CT TypeAnn deriving (Eq, Show, Data, Generic) instance Buildable Comparable where- build (Comparable ct a)- | a == noAnn = build ct- | otherwise = ct |+ " " +| a |+ ""+ build = buildRenderDoc compToType :: Comparable -> Type compToType (Comparable ct tn) = Type (Tc ct) tn@@ -96,30 +164,7 @@ deriving (Eq, Show, Data, Generic) instance Buildable T where- build =- \case- Tc ct -> build ct- TKey -> "key"- TUnit -> "unit"- TSignature -> "signature"- TOption fa t -> "option (" +| t |+ " " +| fa |+ ")"- TList t -> "list (" +| t |+ ")"- TSet c -> "set (" +| c |+ ")"- TOperation -> "operation"- TContract t -> "contract " +| t |+ ""- TPair fa1 fa2 t1 t2 ->- "pair (" +| t1 |+ " " +| fa1 |+ ")"- +| " (" +| t2 |+ " " +| fa2 |+ ")"- TOr fa1 fa2 t1 t2 ->- "or (" +| t1 |+ " " +| fa1 |+ ")"- +| " (" +| t2 |+ " " +| fa2 |+ ")"- TLambda t1 t2 -> build2 "lambda" t1 t2- TMap t1 t2 -> build2 "map" t1 t2- TBigMap t1 t2 -> build2 "big_map" t1 t2- where- -- build something with 2 type parameters- build2 :: (Buildable t1, Buildable t2) => Builder -> t1 -> t2 -> Builder- build2 name t1 t2 = name |+ " (" +| t1 |+ " " +| t2 |+ ")"+ build = buildRenderDoc -- Comparable Sub-Type data CT =@@ -150,17 +195,7 @@ ToCT Timestamp = 'CTimestamp instance Buildable CT where- build =- \case- CInt -> "int"- CNat -> "nat"- CString -> "string"- CBytes -> "bytes"- CMutez -> "mutez"- CBool -> "bool"- CKeyHash -> "key_hash"- CTimestamp -> "timestamp"- CAddress -> "address"+ build = buildRenderDoc pattern Tint :: T pattern Tint <- Tc CInt
src/Michelson/Untyped/Value.hs view
@@ -5,7 +5,6 @@ module Michelson.Untyped.Value ( Value (..) , Elt (..)- -- Internal types to avoid orphan instances , InternalByteString(..) , unInternalByteString@@ -14,11 +13,13 @@ import Data.Aeson (FromJSON(..), ToJSON(..)) import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.Data (Data(..))-import Data.Text.Lazy.Builder (Builder)-import Fmt (hexF, (+|), (|+))-import Formatting.Buildable (Buildable)-import qualified Formatting.Buildable as Buildable+import qualified Data.List as L+import Formatting.Buildable (Buildable(build))+import Text.Hex (encodeHex)+import Text.PrettyPrint.Leijen.Text (braces, dquotes, parens, semi, text, textStrict, (<+>)) +import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOps)+ data Value op = ValueInt Integer | ValueString Text@@ -50,33 +51,33 @@ unInternalByteString :: InternalByteString -> ByteString unInternalByteString (InternalByteString bs) = bs -instance Buildable op => Buildable (Value op) where- build =+instance RenderDoc op => RenderDoc (Value op) where+ renderDoc = \case- ValueInt i -> Buildable.build i- ValueString s -> "\"" +| s |+ "\""- ValueBytes (InternalByteString b) -> "0x" <> hexF b- ValueUnit -> "Unit"- ValueTrue -> "True"- ValueFalse -> "False"- ValuePair a b -> "(Pair " +| a |+ " " +| b |+ ")"- ValueLeft v -> "(Left " +| v |+ ")"- ValueRight v -> "(Right " +| v |+ ")"- ValueSome v -> "(Some " +| v |+ ")"- ValueNone -> "None"- ValueNil -> "{}"- ValueSeq vs -> buildList vs- ValueMap els -> buildList els- ValueLambda ops -> buildList ops- where- buildList :: Buildable a => NonEmpty a -> Builder- buildList (toList -> items) =- "{" <>- mconcat (intersperse "; " $ map Buildable.build items) <>- "}"+ ValueNil -> "{ }"+ ValueInt x -> text . show $ x+ ValueString x -> dquotes (textStrict x)+ ValueBytes xs -> "0x" <> (textStrict . encodeHex . unInternalByteString $ xs)+ ValueUnit -> "Unit"+ ValueTrue -> "True"+ ValueFalse -> "False"+ ValuePair l r -> parens $ ("Pair" <+> renderDoc l <+> renderDoc r)+ ValueLeft l -> parens $ ("Left" <+> renderDoc l)+ ValueRight r -> parens $ ("Right" <+> renderDoc r)+ ValueSome x -> parens $ ("Some" <+> renderDoc x)+ ValueNone -> "None"+ ValueSeq xs -> braces $ mconcat $ (L.intersperse semi (renderDoc <$> toList xs))+ ValueMap xs -> braces $ mconcat $ (L.intersperse semi (renderDoc <$> toList xs))+ ValueLambda xs -> renderOps True xs -instance Buildable op => Buildable (Elt op) where- build (Elt a b) = "Elt " +| a |+ " " +| b |+ ""+instance RenderDoc op => RenderDoc (Elt op) where+ renderDoc (Elt k v) = "Elt" <+> renderDoc k <+> renderDoc v++instance (RenderDoc op) => Buildable (Value op) where+ build = buildRenderDoc++instance (RenderDoc op) => Buildable (Elt op) where+ build = buildRenderDoc ---------------------------------------------------------------------------- -- JSON serialization
src/Morley/Macro.hs view
@@ -15,20 +15,18 @@ , expandCadr , expandSetCadr , expandMapCadr- ) where - import Michelson.Untyped (UntypedContract, UntypedValue) import Morley.Types- (CadrStruct(..), Contract(..), Elt(..), ExpandedOp(..), FieldAnn,- InstrAbstract(..), LetMacro(..), Macro(..), PairStruct(..), ParsedOp(..), TypeAnn,- UExtInstrAbstract(..), Value(..), VarAnn, ann, noAnn)+ (CadrStruct(..), Contract(..), Elt(..), ExpandedOp(..), FieldAnn, InstrAbstract(..),+ LetMacro(..), Macro(..), PairStruct(..), ParsedOp(..), TypeAnn, UExtInstrAbstract(..), Value(..),+ VarAnn, ann, noAnn) expandList :: [ParsedOp] -> [ExpandedOp] expandList = fmap expand --- | Expand and flatten and instructions in parsed contract.+-- | Expand all macros in parsed contract. expandContract :: Contract ParsedOp -> UntypedContract expandContract Contract {..} = Contract para stor (expandList $ code)@@ -52,6 +50,11 @@ expandElt (Elt l r) = Elt (expandValue l) (expandValue r) expand :: ParsedOp -> ExpandedOp+-- We handle this case specially, because it's essentially just PAIR.+-- It's needed because we have a hack in parser: we parse PAIR as PAPAIR.+-- We need to do something better eventually.+expand (Mac (PAPAIR (P (F a) (F b)) t v)) =+ PrimEx $ PAIR t v (snd a) (snd b) expand (Mac m) = SeqEx $ expandMacro m expand (Prim i) = PrimEx $ expand <$> i expand (Seq s) = SeqEx $ expand <$> s
src/Morley/Runtime.hs view
@@ -8,6 +8,8 @@ , transfer -- * Other helpers+ , parseContract+ , parseExpandContract , readAndParseContract , prepareContract @@ -25,10 +27,9 @@ import Control.Lens (at, makeLenses, (%=), (.=), (<>=)) import Control.Monad.Except (Except, runExcept, throwError)-import Data.Default (def) import qualified Data.Map.Strict as Map import Data.Text.IO (getContents)-import Fmt (Buildable(build), blockListF, fmtLn, nameF, pretty, (+|), (|+))+import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+)) import Named ((:!), (:?), arg, argDef, defaults, (!)) import Text.Megaparsec (parse) @@ -46,7 +47,7 @@ import qualified Morley.Parser as P import Morley.Runtime.GState import Morley.Runtime.TxData-import Morley.Types (MorleyLogs(..), ParsedOp, noMorleyLogs)+import Morley.Types (MorleyLogs(..), ParsedOp) import Tezos.Address (Address(..)) import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez) import Tezos.Crypto (parseKeyHash)@@ -79,13 +80,15 @@ -- ^ List of operations to be added to the operations queue. , _irUpdates :: ![GStateUpdate] -- ^ Updates applied to 'GState'.- , _irPrintedLogs :: [MorleyLogs]- -- ^ During execution a contract can print logs,- -- all logs are kept until all called contracts are executed+ , _irInterpretResults :: [(Address, InterpretUntypedResult MorleyLogs)]+ -- ^ During execution a contract can print logs and in the end it returns+ -- a pair. All logs and returned values are kept until all called contracts+ -- are executed. In the end they are printed. , _irSourceAddress :: !(Maybe Address) -- ^ As soon as transfer operation is encountered, this address is -- set to its input. , _irRemainingSteps :: !RemainingSteps+ -- ^ Now much gas all remaining executions can consume. } deriving (Show) makeLenses ''InterpreterRes@@ -136,14 +139,23 @@ -- Interface ---------------------------------------------------------------------------- +-- | Parse a contract from 'Text'.+parseContract ::+ Maybe FilePath -> Text -> Either P.ParserException (Contract ParsedOp)+parseContract mFileName =+ first P.ParserException . parse P.program (fromMaybe "<stdin>" mFileName)++-- | Parse a contract from 'Text' and expand macros.+parseExpandContract ::+ Maybe FilePath -> Text -> Either P.ParserException UntypedContract+parseExpandContract mFileName = fmap expandContract . parseContract mFileName+ -- | Read and parse a contract from give path or `stdin` (if the -- argument is 'Nothing'). The contract is not expanded. readAndParseContract :: Maybe FilePath -> IO (Contract ParsedOp) readAndParseContract mFilename = do code <- readCode mFilename- let filename = fromMaybe "<stdin>" mFilename- either (throwM . P.ParserException) pure $- parse P.program filename code+ either throwM pure $ parseContract mFilename code where readCode :: Maybe FilePath -> IO Text readCode = maybe getContents readFile@@ -236,14 +248,26 @@ let eitherRes = interpreterPure now (RemainingSteps maxSteps) gState operations InterpreterRes {..} <- either throwM pure eitherRes+ mapM_ printInterpretResult _irInterpretResults when (verbose && not (null _irUpdates)) $ do fmtLn $ nameF "Updates:" (blockListF _irUpdates) putTextLn $ "Remaining gas: " <> pretty _irRemainingSteps- forM_ _irPrintedLogs $ \(MorleyLogs logs) -> do- mapM_ putTextLn logs- putTextLn "" -- extra break line to separate logs from two sequence contracts unless dryRun $ writeGState dbPath _irGState+ where+ printInterpretResult+ :: (Address, InterpretUntypedResult MorleyLogs) -> IO ()+ printInterpretResult (addr, InterpretUntypedResult {..}) = do+ putTextLn $ "Executed contract " <> pretty addr+ case iurOps of+ [] -> putTextLn "It didn't return any operations"+ _ -> fmt $ nameF "It returned operations:" (blockListF iurOps)+ putTextLn $+ "It returned storage: " <> pretty (unsafeValToValue iurNewStorage)+ let MorleyLogs logs = isExtState iurNewState+ unless (null logs) $+ mapM_ putTextLn logs+ putTextLn "" -- extra break line to separate logs from two sequence contracts -- | Implementation of interpreter outside 'IO'. It reads operations, -- interprets them one by one and updates state accordingly.@@ -256,7 +280,7 @@ { _irGState = gState , _irOperations = ops , _irUpdates = mempty- , _irPrintedLogs = def+ , _irInterpretResults = [] , _irSourceAddress = Nothing , _irRemainingSteps = maxSteps }@@ -278,7 +302,7 @@ irGState .= _irGState irOperations .= opsTail <> _irOperations irUpdates <>= _irUpdates- irPrintedLogs <>= _irPrintedLogs+ irInterpretResults <>= _irInterpretResults irSourceAddress %= (<|> _irSourceAddress) irRemainingSteps .= _irRemainingSteps statefulInterpreter now@@ -316,7 +340,7 @@ { _irGState = newGS , _irOperations = mempty , _irUpdates = updates- , _irPrintedLogs = def+ , _irInterpretResults = [] , _irSourceAddress = Nothing , _irRemainingSteps = remainingSteps }@@ -339,8 +363,9 @@ -- Subtraction is safe because we have checked its -- precondition in guard. Right (GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData))- let onlyUpdates updates = Right (updates, [], noMorleyLogs, remainingSteps)- (otherUpdates, sideEffects, logs, newRemSteps) <- case (addresses ^. at addr, addr) of+ let onlyUpdates updates = Right (updates, [], Nothing, remainingSteps)+ (otherUpdates, sideEffects, maybeInterpretRes, newRemSteps)+ <- case (addresses ^. at addr, addr) of (Nothing, ContractAddress _) -> Left (IEUnknownContract addr) (Nothing, KeyAddress _) -> do@@ -368,10 +393,10 @@ , ceSender = senderAddr , ceAmount = tdAmount txData }- InterpretUntypedResult+ iur@InterpretUntypedResult { iurOps = sideEffects , iurNewStorage = newValue- , iurNewState = InterpreterState printedLogs newRemainingSteps+ , iurNewState = InterpreterState _ newRemainingSteps } <- first (IEInterpreterFailed addr) $ interpretMorleyUntyped contract (tdParameter txData)@@ -387,7 +412,7 @@ [ updBalance , updStorage ]- Right (updates, sideEffects, printedLogs, newRemainingSteps)+ Right (updates, sideEffects, Just iur, newRemainingSteps) let updates = decreaseSenderBalance:otherUpdates@@ -398,7 +423,7 @@ { _irGState = newGState , _irOperations = mapMaybe (convertOp addr) sideEffects , _irUpdates = updates- , _irPrintedLogs = [logs]+ , _irInterpretResults = maybe mempty (one . (addr,)) maybeInterpretRes , _irSourceAddress = Just sourceAddr , _irRemainingSteps = newRemSteps }
src/Morley/Test.hs view
@@ -6,6 +6,7 @@ ( -- * Importing a contract specWithContract , specWithTypedContract+ , specWithUntypedContract -- * Unit testing , ContractReturn@@ -37,6 +38,16 @@ , expectGasExhaustion , expectMichelsonFailed + -- ** Various+ , TxData (..)+ , genesisAddress++ -- * General utilities+ , failedProp+ , succeededProp+ , qcIsLeft+ , qcIsRight+ -- * Dummy values , dummyContractEnv @@ -51,3 +62,4 @@ import Morley.Test.Import import Morley.Test.Integrational import Morley.Test.Unit+import Morley.Test.Util
src/Morley/Test/Import.hs view
@@ -1,13 +1,16 @@ -- | Functions to import contracts to be used in tests. module Morley.Test.Import- ( specWithContract+ ( readContract+ , specWithContract , specWithTypedContract+ , specWithUntypedContract , importContract+ , importUntypedContract , ImportContractError (..) ) where -import Control.Exception (IOException, mapException)+import Control.Exception (IOException) import Data.Typeable ((:~:)(..), TypeRep, eqT, typeRep) import Fmt (Buildable(build), pretty, (+|), (|+), (||+)) import Test.Hspec (Spec, describe, expectationFailure, it, runIO)@@ -15,8 +18,9 @@ import Michelson.TypeCheck (SomeContract(..), TCError) import Michelson.Typed (Contract) import qualified Michelson.Untyped as U+import Michelson.Untyped.Aliases (UntypedContract) import Morley.Ext (typeCheckMorleyContract)-import Morley.Runtime (prepareContract)+import Morley.Runtime (parseExpandContract, prepareContract) import Morley.Types (ParserException(..)) -- | Import contract and use it in the spec. Both versions of contract are@@ -27,23 +31,44 @@ -- result will notify about problem). specWithContract :: (Typeable cp, Typeable st)- => FilePath -> ((U.UntypedContract, Contract cp st) -> Spec) -> Spec-specWithContract file execSpec =- either errorSpec (describe ("Test contract " <> file) . execSpec)- =<< runIO- ( (Right <$> importContract file)- `catch` (\(e :: ImportContractError) -> pure $ Left $ displayException e)- `catch` \(e :: IOException) -> pure $ Left $ displayException e )- where- errorSpec = it ("Type check contract " <> file) . expectationFailure+ => FilePath -> ((UntypedContract, Contract cp st) -> Spec) -> Spec+specWithContract = specWithContractImpl importContract -- | A version of 'specWithContract' which passes only the typed -- representation of the contract. specWithTypedContract :: (Typeable cp, Typeable st) => FilePath -> (Contract cp st -> Spec) -> Spec-specWithTypedContract file execSpec = specWithContract file (execSpec . snd)+specWithTypedContract = specWithContractImpl (fmap snd . importContract) +specWithUntypedContract :: FilePath -> (UntypedContract -> Spec) -> Spec+specWithUntypedContract = specWithContractImpl importUntypedContract++specWithContractImpl+ :: (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec+specWithContractImpl doImport file execSpec =+ either errorSpec (describe ("Test contract " <> file) . execSpec)+ =<< runIO+ ( (Right <$> doImport file)+ `catch` (\(e :: ImportContractError) -> pure $ Left $ displayException e)+ `catch` \(e :: IOException) -> pure $ Left $ displayException e )+ where+ errorSpec = it ("Import contract " <> file) . expectationFailure++readContract+ :: forall cp st .+ (Typeable cp, Typeable st)+ => FilePath -> Text -> Either ImportContractError (UntypedContract, Contract cp st)+readContract filePath txt = do+ contract <- first ICEParse $ parseExpandContract (Just filePath) txt+ SomeContract (instr :: Contract cp' st') _ _+ <- first ICETypeCheck $ typeCheckMorleyContract contract+ case (eqT @cp @cp', eqT @st @st') of+ (Just Refl, Just Refl) -> pure (contract, instr)+ (Nothing, _) -> Left $+ ICEUnexpectedParamType (U.para contract) (typeRep (Proxy @cp))+ _ -> Left (ICEUnexpectedStorageType (U.stor contract) (typeRep (Proxy @st)))+ -- | Import contract from a given file path. -- -- This function reads file, parses and type checks contract.@@ -52,18 +77,11 @@ importContract :: forall cp st . (Typeable cp, Typeable 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 contract- case (eqT @cp @cp', eqT @st @st') of- (Just Refl, Just Refl) -> pure (contract, instr)- (Nothing, _) -> throwM $- ICEUnexpectedParamType (U.para contract) (typeRep (Proxy @cp))- _ -> throwM (ICEUnexpectedStorageType (U.stor contract) (typeRep (Proxy @st)))- where- assertEither err action = either (throwM . err) pure =<< action+ => FilePath -> IO (UntypedContract, Contract cp st)+importContract file = either throwM pure =<< readContract file <$> readFile file++importUntypedContract :: FilePath -> IO UntypedContract+importUntypedContract = prepareContract . Just -- | Error type for 'importContract' function. data ImportContractError
src/Morley/Test/Integrational.hs view
@@ -5,6 +5,7 @@ ( -- * Re-exports TxData (..)+ , genesisAddress -- * Testing engine , IntegrationalValidator
src/Morley/Types.hs view
@@ -87,17 +87,19 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T-import Fmt (Buildable(build), Builder, genericF, listF)+import Fmt (Buildable(build), Builder, genericF, listF, (+|), (|+)) import Text.Megaparsec (ParseErrorBundle, Parsec, ShowErrorComponent(..), errorBundlePretty)+import qualified Text.PrettyPrint.Leijen.Text as PP (empty) import qualified Text.Show (show) import Michelson.EqParam (eqParam2)+import Michelson.Printer (RenderDoc(..)) import Michelson.Typed (instrToOps) import qualified Michelson.Typed as T import Michelson.Untyped- (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), ExpandedInstr, ExpandedOp (..), 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(..)) -------------------------------------@@ -169,7 +171,7 @@ build = genericF -- TODO replace ParsedOp in ExpandedUExtInstr with op--- to reflect Parsed, Epxanded and Flattened phase+-- to reflect Parsed, Expanded and Flattened phase type instance ExtU InstrAbstract = UExtInstrAbstract type instance T.ExtT T.Instr = ExtInstr@@ -191,20 +193,18 @@ | Seq [ParsedOp] -- ^ A sequence of instructions deriving (Eq, Show, Data, Generic) -instance Buildable ParsedInstr where- build = genericF+-- dummy value+instance RenderDoc ParsedOp where+ renderDoc _ = PP.empty instance Buildable ParsedOp where- build = genericF+ build (Prim parseInstr) = "<Prim: "+|parseInstr|+">"+ build (Mac macro) = "<Mac: "+|macro|+">"+ build (LMac letMacro) = "<LMac: "+|letMacro|+">"+ build (Seq parsedOps) = "<Seq: "+|parsedOps|+">" type ExpandedUExtInstr = UExtInstrAbstract ExpandedOp -instance Buildable ExpandedInstr where- build = genericF--instance Buildable Instr where- build = genericF- --------------------------------------------------- data TestAssert where@@ -290,7 +290,25 @@ deriving (Eq, Show, Data, Generic) instance Buildable Macro where- build = genericF+ build (CMP parsedInstr carAnn) = "<CMP: "+|parsedInstr|+", "+|carAnn|+">"+ build (IFX parsedInstr parsedOps1 parsedOps2) = "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"+ build (IFCMP parsedInstr varAnn parsedOps1 parsedOps2) = "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"+ build FAIL = "FAIL"+ build (PAPAIR pairStruct typeAnn varAnn) = "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"+ build (UNPAIR pairStruct) = "<UNPAIR: "+|pairStruct|+">"+ build (CADR cadrStructs varAnn fieldAnn) = "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+ build (SET_CADR cadrStructs varAnn fieldAnn) = "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"+ build (MAP_CADR cadrStructs varAnn fieldAnn parsedOps) = "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"+ build (DIIP integer parsedOps) = "<DIIP: "+|integer|+", "+|parsedOps|+">"+ build (DUUP integer varAnn) = "<DUUP: "+|integer|+", "+|varAnn|+">"+ build ASSERT = "ASSERT"+ build (ASSERTX parsedInstr) = "<ASSERTX: "+|parsedInstr|+">"+ build (ASSERT_CMP parsedInstr) = "<ASSERT_CMP: "+|parsedInstr|+">"+ build ASSERT_NONE = "ASSERT_NONE"+ build ASSERT_SOME = "ASSERT_SOME"+ build ASSERT_LEFT = "ASSERT_LEFT"+ build ASSERT_RIGHT = "ASSERT_RIGHT"+ build (IF_SOME parsedOps1 parsedOps2) = "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">" ---------------------------------------------------
test/Spec.hs view
@@ -10,6 +10,7 @@ import qualified Test.Morley.Runtime as Morley.Runtime import qualified Test.Ext as Ext import qualified Test.Parser as Parser+import qualified Test.Printer.Michelson as Printer.Michelson import qualified Test.Serialization.Aeson as Serialization.Aeson import qualified Test.Tezos.Address as Tezos.Address import qualified Test.Tezos.Crypto as Tezos.Crypto@@ -31,3 +32,4 @@ Interpreter.spec Val.spec CVal.spec+ Printer.Michelson.spec
test/Test/Interpreter/EnvironmentSpec.hs view
@@ -34,7 +34,7 @@ instance Arbitrary Fixture where arbitrary = do fNow <- timestampFromSeconds @Int <$> choose (100000, 111111)- fMaxSteps <- RemainingSteps <$> choose (1000, 1200)+ fMaxSteps <- RemainingSteps <$> choose (1015, 1028) fPassOriginatedAddress <- arbitrary fBalance <- unsafeMkMutez <$> choose (1, 1234) fAmount <- unsafeMkMutez <$> choose (1, 42)@@ -54,14 +54,14 @@ | fMaxSteps fixture - consumedGas > 1000 = Untyped.ValueTrue | otherwise = Untyped.ValueFalse where- consumedGas = 20+ consumedGas = 19 specImpl :: (UntypedContract, Contract ('Tc 'CAddress) ('Tc 'CBool)) -> Spec specImpl (uEnvironment, _environment) = do let scenario = integrationalScenario uEnvironment- modifyMaxSuccess (min 12) $+ modifyMaxSuccess (min 50) $ prop description $ integrationalTestExpectation . scenario where
test/Test/Macro.hs view
@@ -24,10 +24,10 @@ expandPapair (P leaf pair) n n `shouldBe` [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]]+ [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)]]),+ [SeqEx [PrimEx (PAIR n n n n),+ PrimEx (DIP [PrimEx (PAIR n n n n)]), PrimEx (PAIR n n n n)]] where n = noAnn@@ -160,6 +160,6 @@ expandedLambdaWithMac :: UntypedValue expandedLambdaWithMac = ValueLambda . one $ SeqEx- [ PrimEx $ DIP [SeqEx $ one $ PrimEx $ PAIR noAnn noAnn noAnn noAnn]+ [ PrimEx $ DIP [PrimEx $ PAIR noAnn noAnn noAnn noAnn] , PrimEx $ PAIR noAnn noAnn noAnn noAnn ]
+ test/Test/Printer/Michelson.hs view
@@ -0,0 +1,27 @@+module Test.Printer.Michelson+ ( spec+ ) where++import Fmt (pretty)+import Test.Hspec (Spec, describe, it, runIO, shouldBe)++import Michelson.Printer (printUntypedContract)+import Morley.Runtime (parseExpandContract)+import Morley.Test (specWithUntypedContract)++import Test.Util.Contracts (getWellTypedContracts)++spec :: Spec+spec = describe "Michelson.TzPrinter.printUntypedContract" $ do+ contractFiles <- runIO getWellTypedContracts+ mapM_ roundtripPrintTest contractFiles++roundtripPrintTest :: FilePath -> Spec+roundtripPrintTest filePath =+ -- these are untyped and expanded contracts, they might have macros+ specWithUntypedContract filePath $ \contract1 ->+ it "roundtrip printUntypedContract test" $ do+ case parseExpandContract (Just filePath) (toText $ printUntypedContract contract1) of+ Left err -> fail ("Failed to read 'printUntypedContract contract1': " ++ pretty err)+ Right contract2 ->+ printUntypedContract contract1 `shouldBe` printUntypedContract contract2