From cb1aa44ff4558a9b2af006fd41a091dcf8aa1d42 Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 8 Sep 2019 12:17:24 +0200 Subject: [PATCH 01/53] moving stuff around --- src/{ => passes}/operators/dune | 0 src/{ => passes}/operators/helpers.ml | 0 src/{ => passes}/operators/operators.ml | 0 src/{ => passes}/parser/camligo/.gitignore | 0 src/{ => passes}/parser/camligo/ast.ml | 0 src/{ => passes}/parser/camligo/dune | 0 src/{ => passes}/parser/camligo/generator.ml | 0 src/{ => passes}/parser/camligo/lex/dune | 0 .../parser/camligo/lex/generator.ml | 0 src/{ => passes}/parser/camligo/location.ml | 0 .../parser/camligo/parser_camligo.ml | 0 .../parser/camligo/pre_parser.mly | 0 src/{ => passes}/parser/camligo/user.ml | 0 src/{ => passes}/parser/dune | 0 .../parser/generator/doc/essai.ml | 0 .../parser/generator/doc/mini_ml.bnf | 0 .../parser/generator/doc/mini_ml2.bnf | 0 .../parser/generator/doc/mini_ml3.bnf | 0 .../parser/generator/doc/mini_ml4.bnf | 0 src/{ => passes}/parser/ligodity.ml | 0 src/{ => passes}/parser/ligodity/.AST.ml.tag | 0 src/{ => passes}/parser/ligodity/.Eval.ml.tag | 0 .../parser/ligodity/.EvalMain.ml.tag | 0 .../parser/ligodity/.Lexer.ml.tag | 0 .../parser/ligodity/.LexerMain.tag | 0 .../parser/ligodity/.Parser.ml.tag | 0 .../parser/ligodity/.Parser.mly.tag | 0 .../parser/ligodity/.ParserMain.tag | 0 src/{ => passes}/parser/ligodity/.links | 0 src/{ => passes}/parser/ligodity/AST.ml | 0 src/{ => passes}/parser/ligodity/AST.mli | 0 src/{ => passes}/parser/ligodity/EvalOpt.ml | 0 src/{ => passes}/parser/ligodity/EvalOpt.mli | 0 src/{ => passes}/parser/ligodity/Lexer.mli | 0 src/{ => passes}/parser/ligodity/Lexer.mll | 0 src/{ => passes}/parser/ligodity/LexerMain.ml | 0 src/{ => passes}/parser/ligodity/ParToken.mly | 0 src/{ => passes}/parser/ligodity/Parser.mly | 0 .../parser/ligodity/ParserMain.ml | 0 .../parser/ligodity/Stubs/Simple_utils.ml | 0 .../parser/ligodity/Tests/match.mml | 0 src/{ => passes}/parser/ligodity/Token.ml | 0 src/{ => passes}/parser/ligodity/Token.mli | 0 src/{ => passes}/parser/ligodity/Utils.ml | 0 src/{ => passes}/parser/ligodity/Utils.mli | 0 .../parser/ligodity/check_dot_git_is_dir.sh | 0 src/{ => passes}/parser/ligodity/dune | 0 src/{ => passes}/parser/ligodity/ligodity.ml | 0 src/{ => passes}/parser/parser.ml | 0 src/{ => passes}/parser/pascaligo.ml | 0 .../parser/pascaligo/.Lexer.ml.tag | 0 .../parser/pascaligo/.LexerMain.tag | 0 .../parser/pascaligo/.Parser.mly.tag | 0 .../parser/pascaligo/.ParserMain.tag | 0 src/{ => passes}/parser/pascaligo/.gitignore | 0 src/{ => passes}/parser/pascaligo/.links | 0 src/{ => passes}/parser/pascaligo/AST.ml | 0 src/{ => passes}/parser/pascaligo/AST.mli | 0 .../parser/pascaligo/Doc/pascaligo.txt | 0 .../parser/pascaligo/Doc/pascaligo_01.bnf | 0 .../parser/pascaligo/Doc/pascaligo_02.bnf | 0 .../parser/pascaligo/Doc/pascaligo_03.bnf | 0 .../parser/pascaligo/Doc/pascaligo_04.bnf | 0 .../parser/pascaligo/Doc/pascaligo_05.bnf | 0 .../parser/pascaligo/Doc/pascaligo_06.bnf | 0 .../parser/pascaligo/Doc/pascaligo_07.bnf | 0 .../parser/pascaligo/Doc/pascaligo_08.bnf | 0 .../parser/pascaligo/Doc/pascaligo_09.bnf | 0 .../parser/pascaligo/Doc/pascaligo_10.bnf | 0 .../parser/pascaligo/Doc/pascaligo_11.bnf | 0 .../parser/pascaligo/Doc/pascaligo_12.bnf | 0 .../parser/pascaligo/LexToken.mli | 0 .../parser/pascaligo/LexToken.mll | 0 .../parser/pascaligo/LexerMain.ml | 0 .../parser/pascaligo/ParToken.mly | 0 src/{ => passes}/parser/pascaligo/Parser.mly | 0 .../parser/pascaligo/ParserLog.ml | 0 .../parser/pascaligo/ParserLog.mli | 0 .../parser/pascaligo/ParserMain.ml | 0 .../parser/pascaligo/Stubs/Simple_utils.ml | 0 .../parser/pascaligo/Tests/a.ligo | 0 .../parser/pascaligo/Tests/crowdfunding.ligo | 0 .../parser/pascaligo/check_dot_git_is_dir.sh | 0 src/{ => passes}/parser/pascaligo/dune | 0 .../parser/pascaligo/pascaligo.ml | 0 src/{ => passes}/parser/shared/.links | 0 src/{ => passes}/parser/shared/Doc/shared.txt | 0 src/{ => passes}/parser/shared/Error.mli | 0 src/{ => passes}/parser/shared/EvalOpt.ml | 0 src/{ => passes}/parser/shared/EvalOpt.mli | 0 src/{ => passes}/parser/shared/FQueue.ml | 0 src/{ => passes}/parser/shared/FQueue.mli | 0 src/{ => passes}/parser/shared/Lexer.mli | 0 src/{ => passes}/parser/shared/Lexer.mll | 0 src/{ => passes}/parser/shared/LexerLog.ml | 0 src/{ => passes}/parser/shared/LexerLog.mli | 0 src/{ => passes}/parser/shared/Markup.ml | 0 src/{ => passes}/parser/shared/Markup.mli | 0 src/{ => passes}/parser/shared/Utils.ml | 0 src/{ => passes}/parser/shared/Utils.mli | 0 src/{ => passes}/parser/shared/dune | 0 src/{ => passes}/simplify/camligo.ml.old | 0 src/{ => passes}/simplify/dune | 0 src/{ => passes}/simplify/ligodity.ml | 0 src/{ => passes}/simplify/pascaligo.ml | 0 src/{ => passes}/simplify/simplify.ml | 0 src/{ => passes}/typer/dune | 0 src/{ => passes}/typer/typer.ml | 0 src/{ => run}/main/display.ml | 0 src/{ => run}/main/dune | 0 src/{ => run}/main/main.ml | 0 src/{ => run}/main/run_mini_c.ml | 0 src/{ => run}/main/run_simplified.ml | 0 src/{ => run}/main/run_source.ml | 0 src/{ => run}/main/run_typed.ml | 0 src/{ => stages}/ast_simplified/PP.ml | 0 .../ast_simplified/ast_simplified.ml | 0 .../ast_simplified/combinators.ml | 0 src/{ => stages}/ast_simplified/dune | 0 src/{ => stages}/ast_simplified/misc.ml | 0 src/{ => stages}/ast_simplified/types.ml | 0 src/{ => stages}/ast_typed/PP.ml | 0 src/{ => stages}/ast_typed/ast_typed.ml | 0 src/{ => stages}/ast_typed/combinators.ml | 0 .../ast_typed/combinators_environment.ml | 0 src/{ => stages}/ast_typed/dune | 0 src/{ => stages}/ast_typed/environment.ml | 0 src/{ => stages}/ast_typed/misc.ml | 0 src/{ => stages}/ast_typed/misc_smart.ml | 0 src/{ => stages}/ast_typed/types.ml | 0 src/{ => stages}/compiler/compiler.ml | 0 .../compiler/compiler_environment.ml | 0 src/{ => stages}/compiler/compiler_program.ml | 0 src/{ => stages}/compiler/compiler_type.ml | 0 src/{ => stages}/compiler/dune | 0 src/{ => stages}/compiler/uncompiler.ml | 0 src/{ => stages}/mini_c/PP.ml | 0 src/{ => stages}/mini_c/combinators.ml | 0 src/{ => stages}/mini_c/combinators_smart.ml | 0 src/{ => stages}/mini_c/dune | 0 src/{ => stages}/mini_c/environment.ml | 0 src/{ => stages}/mini_c/mini_c.ml | 0 src/{ => stages}/mini_c/types.ml | 0 src/{ => stages}/transpiler/dune | 0 src/{ => stages}/transpiler/transpiler.ml | 0 {src/test => test}/.gitignore | 0 test/.merlin | 187 ++++++++++++++++++ {src/test => test}/bin_tests.ml | 0 {src/test => test}/coase_tests.ml | 0 {src/test => test}/compiler_tests.ml | 0 {src/test => test}/dune | 0 {src/test => test}/heap_tests.ml | 0 {src/test => test}/integration_tests.ml | 0 {src/test => test}/manual_test.ml | 0 {src/test => test}/multifix_tests.ml | 0 {src/test => test}/test.ml | 0 {src/test => test}/test_helpers.ml | 0 {src/test => test}/transpiler_tests.ml | 0 {src/test => test}/typer_tests.ml | 0 {src/test => test}/vote_tests.ml | 0 {src => vendors}/rope/rope.ml | 0 {src => vendors}/rope/rope.mli | 0 {src => vendors}/rope/rope_implementation.ml | 0 {src => vendors}/rope/rope_implementation.mli | 0 {src => vendors}/rope/rope_test.ml | 0 {src => vendors}/rope/rope_top_level_open.ml | 0 {src => vendors}/rope/rope_top_level_open.mli | 0 167 files changed, 187 insertions(+) rename src/{ => passes}/operators/dune (100%) rename src/{ => passes}/operators/helpers.ml (100%) rename src/{ => passes}/operators/operators.ml (100%) rename src/{ => passes}/parser/camligo/.gitignore (100%) rename src/{ => passes}/parser/camligo/ast.ml (100%) rename src/{ => passes}/parser/camligo/dune (100%) rename src/{ => passes}/parser/camligo/generator.ml (100%) rename src/{ => passes}/parser/camligo/lex/dune (100%) rename src/{ => passes}/parser/camligo/lex/generator.ml (100%) rename src/{ => passes}/parser/camligo/location.ml (100%) rename src/{ => passes}/parser/camligo/parser_camligo.ml (100%) rename src/{ => passes}/parser/camligo/pre_parser.mly (100%) rename src/{ => passes}/parser/camligo/user.ml (100%) rename src/{ => passes}/parser/dune (100%) rename src/{ => passes}/parser/generator/doc/essai.ml (100%) rename src/{ => passes}/parser/generator/doc/mini_ml.bnf (100%) rename src/{ => passes}/parser/generator/doc/mini_ml2.bnf (100%) rename src/{ => passes}/parser/generator/doc/mini_ml3.bnf (100%) rename src/{ => passes}/parser/generator/doc/mini_ml4.bnf (100%) rename src/{ => passes}/parser/ligodity.ml (100%) rename src/{ => passes}/parser/ligodity/.AST.ml.tag (100%) rename src/{ => passes}/parser/ligodity/.Eval.ml.tag (100%) rename src/{ => passes}/parser/ligodity/.EvalMain.ml.tag (100%) rename src/{ => passes}/parser/ligodity/.Lexer.ml.tag (100%) rename src/{ => passes}/parser/ligodity/.LexerMain.tag (100%) rename src/{ => passes}/parser/ligodity/.Parser.ml.tag (100%) rename src/{ => passes}/parser/ligodity/.Parser.mly.tag (100%) rename src/{ => passes}/parser/ligodity/.ParserMain.tag (100%) rename src/{ => passes}/parser/ligodity/.links (100%) rename src/{ => passes}/parser/ligodity/AST.ml (100%) rename src/{ => passes}/parser/ligodity/AST.mli (100%) rename src/{ => passes}/parser/ligodity/EvalOpt.ml (100%) rename src/{ => passes}/parser/ligodity/EvalOpt.mli (100%) rename src/{ => passes}/parser/ligodity/Lexer.mli (100%) rename src/{ => passes}/parser/ligodity/Lexer.mll (100%) rename src/{ => passes}/parser/ligodity/LexerMain.ml (100%) rename src/{ => passes}/parser/ligodity/ParToken.mly (100%) rename src/{ => passes}/parser/ligodity/Parser.mly (100%) rename src/{ => passes}/parser/ligodity/ParserMain.ml (100%) rename src/{ => passes}/parser/ligodity/Stubs/Simple_utils.ml (100%) rename src/{ => passes}/parser/ligodity/Tests/match.mml (100%) rename src/{ => passes}/parser/ligodity/Token.ml (100%) rename src/{ => passes}/parser/ligodity/Token.mli (100%) rename src/{ => passes}/parser/ligodity/Utils.ml (100%) rename src/{ => passes}/parser/ligodity/Utils.mli (100%) rename src/{ => passes}/parser/ligodity/check_dot_git_is_dir.sh (100%) rename src/{ => passes}/parser/ligodity/dune (100%) rename src/{ => passes}/parser/ligodity/ligodity.ml (100%) rename src/{ => passes}/parser/parser.ml (100%) rename src/{ => passes}/parser/pascaligo.ml (100%) rename src/{ => passes}/parser/pascaligo/.Lexer.ml.tag (100%) rename src/{ => passes}/parser/pascaligo/.LexerMain.tag (100%) rename src/{ => passes}/parser/pascaligo/.Parser.mly.tag (100%) rename src/{ => passes}/parser/pascaligo/.ParserMain.tag (100%) rename src/{ => passes}/parser/pascaligo/.gitignore (100%) rename src/{ => passes}/parser/pascaligo/.links (100%) rename src/{ => passes}/parser/pascaligo/AST.ml (100%) rename src/{ => passes}/parser/pascaligo/AST.mli (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo.txt (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_01.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_02.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_03.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_04.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_05.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_06.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_07.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_08.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_09.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_10.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_11.bnf (100%) rename src/{ => passes}/parser/pascaligo/Doc/pascaligo_12.bnf (100%) rename src/{ => passes}/parser/pascaligo/LexToken.mli (100%) rename src/{ => passes}/parser/pascaligo/LexToken.mll (100%) rename src/{ => passes}/parser/pascaligo/LexerMain.ml (100%) rename src/{ => passes}/parser/pascaligo/ParToken.mly (100%) rename src/{ => passes}/parser/pascaligo/Parser.mly (100%) rename src/{ => passes}/parser/pascaligo/ParserLog.ml (100%) rename src/{ => passes}/parser/pascaligo/ParserLog.mli (100%) rename src/{ => passes}/parser/pascaligo/ParserMain.ml (100%) rename src/{ => passes}/parser/pascaligo/Stubs/Simple_utils.ml (100%) rename src/{ => passes}/parser/pascaligo/Tests/a.ligo (100%) rename src/{ => passes}/parser/pascaligo/Tests/crowdfunding.ligo (100%) rename src/{ => passes}/parser/pascaligo/check_dot_git_is_dir.sh (100%) rename src/{ => passes}/parser/pascaligo/dune (100%) rename src/{ => passes}/parser/pascaligo/pascaligo.ml (100%) rename src/{ => passes}/parser/shared/.links (100%) rename src/{ => passes}/parser/shared/Doc/shared.txt (100%) rename src/{ => passes}/parser/shared/Error.mli (100%) rename src/{ => passes}/parser/shared/EvalOpt.ml (100%) rename src/{ => passes}/parser/shared/EvalOpt.mli (100%) rename src/{ => passes}/parser/shared/FQueue.ml (100%) rename src/{ => passes}/parser/shared/FQueue.mli (100%) rename src/{ => passes}/parser/shared/Lexer.mli (100%) rename src/{ => passes}/parser/shared/Lexer.mll (100%) rename src/{ => passes}/parser/shared/LexerLog.ml (100%) rename src/{ => passes}/parser/shared/LexerLog.mli (100%) rename src/{ => passes}/parser/shared/Markup.ml (100%) rename src/{ => passes}/parser/shared/Markup.mli (100%) rename src/{ => passes}/parser/shared/Utils.ml (100%) rename src/{ => passes}/parser/shared/Utils.mli (100%) rename src/{ => passes}/parser/shared/dune (100%) rename src/{ => passes}/simplify/camligo.ml.old (100%) rename src/{ => passes}/simplify/dune (100%) rename src/{ => passes}/simplify/ligodity.ml (100%) rename src/{ => passes}/simplify/pascaligo.ml (100%) rename src/{ => passes}/simplify/simplify.ml (100%) rename src/{ => passes}/typer/dune (100%) rename src/{ => passes}/typer/typer.ml (100%) rename src/{ => run}/main/display.ml (100%) rename src/{ => run}/main/dune (100%) rename src/{ => run}/main/main.ml (100%) rename src/{ => run}/main/run_mini_c.ml (100%) rename src/{ => run}/main/run_simplified.ml (100%) rename src/{ => run}/main/run_source.ml (100%) rename src/{ => run}/main/run_typed.ml (100%) rename src/{ => stages}/ast_simplified/PP.ml (100%) rename src/{ => stages}/ast_simplified/ast_simplified.ml (100%) rename src/{ => stages}/ast_simplified/combinators.ml (100%) rename src/{ => stages}/ast_simplified/dune (100%) rename src/{ => stages}/ast_simplified/misc.ml (100%) rename src/{ => stages}/ast_simplified/types.ml (100%) rename src/{ => stages}/ast_typed/PP.ml (100%) rename src/{ => stages}/ast_typed/ast_typed.ml (100%) rename src/{ => stages}/ast_typed/combinators.ml (100%) rename src/{ => stages}/ast_typed/combinators_environment.ml (100%) rename src/{ => stages}/ast_typed/dune (100%) rename src/{ => stages}/ast_typed/environment.ml (100%) rename src/{ => stages}/ast_typed/misc.ml (100%) rename src/{ => stages}/ast_typed/misc_smart.ml (100%) rename src/{ => stages}/ast_typed/types.ml (100%) rename src/{ => stages}/compiler/compiler.ml (100%) rename src/{ => stages}/compiler/compiler_environment.ml (100%) rename src/{ => stages}/compiler/compiler_program.ml (100%) rename src/{ => stages}/compiler/compiler_type.ml (100%) rename src/{ => stages}/compiler/dune (100%) rename src/{ => stages}/compiler/uncompiler.ml (100%) rename src/{ => stages}/mini_c/PP.ml (100%) rename src/{ => stages}/mini_c/combinators.ml (100%) rename src/{ => stages}/mini_c/combinators_smart.ml (100%) rename src/{ => stages}/mini_c/dune (100%) rename src/{ => stages}/mini_c/environment.ml (100%) rename src/{ => stages}/mini_c/mini_c.ml (100%) rename src/{ => stages}/mini_c/types.ml (100%) rename src/{ => stages}/transpiler/dune (100%) rename src/{ => stages}/transpiler/transpiler.ml (100%) rename {src/test => test}/.gitignore (100%) create mode 100644 test/.merlin rename {src/test => test}/bin_tests.ml (100%) rename {src/test => test}/coase_tests.ml (100%) rename {src/test => test}/compiler_tests.ml (100%) rename {src/test => test}/dune (100%) rename {src/test => test}/heap_tests.ml (100%) rename {src/test => test}/integration_tests.ml (100%) rename {src/test => test}/manual_test.ml (100%) rename {src/test => test}/multifix_tests.ml (100%) rename {src/test => test}/test.ml (100%) rename {src/test => test}/test_helpers.ml (100%) rename {src/test => test}/transpiler_tests.ml (100%) rename {src/test => test}/typer_tests.ml (100%) rename {src/test => test}/vote_tests.ml (100%) rename {src => vendors}/rope/rope.ml (100%) rename {src => vendors}/rope/rope.mli (100%) rename {src => vendors}/rope/rope_implementation.ml (100%) rename {src => vendors}/rope/rope_implementation.mli (100%) rename {src => vendors}/rope/rope_test.ml (100%) rename {src => vendors}/rope/rope_top_level_open.ml (100%) rename {src => vendors}/rope/rope_top_level_open.mli (100%) diff --git a/src/operators/dune b/src/passes/operators/dune similarity index 100% rename from src/operators/dune rename to src/passes/operators/dune diff --git a/src/operators/helpers.ml b/src/passes/operators/helpers.ml similarity index 100% rename from src/operators/helpers.ml rename to src/passes/operators/helpers.ml diff --git a/src/operators/operators.ml b/src/passes/operators/operators.ml similarity index 100% rename from src/operators/operators.ml rename to src/passes/operators/operators.ml diff --git a/src/parser/camligo/.gitignore b/src/passes/parser/camligo/.gitignore similarity index 100% rename from src/parser/camligo/.gitignore rename to src/passes/parser/camligo/.gitignore diff --git a/src/parser/camligo/ast.ml b/src/passes/parser/camligo/ast.ml similarity index 100% rename from src/parser/camligo/ast.ml rename to src/passes/parser/camligo/ast.ml diff --git a/src/parser/camligo/dune b/src/passes/parser/camligo/dune similarity index 100% rename from src/parser/camligo/dune rename to src/passes/parser/camligo/dune diff --git a/src/parser/camligo/generator.ml b/src/passes/parser/camligo/generator.ml similarity index 100% rename from src/parser/camligo/generator.ml rename to src/passes/parser/camligo/generator.ml diff --git a/src/parser/camligo/lex/dune b/src/passes/parser/camligo/lex/dune similarity index 100% rename from src/parser/camligo/lex/dune rename to src/passes/parser/camligo/lex/dune diff --git a/src/parser/camligo/lex/generator.ml b/src/passes/parser/camligo/lex/generator.ml similarity index 100% rename from src/parser/camligo/lex/generator.ml rename to src/passes/parser/camligo/lex/generator.ml diff --git a/src/parser/camligo/location.ml b/src/passes/parser/camligo/location.ml similarity index 100% rename from src/parser/camligo/location.ml rename to src/passes/parser/camligo/location.ml diff --git a/src/parser/camligo/parser_camligo.ml b/src/passes/parser/camligo/parser_camligo.ml similarity index 100% rename from src/parser/camligo/parser_camligo.ml rename to src/passes/parser/camligo/parser_camligo.ml diff --git a/src/parser/camligo/pre_parser.mly b/src/passes/parser/camligo/pre_parser.mly similarity index 100% rename from src/parser/camligo/pre_parser.mly rename to src/passes/parser/camligo/pre_parser.mly diff --git a/src/parser/camligo/user.ml b/src/passes/parser/camligo/user.ml similarity index 100% rename from src/parser/camligo/user.ml rename to src/passes/parser/camligo/user.ml diff --git a/src/parser/dune b/src/passes/parser/dune similarity index 100% rename from src/parser/dune rename to src/passes/parser/dune diff --git a/src/parser/generator/doc/essai.ml b/src/passes/parser/generator/doc/essai.ml similarity index 100% rename from src/parser/generator/doc/essai.ml rename to src/passes/parser/generator/doc/essai.ml diff --git a/src/parser/generator/doc/mini_ml.bnf b/src/passes/parser/generator/doc/mini_ml.bnf similarity index 100% rename from src/parser/generator/doc/mini_ml.bnf rename to src/passes/parser/generator/doc/mini_ml.bnf diff --git a/src/parser/generator/doc/mini_ml2.bnf b/src/passes/parser/generator/doc/mini_ml2.bnf similarity index 100% rename from src/parser/generator/doc/mini_ml2.bnf rename to src/passes/parser/generator/doc/mini_ml2.bnf diff --git a/src/parser/generator/doc/mini_ml3.bnf b/src/passes/parser/generator/doc/mini_ml3.bnf similarity index 100% rename from src/parser/generator/doc/mini_ml3.bnf rename to src/passes/parser/generator/doc/mini_ml3.bnf diff --git a/src/parser/generator/doc/mini_ml4.bnf b/src/passes/parser/generator/doc/mini_ml4.bnf similarity index 100% rename from src/parser/generator/doc/mini_ml4.bnf rename to src/passes/parser/generator/doc/mini_ml4.bnf diff --git a/src/parser/ligodity.ml b/src/passes/parser/ligodity.ml similarity index 100% rename from src/parser/ligodity.ml rename to src/passes/parser/ligodity.ml diff --git a/src/parser/ligodity/.AST.ml.tag b/src/passes/parser/ligodity/.AST.ml.tag similarity index 100% rename from src/parser/ligodity/.AST.ml.tag rename to src/passes/parser/ligodity/.AST.ml.tag diff --git a/src/parser/ligodity/.Eval.ml.tag b/src/passes/parser/ligodity/.Eval.ml.tag similarity index 100% rename from src/parser/ligodity/.Eval.ml.tag rename to src/passes/parser/ligodity/.Eval.ml.tag diff --git a/src/parser/ligodity/.EvalMain.ml.tag b/src/passes/parser/ligodity/.EvalMain.ml.tag similarity index 100% rename from src/parser/ligodity/.EvalMain.ml.tag rename to src/passes/parser/ligodity/.EvalMain.ml.tag diff --git a/src/parser/ligodity/.Lexer.ml.tag b/src/passes/parser/ligodity/.Lexer.ml.tag similarity index 100% rename from src/parser/ligodity/.Lexer.ml.tag rename to src/passes/parser/ligodity/.Lexer.ml.tag diff --git a/src/parser/ligodity/.LexerMain.tag b/src/passes/parser/ligodity/.LexerMain.tag similarity index 100% rename from src/parser/ligodity/.LexerMain.tag rename to src/passes/parser/ligodity/.LexerMain.tag diff --git a/src/parser/ligodity/.Parser.ml.tag b/src/passes/parser/ligodity/.Parser.ml.tag similarity index 100% rename from src/parser/ligodity/.Parser.ml.tag rename to src/passes/parser/ligodity/.Parser.ml.tag diff --git a/src/parser/ligodity/.Parser.mly.tag b/src/passes/parser/ligodity/.Parser.mly.tag similarity index 100% rename from src/parser/ligodity/.Parser.mly.tag rename to src/passes/parser/ligodity/.Parser.mly.tag diff --git a/src/parser/ligodity/.ParserMain.tag b/src/passes/parser/ligodity/.ParserMain.tag similarity index 100% rename from src/parser/ligodity/.ParserMain.tag rename to src/passes/parser/ligodity/.ParserMain.tag diff --git a/src/parser/ligodity/.links b/src/passes/parser/ligodity/.links similarity index 100% rename from src/parser/ligodity/.links rename to src/passes/parser/ligodity/.links diff --git a/src/parser/ligodity/AST.ml b/src/passes/parser/ligodity/AST.ml similarity index 100% rename from src/parser/ligodity/AST.ml rename to src/passes/parser/ligodity/AST.ml diff --git a/src/parser/ligodity/AST.mli b/src/passes/parser/ligodity/AST.mli similarity index 100% rename from src/parser/ligodity/AST.mli rename to src/passes/parser/ligodity/AST.mli diff --git a/src/parser/ligodity/EvalOpt.ml b/src/passes/parser/ligodity/EvalOpt.ml similarity index 100% rename from src/parser/ligodity/EvalOpt.ml rename to src/passes/parser/ligodity/EvalOpt.ml diff --git a/src/parser/ligodity/EvalOpt.mli b/src/passes/parser/ligodity/EvalOpt.mli similarity index 100% rename from src/parser/ligodity/EvalOpt.mli rename to src/passes/parser/ligodity/EvalOpt.mli diff --git a/src/parser/ligodity/Lexer.mli b/src/passes/parser/ligodity/Lexer.mli similarity index 100% rename from src/parser/ligodity/Lexer.mli rename to src/passes/parser/ligodity/Lexer.mli diff --git a/src/parser/ligodity/Lexer.mll b/src/passes/parser/ligodity/Lexer.mll similarity index 100% rename from src/parser/ligodity/Lexer.mll rename to src/passes/parser/ligodity/Lexer.mll diff --git a/src/parser/ligodity/LexerMain.ml b/src/passes/parser/ligodity/LexerMain.ml similarity index 100% rename from src/parser/ligodity/LexerMain.ml rename to src/passes/parser/ligodity/LexerMain.ml diff --git a/src/parser/ligodity/ParToken.mly b/src/passes/parser/ligodity/ParToken.mly similarity index 100% rename from src/parser/ligodity/ParToken.mly rename to src/passes/parser/ligodity/ParToken.mly diff --git a/src/parser/ligodity/Parser.mly b/src/passes/parser/ligodity/Parser.mly similarity index 100% rename from src/parser/ligodity/Parser.mly rename to src/passes/parser/ligodity/Parser.mly diff --git a/src/parser/ligodity/ParserMain.ml b/src/passes/parser/ligodity/ParserMain.ml similarity index 100% rename from src/parser/ligodity/ParserMain.ml rename to src/passes/parser/ligodity/ParserMain.ml diff --git a/src/parser/ligodity/Stubs/Simple_utils.ml b/src/passes/parser/ligodity/Stubs/Simple_utils.ml similarity index 100% rename from src/parser/ligodity/Stubs/Simple_utils.ml rename to src/passes/parser/ligodity/Stubs/Simple_utils.ml diff --git a/src/parser/ligodity/Tests/match.mml b/src/passes/parser/ligodity/Tests/match.mml similarity index 100% rename from src/parser/ligodity/Tests/match.mml rename to src/passes/parser/ligodity/Tests/match.mml diff --git a/src/parser/ligodity/Token.ml b/src/passes/parser/ligodity/Token.ml similarity index 100% rename from src/parser/ligodity/Token.ml rename to src/passes/parser/ligodity/Token.ml diff --git a/src/parser/ligodity/Token.mli b/src/passes/parser/ligodity/Token.mli similarity index 100% rename from src/parser/ligodity/Token.mli rename to src/passes/parser/ligodity/Token.mli diff --git a/src/parser/ligodity/Utils.ml b/src/passes/parser/ligodity/Utils.ml similarity index 100% rename from src/parser/ligodity/Utils.ml rename to src/passes/parser/ligodity/Utils.ml diff --git a/src/parser/ligodity/Utils.mli b/src/passes/parser/ligodity/Utils.mli similarity index 100% rename from src/parser/ligodity/Utils.mli rename to src/passes/parser/ligodity/Utils.mli diff --git a/src/parser/ligodity/check_dot_git_is_dir.sh b/src/passes/parser/ligodity/check_dot_git_is_dir.sh similarity index 100% rename from src/parser/ligodity/check_dot_git_is_dir.sh rename to src/passes/parser/ligodity/check_dot_git_is_dir.sh diff --git a/src/parser/ligodity/dune b/src/passes/parser/ligodity/dune similarity index 100% rename from src/parser/ligodity/dune rename to src/passes/parser/ligodity/dune diff --git a/src/parser/ligodity/ligodity.ml b/src/passes/parser/ligodity/ligodity.ml similarity index 100% rename from src/parser/ligodity/ligodity.ml rename to src/passes/parser/ligodity/ligodity.ml diff --git a/src/parser/parser.ml b/src/passes/parser/parser.ml similarity index 100% rename from src/parser/parser.ml rename to src/passes/parser/parser.ml diff --git a/src/parser/pascaligo.ml b/src/passes/parser/pascaligo.ml similarity index 100% rename from src/parser/pascaligo.ml rename to src/passes/parser/pascaligo.ml diff --git a/src/parser/pascaligo/.Lexer.ml.tag b/src/passes/parser/pascaligo/.Lexer.ml.tag similarity index 100% rename from src/parser/pascaligo/.Lexer.ml.tag rename to src/passes/parser/pascaligo/.Lexer.ml.tag diff --git a/src/parser/pascaligo/.LexerMain.tag b/src/passes/parser/pascaligo/.LexerMain.tag similarity index 100% rename from src/parser/pascaligo/.LexerMain.tag rename to src/passes/parser/pascaligo/.LexerMain.tag diff --git a/src/parser/pascaligo/.Parser.mly.tag b/src/passes/parser/pascaligo/.Parser.mly.tag similarity index 100% rename from src/parser/pascaligo/.Parser.mly.tag rename to src/passes/parser/pascaligo/.Parser.mly.tag diff --git a/src/parser/pascaligo/.ParserMain.tag b/src/passes/parser/pascaligo/.ParserMain.tag similarity index 100% rename from src/parser/pascaligo/.ParserMain.tag rename to src/passes/parser/pascaligo/.ParserMain.tag diff --git a/src/parser/pascaligo/.gitignore b/src/passes/parser/pascaligo/.gitignore similarity index 100% rename from src/parser/pascaligo/.gitignore rename to src/passes/parser/pascaligo/.gitignore diff --git a/src/parser/pascaligo/.links b/src/passes/parser/pascaligo/.links similarity index 100% rename from src/parser/pascaligo/.links rename to src/passes/parser/pascaligo/.links diff --git a/src/parser/pascaligo/AST.ml b/src/passes/parser/pascaligo/AST.ml similarity index 100% rename from src/parser/pascaligo/AST.ml rename to src/passes/parser/pascaligo/AST.ml diff --git a/src/parser/pascaligo/AST.mli b/src/passes/parser/pascaligo/AST.mli similarity index 100% rename from src/parser/pascaligo/AST.mli rename to src/passes/parser/pascaligo/AST.mli diff --git a/src/parser/pascaligo/Doc/pascaligo.txt b/src/passes/parser/pascaligo/Doc/pascaligo.txt similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo.txt rename to src/passes/parser/pascaligo/Doc/pascaligo.txt diff --git a/src/parser/pascaligo/Doc/pascaligo_01.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_01.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_01.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_01.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_02.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_02.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_02.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_02.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_03.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_03.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_03.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_03.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_04.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_04.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_04.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_04.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_05.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_05.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_05.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_05.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_06.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_06.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_06.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_06.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_07.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_07.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_07.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_07.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_08.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_08.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_08.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_08.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_09.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_09.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_09.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_09.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_10.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_10.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_10.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_10.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_11.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_11.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_11.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_11.bnf diff --git a/src/parser/pascaligo/Doc/pascaligo_12.bnf b/src/passes/parser/pascaligo/Doc/pascaligo_12.bnf similarity index 100% rename from src/parser/pascaligo/Doc/pascaligo_12.bnf rename to src/passes/parser/pascaligo/Doc/pascaligo_12.bnf diff --git a/src/parser/pascaligo/LexToken.mli b/src/passes/parser/pascaligo/LexToken.mli similarity index 100% rename from src/parser/pascaligo/LexToken.mli rename to src/passes/parser/pascaligo/LexToken.mli diff --git a/src/parser/pascaligo/LexToken.mll b/src/passes/parser/pascaligo/LexToken.mll similarity index 100% rename from src/parser/pascaligo/LexToken.mll rename to src/passes/parser/pascaligo/LexToken.mll diff --git a/src/parser/pascaligo/LexerMain.ml b/src/passes/parser/pascaligo/LexerMain.ml similarity index 100% rename from src/parser/pascaligo/LexerMain.ml rename to src/passes/parser/pascaligo/LexerMain.ml diff --git a/src/parser/pascaligo/ParToken.mly b/src/passes/parser/pascaligo/ParToken.mly similarity index 100% rename from src/parser/pascaligo/ParToken.mly rename to src/passes/parser/pascaligo/ParToken.mly diff --git a/src/parser/pascaligo/Parser.mly b/src/passes/parser/pascaligo/Parser.mly similarity index 100% rename from src/parser/pascaligo/Parser.mly rename to src/passes/parser/pascaligo/Parser.mly diff --git a/src/parser/pascaligo/ParserLog.ml b/src/passes/parser/pascaligo/ParserLog.ml similarity index 100% rename from src/parser/pascaligo/ParserLog.ml rename to src/passes/parser/pascaligo/ParserLog.ml diff --git a/src/parser/pascaligo/ParserLog.mli b/src/passes/parser/pascaligo/ParserLog.mli similarity index 100% rename from src/parser/pascaligo/ParserLog.mli rename to src/passes/parser/pascaligo/ParserLog.mli diff --git a/src/parser/pascaligo/ParserMain.ml b/src/passes/parser/pascaligo/ParserMain.ml similarity index 100% rename from src/parser/pascaligo/ParserMain.ml rename to src/passes/parser/pascaligo/ParserMain.ml diff --git a/src/parser/pascaligo/Stubs/Simple_utils.ml b/src/passes/parser/pascaligo/Stubs/Simple_utils.ml similarity index 100% rename from src/parser/pascaligo/Stubs/Simple_utils.ml rename to src/passes/parser/pascaligo/Stubs/Simple_utils.ml diff --git a/src/parser/pascaligo/Tests/a.ligo b/src/passes/parser/pascaligo/Tests/a.ligo similarity index 100% rename from src/parser/pascaligo/Tests/a.ligo rename to src/passes/parser/pascaligo/Tests/a.ligo diff --git a/src/parser/pascaligo/Tests/crowdfunding.ligo b/src/passes/parser/pascaligo/Tests/crowdfunding.ligo similarity index 100% rename from src/parser/pascaligo/Tests/crowdfunding.ligo rename to src/passes/parser/pascaligo/Tests/crowdfunding.ligo diff --git a/src/parser/pascaligo/check_dot_git_is_dir.sh b/src/passes/parser/pascaligo/check_dot_git_is_dir.sh similarity index 100% rename from src/parser/pascaligo/check_dot_git_is_dir.sh rename to src/passes/parser/pascaligo/check_dot_git_is_dir.sh diff --git a/src/parser/pascaligo/dune b/src/passes/parser/pascaligo/dune similarity index 100% rename from src/parser/pascaligo/dune rename to src/passes/parser/pascaligo/dune diff --git a/src/parser/pascaligo/pascaligo.ml b/src/passes/parser/pascaligo/pascaligo.ml similarity index 100% rename from src/parser/pascaligo/pascaligo.ml rename to src/passes/parser/pascaligo/pascaligo.ml diff --git a/src/parser/shared/.links b/src/passes/parser/shared/.links similarity index 100% rename from src/parser/shared/.links rename to src/passes/parser/shared/.links diff --git a/src/parser/shared/Doc/shared.txt b/src/passes/parser/shared/Doc/shared.txt similarity index 100% rename from src/parser/shared/Doc/shared.txt rename to src/passes/parser/shared/Doc/shared.txt diff --git a/src/parser/shared/Error.mli b/src/passes/parser/shared/Error.mli similarity index 100% rename from src/parser/shared/Error.mli rename to src/passes/parser/shared/Error.mli diff --git a/src/parser/shared/EvalOpt.ml b/src/passes/parser/shared/EvalOpt.ml similarity index 100% rename from src/parser/shared/EvalOpt.ml rename to src/passes/parser/shared/EvalOpt.ml diff --git a/src/parser/shared/EvalOpt.mli b/src/passes/parser/shared/EvalOpt.mli similarity index 100% rename from src/parser/shared/EvalOpt.mli rename to src/passes/parser/shared/EvalOpt.mli diff --git a/src/parser/shared/FQueue.ml b/src/passes/parser/shared/FQueue.ml similarity index 100% rename from src/parser/shared/FQueue.ml rename to src/passes/parser/shared/FQueue.ml diff --git a/src/parser/shared/FQueue.mli b/src/passes/parser/shared/FQueue.mli similarity index 100% rename from src/parser/shared/FQueue.mli rename to src/passes/parser/shared/FQueue.mli diff --git a/src/parser/shared/Lexer.mli b/src/passes/parser/shared/Lexer.mli similarity index 100% rename from src/parser/shared/Lexer.mli rename to src/passes/parser/shared/Lexer.mli diff --git a/src/parser/shared/Lexer.mll b/src/passes/parser/shared/Lexer.mll similarity index 100% rename from src/parser/shared/Lexer.mll rename to src/passes/parser/shared/Lexer.mll diff --git a/src/parser/shared/LexerLog.ml b/src/passes/parser/shared/LexerLog.ml similarity index 100% rename from src/parser/shared/LexerLog.ml rename to src/passes/parser/shared/LexerLog.ml diff --git a/src/parser/shared/LexerLog.mli b/src/passes/parser/shared/LexerLog.mli similarity index 100% rename from src/parser/shared/LexerLog.mli rename to src/passes/parser/shared/LexerLog.mli diff --git a/src/parser/shared/Markup.ml b/src/passes/parser/shared/Markup.ml similarity index 100% rename from src/parser/shared/Markup.ml rename to src/passes/parser/shared/Markup.ml diff --git a/src/parser/shared/Markup.mli b/src/passes/parser/shared/Markup.mli similarity index 100% rename from src/parser/shared/Markup.mli rename to src/passes/parser/shared/Markup.mli diff --git a/src/parser/shared/Utils.ml b/src/passes/parser/shared/Utils.ml similarity index 100% rename from src/parser/shared/Utils.ml rename to src/passes/parser/shared/Utils.ml diff --git a/src/parser/shared/Utils.mli b/src/passes/parser/shared/Utils.mli similarity index 100% rename from src/parser/shared/Utils.mli rename to src/passes/parser/shared/Utils.mli diff --git a/src/parser/shared/dune b/src/passes/parser/shared/dune similarity index 100% rename from src/parser/shared/dune rename to src/passes/parser/shared/dune diff --git a/src/simplify/camligo.ml.old b/src/passes/simplify/camligo.ml.old similarity index 100% rename from src/simplify/camligo.ml.old rename to src/passes/simplify/camligo.ml.old diff --git a/src/simplify/dune b/src/passes/simplify/dune similarity index 100% rename from src/simplify/dune rename to src/passes/simplify/dune diff --git a/src/simplify/ligodity.ml b/src/passes/simplify/ligodity.ml similarity index 100% rename from src/simplify/ligodity.ml rename to src/passes/simplify/ligodity.ml diff --git a/src/simplify/pascaligo.ml b/src/passes/simplify/pascaligo.ml similarity index 100% rename from src/simplify/pascaligo.ml rename to src/passes/simplify/pascaligo.ml diff --git a/src/simplify/simplify.ml b/src/passes/simplify/simplify.ml similarity index 100% rename from src/simplify/simplify.ml rename to src/passes/simplify/simplify.ml diff --git a/src/typer/dune b/src/passes/typer/dune similarity index 100% rename from src/typer/dune rename to src/passes/typer/dune diff --git a/src/typer/typer.ml b/src/passes/typer/typer.ml similarity index 100% rename from src/typer/typer.ml rename to src/passes/typer/typer.ml diff --git a/src/main/display.ml b/src/run/main/display.ml similarity index 100% rename from src/main/display.ml rename to src/run/main/display.ml diff --git a/src/main/dune b/src/run/main/dune similarity index 100% rename from src/main/dune rename to src/run/main/dune diff --git a/src/main/main.ml b/src/run/main/main.ml similarity index 100% rename from src/main/main.ml rename to src/run/main/main.ml diff --git a/src/main/run_mini_c.ml b/src/run/main/run_mini_c.ml similarity index 100% rename from src/main/run_mini_c.ml rename to src/run/main/run_mini_c.ml diff --git a/src/main/run_simplified.ml b/src/run/main/run_simplified.ml similarity index 100% rename from src/main/run_simplified.ml rename to src/run/main/run_simplified.ml diff --git a/src/main/run_source.ml b/src/run/main/run_source.ml similarity index 100% rename from src/main/run_source.ml rename to src/run/main/run_source.ml diff --git a/src/main/run_typed.ml b/src/run/main/run_typed.ml similarity index 100% rename from src/main/run_typed.ml rename to src/run/main/run_typed.ml diff --git a/src/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml similarity index 100% rename from src/ast_simplified/PP.ml rename to src/stages/ast_simplified/PP.ml diff --git a/src/ast_simplified/ast_simplified.ml b/src/stages/ast_simplified/ast_simplified.ml similarity index 100% rename from src/ast_simplified/ast_simplified.ml rename to src/stages/ast_simplified/ast_simplified.ml diff --git a/src/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml similarity index 100% rename from src/ast_simplified/combinators.ml rename to src/stages/ast_simplified/combinators.ml diff --git a/src/ast_simplified/dune b/src/stages/ast_simplified/dune similarity index 100% rename from src/ast_simplified/dune rename to src/stages/ast_simplified/dune diff --git a/src/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml similarity index 100% rename from src/ast_simplified/misc.ml rename to src/stages/ast_simplified/misc.ml diff --git a/src/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml similarity index 100% rename from src/ast_simplified/types.ml rename to src/stages/ast_simplified/types.ml diff --git a/src/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml similarity index 100% rename from src/ast_typed/PP.ml rename to src/stages/ast_typed/PP.ml diff --git a/src/ast_typed/ast_typed.ml b/src/stages/ast_typed/ast_typed.ml similarity index 100% rename from src/ast_typed/ast_typed.ml rename to src/stages/ast_typed/ast_typed.ml diff --git a/src/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml similarity index 100% rename from src/ast_typed/combinators.ml rename to src/stages/ast_typed/combinators.ml diff --git a/src/ast_typed/combinators_environment.ml b/src/stages/ast_typed/combinators_environment.ml similarity index 100% rename from src/ast_typed/combinators_environment.ml rename to src/stages/ast_typed/combinators_environment.ml diff --git a/src/ast_typed/dune b/src/stages/ast_typed/dune similarity index 100% rename from src/ast_typed/dune rename to src/stages/ast_typed/dune diff --git a/src/ast_typed/environment.ml b/src/stages/ast_typed/environment.ml similarity index 100% rename from src/ast_typed/environment.ml rename to src/stages/ast_typed/environment.ml diff --git a/src/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml similarity index 100% rename from src/ast_typed/misc.ml rename to src/stages/ast_typed/misc.ml diff --git a/src/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml similarity index 100% rename from src/ast_typed/misc_smart.ml rename to src/stages/ast_typed/misc_smart.ml diff --git a/src/ast_typed/types.ml b/src/stages/ast_typed/types.ml similarity index 100% rename from src/ast_typed/types.ml rename to src/stages/ast_typed/types.ml diff --git a/src/compiler/compiler.ml b/src/stages/compiler/compiler.ml similarity index 100% rename from src/compiler/compiler.ml rename to src/stages/compiler/compiler.ml diff --git a/src/compiler/compiler_environment.ml b/src/stages/compiler/compiler_environment.ml similarity index 100% rename from src/compiler/compiler_environment.ml rename to src/stages/compiler/compiler_environment.ml diff --git a/src/compiler/compiler_program.ml b/src/stages/compiler/compiler_program.ml similarity index 100% rename from src/compiler/compiler_program.ml rename to src/stages/compiler/compiler_program.ml diff --git a/src/compiler/compiler_type.ml b/src/stages/compiler/compiler_type.ml similarity index 100% rename from src/compiler/compiler_type.ml rename to src/stages/compiler/compiler_type.ml diff --git a/src/compiler/dune b/src/stages/compiler/dune similarity index 100% rename from src/compiler/dune rename to src/stages/compiler/dune diff --git a/src/compiler/uncompiler.ml b/src/stages/compiler/uncompiler.ml similarity index 100% rename from src/compiler/uncompiler.ml rename to src/stages/compiler/uncompiler.ml diff --git a/src/mini_c/PP.ml b/src/stages/mini_c/PP.ml similarity index 100% rename from src/mini_c/PP.ml rename to src/stages/mini_c/PP.ml diff --git a/src/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml similarity index 100% rename from src/mini_c/combinators.ml rename to src/stages/mini_c/combinators.ml diff --git a/src/mini_c/combinators_smart.ml b/src/stages/mini_c/combinators_smart.ml similarity index 100% rename from src/mini_c/combinators_smart.ml rename to src/stages/mini_c/combinators_smart.ml diff --git a/src/mini_c/dune b/src/stages/mini_c/dune similarity index 100% rename from src/mini_c/dune rename to src/stages/mini_c/dune diff --git a/src/mini_c/environment.ml b/src/stages/mini_c/environment.ml similarity index 100% rename from src/mini_c/environment.ml rename to src/stages/mini_c/environment.ml diff --git a/src/mini_c/mini_c.ml b/src/stages/mini_c/mini_c.ml similarity index 100% rename from src/mini_c/mini_c.ml rename to src/stages/mini_c/mini_c.ml diff --git a/src/mini_c/types.ml b/src/stages/mini_c/types.ml similarity index 100% rename from src/mini_c/types.ml rename to src/stages/mini_c/types.ml diff --git a/src/transpiler/dune b/src/stages/transpiler/dune similarity index 100% rename from src/transpiler/dune rename to src/stages/transpiler/dune diff --git a/src/transpiler/transpiler.ml b/src/stages/transpiler/transpiler.ml similarity index 100% rename from src/transpiler/transpiler.ml rename to src/stages/transpiler/transpiler.ml diff --git a/src/test/.gitignore b/test/.gitignore similarity index 100% rename from src/test/.gitignore rename to test/.gitignore diff --git a/test/.merlin b/test/.merlin new file mode 100644 index 000000000..f2a72b2ea --- /dev/null +++ b/test/.merlin @@ -0,0 +1,187 @@ +EXCLUDE_QUERY_DIR +B /home/cc/Programming/ligo/_opam/lib/alcotest +B /home/cc/Programming/ligo/_opam/lib/astring +B /home/cc/Programming/ligo/_opam/lib/base/caml +B /home/cc/Programming/ligo/_opam/lib/bigarray-compat +B /home/cc/Programming/ligo/_opam/lib/bigstring +B /home/cc/Programming/ligo/_opam/lib/biniou +B /home/cc/Programming/ligo/_opam/lib/blake2 +B /home/cc/Programming/ligo/_opam/lib/bytes +B /home/cc/Programming/ligo/_opam/lib/cmdliner +B /home/cc/Programming/ligo/_opam/lib/cstruct +B /home/cc/Programming/ligo/_opam/lib/easy-format +B /home/cc/Programming/ligo/_opam/lib/ezjsonm +B /home/cc/Programming/ligo/_opam/lib/fmt +B /home/cc/Programming/ligo/_opam/lib/getopt +B /home/cc/Programming/ligo/_opam/lib/hacl +B /home/cc/Programming/ligo/_opam/lib/hex +B /home/cc/Programming/ligo/_opam/lib/ipaddr +B /home/cc/Programming/ligo/_opam/lib/ipaddr/unix +B /home/cc/Programming/ligo/_opam/lib/jsonm +B /home/cc/Programming/ligo/_opam/lib/lwt +B /home/cc/Programming/ligo/_opam/lib/lwt/unix +B /home/cc/Programming/ligo/_opam/lib/lwt_log +B /home/cc/Programming/ligo/_opam/lib/lwt_log/core +B /home/cc/Programming/ligo/_opam/lib/macaddr +B /home/cc/Programming/ligo/_opam/lib/mmap +B /home/cc/Programming/ligo/_opam/lib/mtime +B /home/cc/Programming/ligo/_opam/lib/mtime/os +B /home/cc/Programming/ligo/_opam/lib/ocaml +B /home/cc/Programming/ligo/_opam/lib/ocaml/threads +B /home/cc/Programming/ligo/_opam/lib/ocplib-endian +B /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed +B /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed-bson +B /home/cc/Programming/ligo/_opam/lib/ocplib-resto +B /home/cc/Programming/ligo/_opam/lib/ocplib-resto-directory +B /home/cc/Programming/ligo/_opam/lib/parsexp +B /home/cc/Programming/ligo/_opam/lib/ppx_deriving/runtime +B /home/cc/Programming/ligo/_opam/lib/ptime +B /home/cc/Programming/ligo/_opam/lib/ptime/os +B /home/cc/Programming/ligo/_opam/lib/re +B /home/cc/Programming/ligo/_opam/lib/re/posix +B /home/cc/Programming/ligo/_opam/lib/re/str +B /home/cc/Programming/ligo/_opam/lib/result +B /home/cc/Programming/ligo/_opam/lib/secp256k1 +B /home/cc/Programming/ligo/_opam/lib/seq +B /home/cc/Programming/ligo/_opam/lib/sexplib +B /home/cc/Programming/ligo/_opam/lib/sexplib0 +B /home/cc/Programming/ligo/_opam/lib/stdlib-shims +B /home/cc/Programming/ligo/_opam/lib/stringext +B /home/cc/Programming/ligo/_opam/lib/tezos-base +B /home/cc/Programming/ligo/_opam/lib/tezos-clic +B /home/cc/Programming/ligo/_opam/lib/tezos-crypto +B /home/cc/Programming/ligo/_opam/lib/tezos-data-encoding +B /home/cc/Programming/ligo/_opam/lib/tezos-error-monad +B /home/cc/Programming/ligo/_opam/lib/tezos-event-logging +B /home/cc/Programming/ligo/_opam/lib/tezos-micheline +B /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment +B /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment-sigs +B /home/cc/Programming/ligo/_opam/lib/tezos-rpc +B /home/cc/Programming/ligo/_opam/lib/tezos-stdlib +B /home/cc/Programming/ligo/_opam/lib/tezos-stdlib-unix +B /home/cc/Programming/ligo/_opam/lib/uchar +B /home/cc/Programming/ligo/_opam/lib/uecc +B /home/cc/Programming/ligo/_opam/lib/uri +B /home/cc/Programming/ligo/_opam/lib/uuidm +B /home/cc/Programming/ligo/_opam/lib/uutf +B /home/cc/Programming/ligo/_opam/lib/yojson +B /home/cc/Programming/ligo/_opam/lib/zarith +B ../../_build/default/src/.ligo.objs/byte +B ../../_build/default/src/ast_simplified/.ast_simplified.objs/byte +B ../../_build/default/src/ast_typed/.ast_typed.objs/byte +B ../../_build/default/src/compiler/.compiler.objs/byte +B ../../_build/default/src/mini_c/.mini_c.objs/byte +B ../../_build/default/src/operators/.operators.objs/byte +B ../../_build/default/src/parser/.parser.objs/byte +B ../../_build/default/src/parser/camligo/.parser_camligo.objs/byte +B ../../_build/default/src/parser/camligo/lex/.lex.objs/byte +B ../../_build/default/src/parser/ligodity/.parser_ligodity.objs/byte +B ../../_build/default/src/parser/pascaligo/.parser_pascaligo.objs/byte +B ../../_build/default/src/parser/shared/.parser_shared.objs/byte +B ../../_build/default/src/run/.run.objs/byte +B ../../_build/default/src/simplify/.simplify.objs/byte +B ../../_build/default/src/test/.test.eobjs/byte +B ../../_build/default/src/transpiler/.transpiler.objs/byte +B ../../_build/default/src/typer/.typer.objs/byte +B ../../_build/default/vendors/ligo-utils/memory-proto-alpha/.memory_proto_alpha.objs/byte +B ../../_build/default/vendors/ligo-utils/proto-alpha-utils/.proto_alpha_utils.objs/byte +B ../../_build/default/vendors/ligo-utils/simple-utils/.simple_utils.objs/byte +B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha-parameters/.tezos_protocol_alpha_parameters.objs/byte +B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_alpha.objs/byte +B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_environment_alpha.objs/byte +B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_raw_protocol_alpha.objs/byte +B ../../_build/default/vendors/ligo-utils/tezos-utils/.tezos_utils.objs/byte +B ../../_build/default/vendors/ligo-utils/tezos-utils/michelson-parser/.michelson_parser.objs/byte +S /home/cc/Programming/ligo/_opam/lib/alcotest +S /home/cc/Programming/ligo/_opam/lib/astring +S /home/cc/Programming/ligo/_opam/lib/base/caml +S /home/cc/Programming/ligo/_opam/lib/bigarray-compat +S /home/cc/Programming/ligo/_opam/lib/bigstring +S /home/cc/Programming/ligo/_opam/lib/biniou +S /home/cc/Programming/ligo/_opam/lib/blake2 +S /home/cc/Programming/ligo/_opam/lib/bytes +S /home/cc/Programming/ligo/_opam/lib/cmdliner +S /home/cc/Programming/ligo/_opam/lib/cstruct +S /home/cc/Programming/ligo/_opam/lib/easy-format +S /home/cc/Programming/ligo/_opam/lib/ezjsonm +S /home/cc/Programming/ligo/_opam/lib/fmt +S /home/cc/Programming/ligo/_opam/lib/getopt +S /home/cc/Programming/ligo/_opam/lib/hacl +S /home/cc/Programming/ligo/_opam/lib/hex +S /home/cc/Programming/ligo/_opam/lib/ipaddr +S /home/cc/Programming/ligo/_opam/lib/ipaddr/unix +S /home/cc/Programming/ligo/_opam/lib/jsonm +S /home/cc/Programming/ligo/_opam/lib/lwt +S /home/cc/Programming/ligo/_opam/lib/lwt/unix +S /home/cc/Programming/ligo/_opam/lib/lwt_log +S /home/cc/Programming/ligo/_opam/lib/lwt_log/core +S /home/cc/Programming/ligo/_opam/lib/macaddr +S /home/cc/Programming/ligo/_opam/lib/mmap +S /home/cc/Programming/ligo/_opam/lib/mtime +S /home/cc/Programming/ligo/_opam/lib/mtime/os +S /home/cc/Programming/ligo/_opam/lib/ocaml +S /home/cc/Programming/ligo/_opam/lib/ocaml/threads +S /home/cc/Programming/ligo/_opam/lib/ocplib-endian +S /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed +S /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed-bson +S /home/cc/Programming/ligo/_opam/lib/ocplib-resto +S /home/cc/Programming/ligo/_opam/lib/ocplib-resto-directory +S /home/cc/Programming/ligo/_opam/lib/parsexp +S /home/cc/Programming/ligo/_opam/lib/ppx_deriving/runtime +S /home/cc/Programming/ligo/_opam/lib/ptime +S /home/cc/Programming/ligo/_opam/lib/ptime/os +S /home/cc/Programming/ligo/_opam/lib/re +S /home/cc/Programming/ligo/_opam/lib/re/posix +S /home/cc/Programming/ligo/_opam/lib/re/str +S /home/cc/Programming/ligo/_opam/lib/result +S /home/cc/Programming/ligo/_opam/lib/secp256k1 +S /home/cc/Programming/ligo/_opam/lib/seq +S /home/cc/Programming/ligo/_opam/lib/sexplib +S /home/cc/Programming/ligo/_opam/lib/sexplib0 +S /home/cc/Programming/ligo/_opam/lib/stdlib-shims +S /home/cc/Programming/ligo/_opam/lib/stringext +S /home/cc/Programming/ligo/_opam/lib/tezos-base +S /home/cc/Programming/ligo/_opam/lib/tezos-clic +S /home/cc/Programming/ligo/_opam/lib/tezos-crypto +S /home/cc/Programming/ligo/_opam/lib/tezos-data-encoding +S /home/cc/Programming/ligo/_opam/lib/tezos-error-monad +S /home/cc/Programming/ligo/_opam/lib/tezos-event-logging +S /home/cc/Programming/ligo/_opam/lib/tezos-micheline +S /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment +S /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment-sigs +S /home/cc/Programming/ligo/_opam/lib/tezos-rpc +S /home/cc/Programming/ligo/_opam/lib/tezos-stdlib +S /home/cc/Programming/ligo/_opam/lib/tezos-stdlib-unix +S /home/cc/Programming/ligo/_opam/lib/uchar +S /home/cc/Programming/ligo/_opam/lib/uecc +S /home/cc/Programming/ligo/_opam/lib/uri +S /home/cc/Programming/ligo/_opam/lib/uuidm +S /home/cc/Programming/ligo/_opam/lib/uutf +S /home/cc/Programming/ligo/_opam/lib/yojson +S /home/cc/Programming/ligo/_opam/lib/zarith +S .. +S ../ast_simplified +S ../ast_typed +S ../compiler +S ../mini_c +S ../operators +S ../parser +S ../parser/camligo +S ../parser/camligo/lex +S ../parser/ligodity +S ../parser/pascaligo +S ../parser/shared +S ../run +S ../simplify +S . +S ../transpiler +S ../typer +S ../../vendors/ligo-utils/memory-proto-alpha +S ../../vendors/ligo-utils/proto-alpha-utils +S ../../vendors/ligo-utils/simple-utils +S ../../vendors/ligo-utils/tezos-protocol-alpha +S ../../vendors/ligo-utils/tezos-protocol-alpha-parameters +S ../../vendors/ligo-utils/tezos-utils +S ../../vendors/ligo-utils/tezos-utils/michelson-parser +FLG -ppx '/home/cc/Programming/ligo/_build/default/.ppx/0af9cc0ed9166d3107af7264d5703b53/ppx.exe --as-ppx' +FLG -w @1..3@5..28@30..39@43@46..47@49..57@61..62-40 -strict-sequence -strict-formats -short-paths -keep-locs -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils diff --git a/src/test/bin_tests.ml b/test/bin_tests.ml similarity index 100% rename from src/test/bin_tests.ml rename to test/bin_tests.ml diff --git a/src/test/coase_tests.ml b/test/coase_tests.ml similarity index 100% rename from src/test/coase_tests.ml rename to test/coase_tests.ml diff --git a/src/test/compiler_tests.ml b/test/compiler_tests.ml similarity index 100% rename from src/test/compiler_tests.ml rename to test/compiler_tests.ml diff --git a/src/test/dune b/test/dune similarity index 100% rename from src/test/dune rename to test/dune diff --git a/src/test/heap_tests.ml b/test/heap_tests.ml similarity index 100% rename from src/test/heap_tests.ml rename to test/heap_tests.ml diff --git a/src/test/integration_tests.ml b/test/integration_tests.ml similarity index 100% rename from src/test/integration_tests.ml rename to test/integration_tests.ml diff --git a/src/test/manual_test.ml b/test/manual_test.ml similarity index 100% rename from src/test/manual_test.ml rename to test/manual_test.ml diff --git a/src/test/multifix_tests.ml b/test/multifix_tests.ml similarity index 100% rename from src/test/multifix_tests.ml rename to test/multifix_tests.ml diff --git a/src/test/test.ml b/test/test.ml similarity index 100% rename from src/test/test.ml rename to test/test.ml diff --git a/src/test/test_helpers.ml b/test/test_helpers.ml similarity index 100% rename from src/test/test_helpers.ml rename to test/test_helpers.ml diff --git a/src/test/transpiler_tests.ml b/test/transpiler_tests.ml similarity index 100% rename from src/test/transpiler_tests.ml rename to test/transpiler_tests.ml diff --git a/src/test/typer_tests.ml b/test/typer_tests.ml similarity index 100% rename from src/test/typer_tests.ml rename to test/typer_tests.ml diff --git a/src/test/vote_tests.ml b/test/vote_tests.ml similarity index 100% rename from src/test/vote_tests.ml rename to test/vote_tests.ml diff --git a/src/rope/rope.ml b/vendors/rope/rope.ml similarity index 100% rename from src/rope/rope.ml rename to vendors/rope/rope.ml diff --git a/src/rope/rope.mli b/vendors/rope/rope.mli similarity index 100% rename from src/rope/rope.mli rename to vendors/rope/rope.mli diff --git a/src/rope/rope_implementation.ml b/vendors/rope/rope_implementation.ml similarity index 100% rename from src/rope/rope_implementation.ml rename to vendors/rope/rope_implementation.ml diff --git a/src/rope/rope_implementation.mli b/vendors/rope/rope_implementation.mli similarity index 100% rename from src/rope/rope_implementation.mli rename to vendors/rope/rope_implementation.mli diff --git a/src/rope/rope_test.ml b/vendors/rope/rope_test.ml similarity index 100% rename from src/rope/rope_test.ml rename to vendors/rope/rope_test.ml diff --git a/src/rope/rope_top_level_open.ml b/vendors/rope/rope_top_level_open.ml similarity index 100% rename from src/rope/rope_top_level_open.ml rename to vendors/rope/rope_top_level_open.ml diff --git a/src/rope/rope_top_level_open.mli b/vendors/rope/rope_top_level_open.mli similarity index 100% rename from src/rope/rope_top_level_open.mli rename to vendors/rope/rope_top_level_open.mli From d187317c325df8399e8fca0ac31a9e2952e64e6b Mon Sep 17 00:00:00 2001 From: galfour Date: Mon, 9 Sep 2019 11:47:42 +0200 Subject: [PATCH 02/53] move contracts --- {src => test}/contracts/amount.mligo | 0 {src => test}/contracts/annotation.ligo | 0 {src => test}/contracts/arithmetic.ligo | 0 {src => test}/contracts/assign.ligo | 0 {src => test}/contracts/basic.mligo | 0 {src => test}/contracts/bitwise_arithmetic.ligo | 0 {src => test}/contracts/boolean_operators.ligo | 0 {src => test}/contracts/bytes_arithmetic.ligo | 0 {src => test}/contracts/closure-1.ligo | 0 {src => test}/contracts/closure-2.ligo | 0 {src => test}/contracts/closure-3.ligo | 0 {src => test}/contracts/closure.ligo | 0 {src => test}/contracts/coase.ligo | 0 {src => test}/contracts/condition-simple.ligo | 0 {src => test}/contracts/condition.ligo | 0 {src => test}/contracts/counter.ligo | 0 {src => test}/contracts/counter.mligo | 0 {src => test}/contracts/declaration-local.ligo | 0 {src => test}/contracts/declarations.ligo | 0 {src => test}/contracts/dispatch-counter.ligo | 0 {src => test}/contracts/error_syntax.ligo | 0 {src => test}/contracts/error_type.ligo | 0 {src => test}/contracts/failwith.mligo | 0 {src => test}/contracts/function-complex.ligo | 0 {src => test}/contracts/function-shared.ligo | 0 {src => test}/contracts/function.ligo | 0 {src => test}/contracts/guess_string.mligo | 0 {src => test}/contracts/heap-instance.ligo | 0 {src => test}/contracts/heap.ligo | 0 {src => test}/contracts/high-order.ligo | 0 {src => test}/contracts/included.ligo | 0 {src => test}/contracts/includer.ligo | 0 {src => test}/contracts/lambda.ligo | 0 {src => test}/contracts/lambda.mligo | 0 {src => test}/contracts/lambda2.mligo | 0 {src => test}/contracts/letin.mligo | 0 {src => test}/contracts/list.ligo | 0 {src => test}/contracts/list.mligo | 0 {src => test}/contracts/loop.ligo | 0 {src => test}/contracts/map.ligo | 0 {src => test}/contracts/match.ligo | 0 {src => test}/contracts/match.mligo | 0 {src => test}/contracts/match_bis.mligo | 0 {src => test}/contracts/multiple-parameters.ligo | 0 {src => test}/contracts/new-syntax.mligo | 0 {src => test}/contracts/option.ligo | 0 {src => test}/contracts/parser-bad-reported-term.ligo | 0 {src => test}/contracts/quote-declaration.ligo | 0 {src => test}/contracts/quote-declarations.ligo | 0 {src => test}/contracts/record.ligo | 0 {src => test}/contracts/record.mligo | 0 {src => test}/contracts/set_arithmetic-1.ligo | 0 {src => test}/contracts/set_arithmetic.ligo | 0 {src => test}/contracts/shadow.ligo | 0 {src => test}/contracts/string.ligo | 0 {src => test}/contracts/string_arithmetic.ligo | 0 {src => test}/contracts/super-counter.ligo | 0 {src => test}/contracts/super-counter.mligo | 0 {src => test}/contracts/toto.ligo | 0 {src => test}/contracts/tuple.ligo | 0 {src => test}/contracts/type-alias.ligo | 0 {src => test}/contracts/unit.ligo | 0 {src => test}/contracts/variant-matching.ligo | 0 {src => test}/contracts/variant.ligo | 0 {src => test}/contracts/vote.mligo | 0 {src => test}/contracts/website1.ligo | 0 {src => test}/contracts/website2.ligo | 0 67 files changed, 0 insertions(+), 0 deletions(-) rename {src => test}/contracts/amount.mligo (100%) rename {src => test}/contracts/annotation.ligo (100%) rename {src => test}/contracts/arithmetic.ligo (100%) rename {src => test}/contracts/assign.ligo (100%) rename {src => test}/contracts/basic.mligo (100%) rename {src => test}/contracts/bitwise_arithmetic.ligo (100%) rename {src => test}/contracts/boolean_operators.ligo (100%) rename {src => test}/contracts/bytes_arithmetic.ligo (100%) rename {src => test}/contracts/closure-1.ligo (100%) rename {src => test}/contracts/closure-2.ligo (100%) rename {src => test}/contracts/closure-3.ligo (100%) rename {src => test}/contracts/closure.ligo (100%) rename {src => test}/contracts/coase.ligo (100%) rename {src => test}/contracts/condition-simple.ligo (100%) rename {src => test}/contracts/condition.ligo (100%) rename {src => test}/contracts/counter.ligo (100%) rename {src => test}/contracts/counter.mligo (100%) rename {src => test}/contracts/declaration-local.ligo (100%) rename {src => test}/contracts/declarations.ligo (100%) rename {src => test}/contracts/dispatch-counter.ligo (100%) rename {src => test}/contracts/error_syntax.ligo (100%) rename {src => test}/contracts/error_type.ligo (100%) rename {src => test}/contracts/failwith.mligo (100%) rename {src => test}/contracts/function-complex.ligo (100%) rename {src => test}/contracts/function-shared.ligo (100%) rename {src => test}/contracts/function.ligo (100%) rename {src => test}/contracts/guess_string.mligo (100%) rename {src => test}/contracts/heap-instance.ligo (100%) rename {src => test}/contracts/heap.ligo (100%) rename {src => test}/contracts/high-order.ligo (100%) rename {src => test}/contracts/included.ligo (100%) rename {src => test}/contracts/includer.ligo (100%) rename {src => test}/contracts/lambda.ligo (100%) rename {src => test}/contracts/lambda.mligo (100%) rename {src => test}/contracts/lambda2.mligo (100%) rename {src => test}/contracts/letin.mligo (100%) rename {src => test}/contracts/list.ligo (100%) rename {src => test}/contracts/list.mligo (100%) rename {src => test}/contracts/loop.ligo (100%) rename {src => test}/contracts/map.ligo (100%) rename {src => test}/contracts/match.ligo (100%) rename {src => test}/contracts/match.mligo (100%) rename {src => test}/contracts/match_bis.mligo (100%) rename {src => test}/contracts/multiple-parameters.ligo (100%) rename {src => test}/contracts/new-syntax.mligo (100%) rename {src => test}/contracts/option.ligo (100%) rename {src => test}/contracts/parser-bad-reported-term.ligo (100%) rename {src => test}/contracts/quote-declaration.ligo (100%) rename {src => test}/contracts/quote-declarations.ligo (100%) rename {src => test}/contracts/record.ligo (100%) rename {src => test}/contracts/record.mligo (100%) rename {src => test}/contracts/set_arithmetic-1.ligo (100%) rename {src => test}/contracts/set_arithmetic.ligo (100%) rename {src => test}/contracts/shadow.ligo (100%) rename {src => test}/contracts/string.ligo (100%) rename {src => test}/contracts/string_arithmetic.ligo (100%) rename {src => test}/contracts/super-counter.ligo (100%) rename {src => test}/contracts/super-counter.mligo (100%) rename {src => test}/contracts/toto.ligo (100%) rename {src => test}/contracts/tuple.ligo (100%) rename {src => test}/contracts/type-alias.ligo (100%) rename {src => test}/contracts/unit.ligo (100%) rename {src => test}/contracts/variant-matching.ligo (100%) rename {src => test}/contracts/variant.ligo (100%) rename {src => test}/contracts/vote.mligo (100%) rename {src => test}/contracts/website1.ligo (100%) rename {src => test}/contracts/website2.ligo (100%) diff --git a/src/contracts/amount.mligo b/test/contracts/amount.mligo similarity index 100% rename from src/contracts/amount.mligo rename to test/contracts/amount.mligo diff --git a/src/contracts/annotation.ligo b/test/contracts/annotation.ligo similarity index 100% rename from src/contracts/annotation.ligo rename to test/contracts/annotation.ligo diff --git a/src/contracts/arithmetic.ligo b/test/contracts/arithmetic.ligo similarity index 100% rename from src/contracts/arithmetic.ligo rename to test/contracts/arithmetic.ligo diff --git a/src/contracts/assign.ligo b/test/contracts/assign.ligo similarity index 100% rename from src/contracts/assign.ligo rename to test/contracts/assign.ligo diff --git a/src/contracts/basic.mligo b/test/contracts/basic.mligo similarity index 100% rename from src/contracts/basic.mligo rename to test/contracts/basic.mligo diff --git a/src/contracts/bitwise_arithmetic.ligo b/test/contracts/bitwise_arithmetic.ligo similarity index 100% rename from src/contracts/bitwise_arithmetic.ligo rename to test/contracts/bitwise_arithmetic.ligo diff --git a/src/contracts/boolean_operators.ligo b/test/contracts/boolean_operators.ligo similarity index 100% rename from src/contracts/boolean_operators.ligo rename to test/contracts/boolean_operators.ligo diff --git a/src/contracts/bytes_arithmetic.ligo b/test/contracts/bytes_arithmetic.ligo similarity index 100% rename from src/contracts/bytes_arithmetic.ligo rename to test/contracts/bytes_arithmetic.ligo diff --git a/src/contracts/closure-1.ligo b/test/contracts/closure-1.ligo similarity index 100% rename from src/contracts/closure-1.ligo rename to test/contracts/closure-1.ligo diff --git a/src/contracts/closure-2.ligo b/test/contracts/closure-2.ligo similarity index 100% rename from src/contracts/closure-2.ligo rename to test/contracts/closure-2.ligo diff --git a/src/contracts/closure-3.ligo b/test/contracts/closure-3.ligo similarity index 100% rename from src/contracts/closure-3.ligo rename to test/contracts/closure-3.ligo diff --git a/src/contracts/closure.ligo b/test/contracts/closure.ligo similarity index 100% rename from src/contracts/closure.ligo rename to test/contracts/closure.ligo diff --git a/src/contracts/coase.ligo b/test/contracts/coase.ligo similarity index 100% rename from src/contracts/coase.ligo rename to test/contracts/coase.ligo diff --git a/src/contracts/condition-simple.ligo b/test/contracts/condition-simple.ligo similarity index 100% rename from src/contracts/condition-simple.ligo rename to test/contracts/condition-simple.ligo diff --git a/src/contracts/condition.ligo b/test/contracts/condition.ligo similarity index 100% rename from src/contracts/condition.ligo rename to test/contracts/condition.ligo diff --git a/src/contracts/counter.ligo b/test/contracts/counter.ligo similarity index 100% rename from src/contracts/counter.ligo rename to test/contracts/counter.ligo diff --git a/src/contracts/counter.mligo b/test/contracts/counter.mligo similarity index 100% rename from src/contracts/counter.mligo rename to test/contracts/counter.mligo diff --git a/src/contracts/declaration-local.ligo b/test/contracts/declaration-local.ligo similarity index 100% rename from src/contracts/declaration-local.ligo rename to test/contracts/declaration-local.ligo diff --git a/src/contracts/declarations.ligo b/test/contracts/declarations.ligo similarity index 100% rename from src/contracts/declarations.ligo rename to test/contracts/declarations.ligo diff --git a/src/contracts/dispatch-counter.ligo b/test/contracts/dispatch-counter.ligo similarity index 100% rename from src/contracts/dispatch-counter.ligo rename to test/contracts/dispatch-counter.ligo diff --git a/src/contracts/error_syntax.ligo b/test/contracts/error_syntax.ligo similarity index 100% rename from src/contracts/error_syntax.ligo rename to test/contracts/error_syntax.ligo diff --git a/src/contracts/error_type.ligo b/test/contracts/error_type.ligo similarity index 100% rename from src/contracts/error_type.ligo rename to test/contracts/error_type.ligo diff --git a/src/contracts/failwith.mligo b/test/contracts/failwith.mligo similarity index 100% rename from src/contracts/failwith.mligo rename to test/contracts/failwith.mligo diff --git a/src/contracts/function-complex.ligo b/test/contracts/function-complex.ligo similarity index 100% rename from src/contracts/function-complex.ligo rename to test/contracts/function-complex.ligo diff --git a/src/contracts/function-shared.ligo b/test/contracts/function-shared.ligo similarity index 100% rename from src/contracts/function-shared.ligo rename to test/contracts/function-shared.ligo diff --git a/src/contracts/function.ligo b/test/contracts/function.ligo similarity index 100% rename from src/contracts/function.ligo rename to test/contracts/function.ligo diff --git a/src/contracts/guess_string.mligo b/test/contracts/guess_string.mligo similarity index 100% rename from src/contracts/guess_string.mligo rename to test/contracts/guess_string.mligo diff --git a/src/contracts/heap-instance.ligo b/test/contracts/heap-instance.ligo similarity index 100% rename from src/contracts/heap-instance.ligo rename to test/contracts/heap-instance.ligo diff --git a/src/contracts/heap.ligo b/test/contracts/heap.ligo similarity index 100% rename from src/contracts/heap.ligo rename to test/contracts/heap.ligo diff --git a/src/contracts/high-order.ligo b/test/contracts/high-order.ligo similarity index 100% rename from src/contracts/high-order.ligo rename to test/contracts/high-order.ligo diff --git a/src/contracts/included.ligo b/test/contracts/included.ligo similarity index 100% rename from src/contracts/included.ligo rename to test/contracts/included.ligo diff --git a/src/contracts/includer.ligo b/test/contracts/includer.ligo similarity index 100% rename from src/contracts/includer.ligo rename to test/contracts/includer.ligo diff --git a/src/contracts/lambda.ligo b/test/contracts/lambda.ligo similarity index 100% rename from src/contracts/lambda.ligo rename to test/contracts/lambda.ligo diff --git a/src/contracts/lambda.mligo b/test/contracts/lambda.mligo similarity index 100% rename from src/contracts/lambda.mligo rename to test/contracts/lambda.mligo diff --git a/src/contracts/lambda2.mligo b/test/contracts/lambda2.mligo similarity index 100% rename from src/contracts/lambda2.mligo rename to test/contracts/lambda2.mligo diff --git a/src/contracts/letin.mligo b/test/contracts/letin.mligo similarity index 100% rename from src/contracts/letin.mligo rename to test/contracts/letin.mligo diff --git a/src/contracts/list.ligo b/test/contracts/list.ligo similarity index 100% rename from src/contracts/list.ligo rename to test/contracts/list.ligo diff --git a/src/contracts/list.mligo b/test/contracts/list.mligo similarity index 100% rename from src/contracts/list.mligo rename to test/contracts/list.mligo diff --git a/src/contracts/loop.ligo b/test/contracts/loop.ligo similarity index 100% rename from src/contracts/loop.ligo rename to test/contracts/loop.ligo diff --git a/src/contracts/map.ligo b/test/contracts/map.ligo similarity index 100% rename from src/contracts/map.ligo rename to test/contracts/map.ligo diff --git a/src/contracts/match.ligo b/test/contracts/match.ligo similarity index 100% rename from src/contracts/match.ligo rename to test/contracts/match.ligo diff --git a/src/contracts/match.mligo b/test/contracts/match.mligo similarity index 100% rename from src/contracts/match.mligo rename to test/contracts/match.mligo diff --git a/src/contracts/match_bis.mligo b/test/contracts/match_bis.mligo similarity index 100% rename from src/contracts/match_bis.mligo rename to test/contracts/match_bis.mligo diff --git a/src/contracts/multiple-parameters.ligo b/test/contracts/multiple-parameters.ligo similarity index 100% rename from src/contracts/multiple-parameters.ligo rename to test/contracts/multiple-parameters.ligo diff --git a/src/contracts/new-syntax.mligo b/test/contracts/new-syntax.mligo similarity index 100% rename from src/contracts/new-syntax.mligo rename to test/contracts/new-syntax.mligo diff --git a/src/contracts/option.ligo b/test/contracts/option.ligo similarity index 100% rename from src/contracts/option.ligo rename to test/contracts/option.ligo diff --git a/src/contracts/parser-bad-reported-term.ligo b/test/contracts/parser-bad-reported-term.ligo similarity index 100% rename from src/contracts/parser-bad-reported-term.ligo rename to test/contracts/parser-bad-reported-term.ligo diff --git a/src/contracts/quote-declaration.ligo b/test/contracts/quote-declaration.ligo similarity index 100% rename from src/contracts/quote-declaration.ligo rename to test/contracts/quote-declaration.ligo diff --git a/src/contracts/quote-declarations.ligo b/test/contracts/quote-declarations.ligo similarity index 100% rename from src/contracts/quote-declarations.ligo rename to test/contracts/quote-declarations.ligo diff --git a/src/contracts/record.ligo b/test/contracts/record.ligo similarity index 100% rename from src/contracts/record.ligo rename to test/contracts/record.ligo diff --git a/src/contracts/record.mligo b/test/contracts/record.mligo similarity index 100% rename from src/contracts/record.mligo rename to test/contracts/record.mligo diff --git a/src/contracts/set_arithmetic-1.ligo b/test/contracts/set_arithmetic-1.ligo similarity index 100% rename from src/contracts/set_arithmetic-1.ligo rename to test/contracts/set_arithmetic-1.ligo diff --git a/src/contracts/set_arithmetic.ligo b/test/contracts/set_arithmetic.ligo similarity index 100% rename from src/contracts/set_arithmetic.ligo rename to test/contracts/set_arithmetic.ligo diff --git a/src/contracts/shadow.ligo b/test/contracts/shadow.ligo similarity index 100% rename from src/contracts/shadow.ligo rename to test/contracts/shadow.ligo diff --git a/src/contracts/string.ligo b/test/contracts/string.ligo similarity index 100% rename from src/contracts/string.ligo rename to test/contracts/string.ligo diff --git a/src/contracts/string_arithmetic.ligo b/test/contracts/string_arithmetic.ligo similarity index 100% rename from src/contracts/string_arithmetic.ligo rename to test/contracts/string_arithmetic.ligo diff --git a/src/contracts/super-counter.ligo b/test/contracts/super-counter.ligo similarity index 100% rename from src/contracts/super-counter.ligo rename to test/contracts/super-counter.ligo diff --git a/src/contracts/super-counter.mligo b/test/contracts/super-counter.mligo similarity index 100% rename from src/contracts/super-counter.mligo rename to test/contracts/super-counter.mligo diff --git a/src/contracts/toto.ligo b/test/contracts/toto.ligo similarity index 100% rename from src/contracts/toto.ligo rename to test/contracts/toto.ligo diff --git a/src/contracts/tuple.ligo b/test/contracts/tuple.ligo similarity index 100% rename from src/contracts/tuple.ligo rename to test/contracts/tuple.ligo diff --git a/src/contracts/type-alias.ligo b/test/contracts/type-alias.ligo similarity index 100% rename from src/contracts/type-alias.ligo rename to test/contracts/type-alias.ligo diff --git a/src/contracts/unit.ligo b/test/contracts/unit.ligo similarity index 100% rename from src/contracts/unit.ligo rename to test/contracts/unit.ligo diff --git a/src/contracts/variant-matching.ligo b/test/contracts/variant-matching.ligo similarity index 100% rename from src/contracts/variant-matching.ligo rename to test/contracts/variant-matching.ligo diff --git a/src/contracts/variant.ligo b/test/contracts/variant.ligo similarity index 100% rename from src/contracts/variant.ligo rename to test/contracts/variant.ligo diff --git a/src/contracts/vote.mligo b/test/contracts/vote.mligo similarity index 100% rename from src/contracts/vote.mligo rename to test/contracts/vote.mligo diff --git a/src/contracts/website1.ligo b/test/contracts/website1.ligo similarity index 100% rename from src/contracts/website1.ligo rename to test/contracts/website1.ligo diff --git a/src/contracts/website2.ligo b/test/contracts/website2.ligo similarity index 100% rename from src/contracts/website2.ligo rename to test/contracts/website2.ligo From cdfffcf8ecaec28a7171d2f04bedb12548634f5f Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 10 Sep 2019 12:42:49 +0200 Subject: [PATCH 03/53] more refactoring --- .gitignore | 1 + src/dune | 17 --- .../{parser => 1-parser}/camligo/.gitignore | 0 .../{parser => 1-parser}/camligo/ast.ml | 0 src/passes/{parser => 1-parser}/camligo/dune | 0 .../{parser => 1-parser}/camligo/generator.ml | 0 .../{parser => 1-parser}/camligo/lex/dune | 0 .../camligo/lex/generator.ml | 0 .../{parser => 1-parser}/camligo/location.ml | 0 .../camligo/parser_camligo.ml | 0 .../camligo/pre_parser.mly | 0 .../{parser => 1-parser}/camligo/user.ml | 0 src/passes/{parser => 1-parser}/dune | 0 .../generator/doc/essai.ml | 0 .../generator/doc/mini_ml.bnf | 0 .../generator/doc/mini_ml2.bnf | 0 .../generator/doc/mini_ml3.bnf | 0 .../generator/doc/mini_ml4.bnf | 0 src/passes/{parser => 1-parser}/ligodity.ml | 0 .../{parser => 1-parser}/ligodity/.AST.ml.tag | 0 .../ligodity/.Eval.ml.tag | 0 .../ligodity/.EvalMain.ml.tag | 0 .../ligodity/.Lexer.ml.tag | 0 .../ligodity/.LexerMain.tag | 0 .../ligodity/.Parser.ml.tag | 0 .../ligodity/.Parser.mly.tag | 0 .../ligodity/.ParserMain.tag | 0 .../{parser => 1-parser}/ligodity/.links | 0 .../{parser => 1-parser}/ligodity/AST.ml | 0 .../{parser => 1-parser}/ligodity/AST.mli | 0 .../{parser => 1-parser}/ligodity/EvalOpt.ml | 0 .../{parser => 1-parser}/ligodity/EvalOpt.mli | 0 .../{parser => 1-parser}/ligodity/Lexer.mli | 0 .../{parser => 1-parser}/ligodity/Lexer.mll | 0 .../ligodity/LexerMain.ml | 0 .../ligodity/ParToken.mly | 0 .../{parser => 1-parser}/ligodity/Parser.mly | 0 .../ligodity/ParserMain.ml | 0 .../ligodity/Stubs/Simple_utils.ml | 0 .../ligodity/Tests/match.mml | 0 .../{parser => 1-parser}/ligodity/Token.ml | 0 .../{parser => 1-parser}/ligodity/Token.mli | 0 .../{parser => 1-parser}/ligodity/Utils.ml | 0 .../{parser => 1-parser}/ligodity/Utils.mli | 0 .../ligodity/check_dot_git_is_dir.sh | 0 src/passes/{parser => 1-parser}/ligodity/dune | 0 .../{parser => 1-parser}/ligodity/ligodity.ml | 0 src/passes/{parser => 1-parser}/parser.ml | 0 src/passes/{parser => 1-parser}/pascaligo.ml | 0 .../pascaligo/.Lexer.ml.tag | 0 .../pascaligo/.LexerMain.tag | 0 .../pascaligo/.Parser.mly.tag | 0 .../pascaligo/.ParserMain.tag | 0 .../{parser => 1-parser}/pascaligo/.gitignore | 0 .../{parser => 1-parser}/pascaligo/.links | 0 .../{parser => 1-parser}/pascaligo/AST.ml | 0 .../{parser => 1-parser}/pascaligo/AST.mli | 0 .../pascaligo/Doc/pascaligo.txt | 0 .../pascaligo/Doc/pascaligo_01.bnf | 0 .../pascaligo/Doc/pascaligo_02.bnf | 0 .../pascaligo/Doc/pascaligo_03.bnf | 0 .../pascaligo/Doc/pascaligo_04.bnf | 0 .../pascaligo/Doc/pascaligo_05.bnf | 0 .../pascaligo/Doc/pascaligo_06.bnf | 0 .../pascaligo/Doc/pascaligo_07.bnf | 0 .../pascaligo/Doc/pascaligo_08.bnf | 0 .../pascaligo/Doc/pascaligo_09.bnf | 0 .../pascaligo/Doc/pascaligo_10.bnf | 0 .../pascaligo/Doc/pascaligo_11.bnf | 0 .../pascaligo/Doc/pascaligo_12.bnf | 0 .../pascaligo/LexToken.mli | 0 .../pascaligo/LexToken.mll | 0 .../pascaligo/LexerMain.ml | 0 .../pascaligo/ParToken.mly | 0 .../{parser => 1-parser}/pascaligo/Parser.mly | 0 .../pascaligo/ParserLog.ml | 0 .../pascaligo/ParserLog.mli | 0 .../pascaligo/ParserMain.ml | 0 .../pascaligo/Stubs/Simple_utils.ml | 0 .../pascaligo/Tests/a.ligo | 0 .../pascaligo/Tests/crowdfunding.ligo | 0 .../pascaligo/check_dot_git_is_dir.sh | 0 .../{parser => 1-parser}/pascaligo/dune | 0 .../pascaligo/pascaligo.ml | 0 src/passes/{parser => 1-parser}/shared/.links | 0 .../shared/Doc/shared.txt | 0 .../{parser => 1-parser}/shared/Error.mli | 0 .../{parser => 1-parser}/shared/EvalOpt.ml | 0 .../{parser => 1-parser}/shared/EvalOpt.mli | 0 .../{parser => 1-parser}/shared/FQueue.ml | 0 .../{parser => 1-parser}/shared/FQueue.mli | 0 .../{parser => 1-parser}/shared/Lexer.mli | 0 .../{parser => 1-parser}/shared/Lexer.mll | 0 .../{parser => 1-parser}/shared/LexerLog.ml | 0 .../{parser => 1-parser}/shared/LexerLog.mli | 0 .../{parser => 1-parser}/shared/Markup.ml | 0 .../{parser => 1-parser}/shared/Markup.mli | 0 .../{parser => 1-parser}/shared/Utils.ml | 0 .../{parser => 1-parser}/shared/Utils.mli | 0 src/passes/{parser => 1-parser}/shared/dune | 0 .../{simplify => 2-simplify}/camligo.ml.old | 0 src/passes/{simplify => 2-simplify}/dune | 0 .../{simplify => 2-simplify}/ligodity.ml | 1 - .../{simplify => 2-simplify}/pascaligo.ml | 98 +++++++------- .../{simplify => 2-simplify}/simplify.ml | 0 src/passes/3-self_ast_simplified/dune | 12 ++ src/passes/3-self_ast_simplified/helpers.ml | 127 ++++++++++++++++++ src/passes/3-self_ast_simplified/main.ml | 0 .../self_ast_simplified.ml | 1 + .../tezos_type_annotation.ml | 16 +++ src/passes/{typer => 4-typer}/dune | 0 src/passes/{typer => 4-typer}/typer.ml | 19 +-- .../transpiler => passes/6-transpiler}/dune | 0 .../6-transpiler}/transpiler.ml | 0 .../8-compiler}/compiler.ml | 0 .../8-compiler}/compiler_environment.ml | 0 .../8-compiler}/compiler_program.ml | 0 .../8-compiler}/compiler_type.ml | 0 .../compiler => passes/8-compiler}/dune | 0 .../8-compiler}/uncompiler.ml | 0 src/run/{main => }/display.ml | 0 src/run/{main => }/dune | 0 src/run/{main => }/main.ml | 0 src/run/{main => }/run_mini_c.ml | 0 src/run/{main => }/run_simplified.ml | 0 src/run/{main => }/run_source.ml | 0 src/run/{main => }/run_typed.ml | 0 src/stages/ast_simplified/PP.ml | 2 +- src/stages/ast_simplified/combinators.ml | 93 +++++++------ src/stages/ast_simplified/misc.ml | 2 +- src/stages/ast_simplified/types.ml | 5 +- test/.merlin | 98 +++++++------- test/coase_tests.ml | 4 +- test/dune | 17 +++ 134 files changed, 340 insertions(+), 173 deletions(-) rename src/passes/{parser => 1-parser}/camligo/.gitignore (100%) rename src/passes/{parser => 1-parser}/camligo/ast.ml (100%) rename src/passes/{parser => 1-parser}/camligo/dune (100%) rename src/passes/{parser => 1-parser}/camligo/generator.ml (100%) rename src/passes/{parser => 1-parser}/camligo/lex/dune (100%) rename src/passes/{parser => 1-parser}/camligo/lex/generator.ml (100%) rename src/passes/{parser => 1-parser}/camligo/location.ml (100%) rename src/passes/{parser => 1-parser}/camligo/parser_camligo.ml (100%) rename src/passes/{parser => 1-parser}/camligo/pre_parser.mly (100%) rename src/passes/{parser => 1-parser}/camligo/user.ml (100%) rename src/passes/{parser => 1-parser}/dune (100%) rename src/passes/{parser => 1-parser}/generator/doc/essai.ml (100%) rename src/passes/{parser => 1-parser}/generator/doc/mini_ml.bnf (100%) rename src/passes/{parser => 1-parser}/generator/doc/mini_ml2.bnf (100%) rename src/passes/{parser => 1-parser}/generator/doc/mini_ml3.bnf (100%) rename src/passes/{parser => 1-parser}/generator/doc/mini_ml4.bnf (100%) rename src/passes/{parser => 1-parser}/ligodity.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/.AST.ml.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.Eval.ml.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.EvalMain.ml.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.Lexer.ml.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.LexerMain.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.Parser.ml.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.Parser.mly.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.ParserMain.tag (100%) rename src/passes/{parser => 1-parser}/ligodity/.links (100%) rename src/passes/{parser => 1-parser}/ligodity/AST.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/AST.mli (100%) rename src/passes/{parser => 1-parser}/ligodity/EvalOpt.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/EvalOpt.mli (100%) rename src/passes/{parser => 1-parser}/ligodity/Lexer.mli (100%) rename src/passes/{parser => 1-parser}/ligodity/Lexer.mll (100%) rename src/passes/{parser => 1-parser}/ligodity/LexerMain.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/ParToken.mly (100%) rename src/passes/{parser => 1-parser}/ligodity/Parser.mly (100%) rename src/passes/{parser => 1-parser}/ligodity/ParserMain.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/Stubs/Simple_utils.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/Tests/match.mml (100%) rename src/passes/{parser => 1-parser}/ligodity/Token.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/Token.mli (100%) rename src/passes/{parser => 1-parser}/ligodity/Utils.ml (100%) rename src/passes/{parser => 1-parser}/ligodity/Utils.mli (100%) rename src/passes/{parser => 1-parser}/ligodity/check_dot_git_is_dir.sh (100%) rename src/passes/{parser => 1-parser}/ligodity/dune (100%) rename src/passes/{parser => 1-parser}/ligodity/ligodity.ml (100%) rename src/passes/{parser => 1-parser}/parser.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo/.Lexer.ml.tag (100%) rename src/passes/{parser => 1-parser}/pascaligo/.LexerMain.tag (100%) rename src/passes/{parser => 1-parser}/pascaligo/.Parser.mly.tag (100%) rename src/passes/{parser => 1-parser}/pascaligo/.ParserMain.tag (100%) rename src/passes/{parser => 1-parser}/pascaligo/.gitignore (100%) rename src/passes/{parser => 1-parser}/pascaligo/.links (100%) rename src/passes/{parser => 1-parser}/pascaligo/AST.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo/AST.mli (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo.txt (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_01.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_02.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_03.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_04.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_05.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_06.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_07.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_08.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_09.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_10.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_11.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/Doc/pascaligo_12.bnf (100%) rename src/passes/{parser => 1-parser}/pascaligo/LexToken.mli (100%) rename src/passes/{parser => 1-parser}/pascaligo/LexToken.mll (100%) rename src/passes/{parser => 1-parser}/pascaligo/LexerMain.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo/ParToken.mly (100%) rename src/passes/{parser => 1-parser}/pascaligo/Parser.mly (100%) rename src/passes/{parser => 1-parser}/pascaligo/ParserLog.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo/ParserLog.mli (100%) rename src/passes/{parser => 1-parser}/pascaligo/ParserMain.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo/Stubs/Simple_utils.ml (100%) rename src/passes/{parser => 1-parser}/pascaligo/Tests/a.ligo (100%) rename src/passes/{parser => 1-parser}/pascaligo/Tests/crowdfunding.ligo (100%) rename src/passes/{parser => 1-parser}/pascaligo/check_dot_git_is_dir.sh (100%) rename src/passes/{parser => 1-parser}/pascaligo/dune (100%) rename src/passes/{parser => 1-parser}/pascaligo/pascaligo.ml (100%) rename src/passes/{parser => 1-parser}/shared/.links (100%) rename src/passes/{parser => 1-parser}/shared/Doc/shared.txt (100%) rename src/passes/{parser => 1-parser}/shared/Error.mli (100%) rename src/passes/{parser => 1-parser}/shared/EvalOpt.ml (100%) rename src/passes/{parser => 1-parser}/shared/EvalOpt.mli (100%) rename src/passes/{parser => 1-parser}/shared/FQueue.ml (100%) rename src/passes/{parser => 1-parser}/shared/FQueue.mli (100%) rename src/passes/{parser => 1-parser}/shared/Lexer.mli (100%) rename src/passes/{parser => 1-parser}/shared/Lexer.mll (100%) rename src/passes/{parser => 1-parser}/shared/LexerLog.ml (100%) rename src/passes/{parser => 1-parser}/shared/LexerLog.mli (100%) rename src/passes/{parser => 1-parser}/shared/Markup.ml (100%) rename src/passes/{parser => 1-parser}/shared/Markup.mli (100%) rename src/passes/{parser => 1-parser}/shared/Utils.ml (100%) rename src/passes/{parser => 1-parser}/shared/Utils.mli (100%) rename src/passes/{parser => 1-parser}/shared/dune (100%) rename src/passes/{simplify => 2-simplify}/camligo.ml.old (100%) rename src/passes/{simplify => 2-simplify}/dune (100%) rename src/passes/{simplify => 2-simplify}/ligodity.ml (99%) rename src/passes/{simplify => 2-simplify}/pascaligo.ml (94%) rename src/passes/{simplify => 2-simplify}/simplify.ml (100%) create mode 100644 src/passes/3-self_ast_simplified/dune create mode 100644 src/passes/3-self_ast_simplified/helpers.ml create mode 100644 src/passes/3-self_ast_simplified/main.ml create mode 100644 src/passes/3-self_ast_simplified/self_ast_simplified.ml create mode 100644 src/passes/3-self_ast_simplified/tezos_type_annotation.ml rename src/passes/{typer => 4-typer}/dune (100%) rename src/passes/{typer => 4-typer}/typer.ml (98%) rename src/{stages/transpiler => passes/6-transpiler}/dune (100%) rename src/{stages/transpiler => passes/6-transpiler}/transpiler.ml (100%) rename src/{stages/compiler => passes/8-compiler}/compiler.ml (100%) rename src/{stages/compiler => passes/8-compiler}/compiler_environment.ml (100%) rename src/{stages/compiler => passes/8-compiler}/compiler_program.ml (100%) rename src/{stages/compiler => passes/8-compiler}/compiler_type.ml (100%) rename src/{stages/compiler => passes/8-compiler}/dune (100%) rename src/{stages/compiler => passes/8-compiler}/uncompiler.ml (100%) rename src/run/{main => }/display.ml (100%) rename src/run/{main => }/dune (100%) rename src/run/{main => }/main.ml (100%) rename src/run/{main => }/run_mini_c.ml (100%) rename src/run/{main => }/run_simplified.ml (100%) rename src/run/{main => }/run_source.ml (100%) rename src/run/{main => }/run_typed.ml (100%) diff --git a/.gitignore b/.gitignore index 52f26081e..25b63a08d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ /_build/ /dune-project *~ +*.merlin cache/* Version.ml /_opam/ diff --git a/src/dune b/src/dune index c2f58b54f..de5be01e6 100644 --- a/src/dune +++ b/src/dune @@ -12,20 +12,3 @@ (pps ppx_let) ) ) - -(alias - (name ligo-test) - (action (run test/test.exe)) - (deps (glob_files contracts/*)) -) - -(alias - (name runtest) - (deps (alias ligo-test)) -) - -(alias - (name manual-test) - (action (run test/manual_test.exe)) - (deps (glob_files contracts/*)) -) diff --git a/src/passes/parser/camligo/.gitignore b/src/passes/1-parser/camligo/.gitignore similarity index 100% rename from src/passes/parser/camligo/.gitignore rename to src/passes/1-parser/camligo/.gitignore diff --git a/src/passes/parser/camligo/ast.ml b/src/passes/1-parser/camligo/ast.ml similarity index 100% rename from src/passes/parser/camligo/ast.ml rename to src/passes/1-parser/camligo/ast.ml diff --git a/src/passes/parser/camligo/dune b/src/passes/1-parser/camligo/dune similarity index 100% rename from src/passes/parser/camligo/dune rename to src/passes/1-parser/camligo/dune diff --git a/src/passes/parser/camligo/generator.ml b/src/passes/1-parser/camligo/generator.ml similarity index 100% rename from src/passes/parser/camligo/generator.ml rename to src/passes/1-parser/camligo/generator.ml diff --git a/src/passes/parser/camligo/lex/dune b/src/passes/1-parser/camligo/lex/dune similarity index 100% rename from src/passes/parser/camligo/lex/dune rename to src/passes/1-parser/camligo/lex/dune diff --git a/src/passes/parser/camligo/lex/generator.ml b/src/passes/1-parser/camligo/lex/generator.ml similarity index 100% rename from src/passes/parser/camligo/lex/generator.ml rename to src/passes/1-parser/camligo/lex/generator.ml diff --git a/src/passes/parser/camligo/location.ml b/src/passes/1-parser/camligo/location.ml similarity index 100% rename from src/passes/parser/camligo/location.ml rename to src/passes/1-parser/camligo/location.ml diff --git a/src/passes/parser/camligo/parser_camligo.ml b/src/passes/1-parser/camligo/parser_camligo.ml similarity index 100% rename from src/passes/parser/camligo/parser_camligo.ml rename to src/passes/1-parser/camligo/parser_camligo.ml diff --git a/src/passes/parser/camligo/pre_parser.mly b/src/passes/1-parser/camligo/pre_parser.mly similarity index 100% rename from src/passes/parser/camligo/pre_parser.mly rename to src/passes/1-parser/camligo/pre_parser.mly diff --git a/src/passes/parser/camligo/user.ml b/src/passes/1-parser/camligo/user.ml similarity index 100% rename from src/passes/parser/camligo/user.ml rename to src/passes/1-parser/camligo/user.ml diff --git a/src/passes/parser/dune b/src/passes/1-parser/dune similarity index 100% rename from src/passes/parser/dune rename to src/passes/1-parser/dune diff --git a/src/passes/parser/generator/doc/essai.ml b/src/passes/1-parser/generator/doc/essai.ml similarity index 100% rename from src/passes/parser/generator/doc/essai.ml rename to src/passes/1-parser/generator/doc/essai.ml diff --git a/src/passes/parser/generator/doc/mini_ml.bnf b/src/passes/1-parser/generator/doc/mini_ml.bnf similarity index 100% rename from src/passes/parser/generator/doc/mini_ml.bnf rename to src/passes/1-parser/generator/doc/mini_ml.bnf diff --git a/src/passes/parser/generator/doc/mini_ml2.bnf b/src/passes/1-parser/generator/doc/mini_ml2.bnf similarity index 100% rename from src/passes/parser/generator/doc/mini_ml2.bnf rename to src/passes/1-parser/generator/doc/mini_ml2.bnf diff --git a/src/passes/parser/generator/doc/mini_ml3.bnf b/src/passes/1-parser/generator/doc/mini_ml3.bnf similarity index 100% rename from src/passes/parser/generator/doc/mini_ml3.bnf rename to src/passes/1-parser/generator/doc/mini_ml3.bnf diff --git a/src/passes/parser/generator/doc/mini_ml4.bnf b/src/passes/1-parser/generator/doc/mini_ml4.bnf similarity index 100% rename from src/passes/parser/generator/doc/mini_ml4.bnf rename to src/passes/1-parser/generator/doc/mini_ml4.bnf diff --git a/src/passes/parser/ligodity.ml b/src/passes/1-parser/ligodity.ml similarity index 100% rename from src/passes/parser/ligodity.ml rename to src/passes/1-parser/ligodity.ml diff --git a/src/passes/parser/ligodity/.AST.ml.tag b/src/passes/1-parser/ligodity/.AST.ml.tag similarity index 100% rename from src/passes/parser/ligodity/.AST.ml.tag rename to src/passes/1-parser/ligodity/.AST.ml.tag diff --git a/src/passes/parser/ligodity/.Eval.ml.tag b/src/passes/1-parser/ligodity/.Eval.ml.tag similarity index 100% rename from src/passes/parser/ligodity/.Eval.ml.tag rename to src/passes/1-parser/ligodity/.Eval.ml.tag diff --git a/src/passes/parser/ligodity/.EvalMain.ml.tag b/src/passes/1-parser/ligodity/.EvalMain.ml.tag similarity index 100% rename from src/passes/parser/ligodity/.EvalMain.ml.tag rename to src/passes/1-parser/ligodity/.EvalMain.ml.tag diff --git a/src/passes/parser/ligodity/.Lexer.ml.tag b/src/passes/1-parser/ligodity/.Lexer.ml.tag similarity index 100% rename from src/passes/parser/ligodity/.Lexer.ml.tag rename to src/passes/1-parser/ligodity/.Lexer.ml.tag diff --git a/src/passes/parser/ligodity/.LexerMain.tag b/src/passes/1-parser/ligodity/.LexerMain.tag similarity index 100% rename from src/passes/parser/ligodity/.LexerMain.tag rename to src/passes/1-parser/ligodity/.LexerMain.tag diff --git a/src/passes/parser/ligodity/.Parser.ml.tag b/src/passes/1-parser/ligodity/.Parser.ml.tag similarity index 100% rename from src/passes/parser/ligodity/.Parser.ml.tag rename to src/passes/1-parser/ligodity/.Parser.ml.tag diff --git a/src/passes/parser/ligodity/.Parser.mly.tag b/src/passes/1-parser/ligodity/.Parser.mly.tag similarity index 100% rename from src/passes/parser/ligodity/.Parser.mly.tag rename to src/passes/1-parser/ligodity/.Parser.mly.tag diff --git a/src/passes/parser/ligodity/.ParserMain.tag b/src/passes/1-parser/ligodity/.ParserMain.tag similarity index 100% rename from src/passes/parser/ligodity/.ParserMain.tag rename to src/passes/1-parser/ligodity/.ParserMain.tag diff --git a/src/passes/parser/ligodity/.links b/src/passes/1-parser/ligodity/.links similarity index 100% rename from src/passes/parser/ligodity/.links rename to src/passes/1-parser/ligodity/.links diff --git a/src/passes/parser/ligodity/AST.ml b/src/passes/1-parser/ligodity/AST.ml similarity index 100% rename from src/passes/parser/ligodity/AST.ml rename to src/passes/1-parser/ligodity/AST.ml diff --git a/src/passes/parser/ligodity/AST.mli b/src/passes/1-parser/ligodity/AST.mli similarity index 100% rename from src/passes/parser/ligodity/AST.mli rename to src/passes/1-parser/ligodity/AST.mli diff --git a/src/passes/parser/ligodity/EvalOpt.ml b/src/passes/1-parser/ligodity/EvalOpt.ml similarity index 100% rename from src/passes/parser/ligodity/EvalOpt.ml rename to src/passes/1-parser/ligodity/EvalOpt.ml diff --git a/src/passes/parser/ligodity/EvalOpt.mli b/src/passes/1-parser/ligodity/EvalOpt.mli similarity index 100% rename from src/passes/parser/ligodity/EvalOpt.mli rename to src/passes/1-parser/ligodity/EvalOpt.mli diff --git a/src/passes/parser/ligodity/Lexer.mli b/src/passes/1-parser/ligodity/Lexer.mli similarity index 100% rename from src/passes/parser/ligodity/Lexer.mli rename to src/passes/1-parser/ligodity/Lexer.mli diff --git a/src/passes/parser/ligodity/Lexer.mll b/src/passes/1-parser/ligodity/Lexer.mll similarity index 100% rename from src/passes/parser/ligodity/Lexer.mll rename to src/passes/1-parser/ligodity/Lexer.mll diff --git a/src/passes/parser/ligodity/LexerMain.ml b/src/passes/1-parser/ligodity/LexerMain.ml similarity index 100% rename from src/passes/parser/ligodity/LexerMain.ml rename to src/passes/1-parser/ligodity/LexerMain.ml diff --git a/src/passes/parser/ligodity/ParToken.mly b/src/passes/1-parser/ligodity/ParToken.mly similarity index 100% rename from src/passes/parser/ligodity/ParToken.mly rename to src/passes/1-parser/ligodity/ParToken.mly diff --git a/src/passes/parser/ligodity/Parser.mly b/src/passes/1-parser/ligodity/Parser.mly similarity index 100% rename from src/passes/parser/ligodity/Parser.mly rename to src/passes/1-parser/ligodity/Parser.mly diff --git a/src/passes/parser/ligodity/ParserMain.ml b/src/passes/1-parser/ligodity/ParserMain.ml similarity index 100% rename from src/passes/parser/ligodity/ParserMain.ml rename to src/passes/1-parser/ligodity/ParserMain.ml diff --git a/src/passes/parser/ligodity/Stubs/Simple_utils.ml b/src/passes/1-parser/ligodity/Stubs/Simple_utils.ml similarity index 100% rename from src/passes/parser/ligodity/Stubs/Simple_utils.ml rename to src/passes/1-parser/ligodity/Stubs/Simple_utils.ml diff --git a/src/passes/parser/ligodity/Tests/match.mml b/src/passes/1-parser/ligodity/Tests/match.mml similarity index 100% rename from src/passes/parser/ligodity/Tests/match.mml rename to src/passes/1-parser/ligodity/Tests/match.mml diff --git a/src/passes/parser/ligodity/Token.ml b/src/passes/1-parser/ligodity/Token.ml similarity index 100% rename from src/passes/parser/ligodity/Token.ml rename to src/passes/1-parser/ligodity/Token.ml diff --git a/src/passes/parser/ligodity/Token.mli b/src/passes/1-parser/ligodity/Token.mli similarity index 100% rename from src/passes/parser/ligodity/Token.mli rename to src/passes/1-parser/ligodity/Token.mli diff --git a/src/passes/parser/ligodity/Utils.ml b/src/passes/1-parser/ligodity/Utils.ml similarity index 100% rename from src/passes/parser/ligodity/Utils.ml rename to src/passes/1-parser/ligodity/Utils.ml diff --git a/src/passes/parser/ligodity/Utils.mli b/src/passes/1-parser/ligodity/Utils.mli similarity index 100% rename from src/passes/parser/ligodity/Utils.mli rename to src/passes/1-parser/ligodity/Utils.mli diff --git a/src/passes/parser/ligodity/check_dot_git_is_dir.sh b/src/passes/1-parser/ligodity/check_dot_git_is_dir.sh similarity index 100% rename from src/passes/parser/ligodity/check_dot_git_is_dir.sh rename to src/passes/1-parser/ligodity/check_dot_git_is_dir.sh diff --git a/src/passes/parser/ligodity/dune b/src/passes/1-parser/ligodity/dune similarity index 100% rename from src/passes/parser/ligodity/dune rename to src/passes/1-parser/ligodity/dune diff --git a/src/passes/parser/ligodity/ligodity.ml b/src/passes/1-parser/ligodity/ligodity.ml similarity index 100% rename from src/passes/parser/ligodity/ligodity.ml rename to src/passes/1-parser/ligodity/ligodity.ml diff --git a/src/passes/parser/parser.ml b/src/passes/1-parser/parser.ml similarity index 100% rename from src/passes/parser/parser.ml rename to src/passes/1-parser/parser.ml diff --git a/src/passes/parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml similarity index 100% rename from src/passes/parser/pascaligo.ml rename to src/passes/1-parser/pascaligo.ml diff --git a/src/passes/parser/pascaligo/.Lexer.ml.tag b/src/passes/1-parser/pascaligo/.Lexer.ml.tag similarity index 100% rename from src/passes/parser/pascaligo/.Lexer.ml.tag rename to src/passes/1-parser/pascaligo/.Lexer.ml.tag diff --git a/src/passes/parser/pascaligo/.LexerMain.tag b/src/passes/1-parser/pascaligo/.LexerMain.tag similarity index 100% rename from src/passes/parser/pascaligo/.LexerMain.tag rename to src/passes/1-parser/pascaligo/.LexerMain.tag diff --git a/src/passes/parser/pascaligo/.Parser.mly.tag b/src/passes/1-parser/pascaligo/.Parser.mly.tag similarity index 100% rename from src/passes/parser/pascaligo/.Parser.mly.tag rename to src/passes/1-parser/pascaligo/.Parser.mly.tag diff --git a/src/passes/parser/pascaligo/.ParserMain.tag b/src/passes/1-parser/pascaligo/.ParserMain.tag similarity index 100% rename from src/passes/parser/pascaligo/.ParserMain.tag rename to src/passes/1-parser/pascaligo/.ParserMain.tag diff --git a/src/passes/parser/pascaligo/.gitignore b/src/passes/1-parser/pascaligo/.gitignore similarity index 100% rename from src/passes/parser/pascaligo/.gitignore rename to src/passes/1-parser/pascaligo/.gitignore diff --git a/src/passes/parser/pascaligo/.links b/src/passes/1-parser/pascaligo/.links similarity index 100% rename from src/passes/parser/pascaligo/.links rename to src/passes/1-parser/pascaligo/.links diff --git a/src/passes/parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml similarity index 100% rename from src/passes/parser/pascaligo/AST.ml rename to src/passes/1-parser/pascaligo/AST.ml diff --git a/src/passes/parser/pascaligo/AST.mli b/src/passes/1-parser/pascaligo/AST.mli similarity index 100% rename from src/passes/parser/pascaligo/AST.mli rename to src/passes/1-parser/pascaligo/AST.mli diff --git a/src/passes/parser/pascaligo/Doc/pascaligo.txt b/src/passes/1-parser/pascaligo/Doc/pascaligo.txt similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo.txt rename to src/passes/1-parser/pascaligo/Doc/pascaligo.txt diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_01.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_01.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_01.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_01.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_02.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_02.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_02.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_02.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_03.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_03.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_03.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_03.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_04.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_04.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_04.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_04.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_05.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_05.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_05.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_05.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_06.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_06.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_06.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_06.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_07.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_07.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_07.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_07.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_08.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_08.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_08.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_08.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_09.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_09.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_09.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_09.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_10.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_10.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_10.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_10.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_11.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_11.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_11.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_11.bnf diff --git a/src/passes/parser/pascaligo/Doc/pascaligo_12.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_12.bnf similarity index 100% rename from src/passes/parser/pascaligo/Doc/pascaligo_12.bnf rename to src/passes/1-parser/pascaligo/Doc/pascaligo_12.bnf diff --git a/src/passes/parser/pascaligo/LexToken.mli b/src/passes/1-parser/pascaligo/LexToken.mli similarity index 100% rename from src/passes/parser/pascaligo/LexToken.mli rename to src/passes/1-parser/pascaligo/LexToken.mli diff --git a/src/passes/parser/pascaligo/LexToken.mll b/src/passes/1-parser/pascaligo/LexToken.mll similarity index 100% rename from src/passes/parser/pascaligo/LexToken.mll rename to src/passes/1-parser/pascaligo/LexToken.mll diff --git a/src/passes/parser/pascaligo/LexerMain.ml b/src/passes/1-parser/pascaligo/LexerMain.ml similarity index 100% rename from src/passes/parser/pascaligo/LexerMain.ml rename to src/passes/1-parser/pascaligo/LexerMain.ml diff --git a/src/passes/parser/pascaligo/ParToken.mly b/src/passes/1-parser/pascaligo/ParToken.mly similarity index 100% rename from src/passes/parser/pascaligo/ParToken.mly rename to src/passes/1-parser/pascaligo/ParToken.mly diff --git a/src/passes/parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly similarity index 100% rename from src/passes/parser/pascaligo/Parser.mly rename to src/passes/1-parser/pascaligo/Parser.mly diff --git a/src/passes/parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml similarity index 100% rename from src/passes/parser/pascaligo/ParserLog.ml rename to src/passes/1-parser/pascaligo/ParserLog.ml diff --git a/src/passes/parser/pascaligo/ParserLog.mli b/src/passes/1-parser/pascaligo/ParserLog.mli similarity index 100% rename from src/passes/parser/pascaligo/ParserLog.mli rename to src/passes/1-parser/pascaligo/ParserLog.mli diff --git a/src/passes/parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml similarity index 100% rename from src/passes/parser/pascaligo/ParserMain.ml rename to src/passes/1-parser/pascaligo/ParserMain.ml diff --git a/src/passes/parser/pascaligo/Stubs/Simple_utils.ml b/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml similarity index 100% rename from src/passes/parser/pascaligo/Stubs/Simple_utils.ml rename to src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml diff --git a/src/passes/parser/pascaligo/Tests/a.ligo b/src/passes/1-parser/pascaligo/Tests/a.ligo similarity index 100% rename from src/passes/parser/pascaligo/Tests/a.ligo rename to src/passes/1-parser/pascaligo/Tests/a.ligo diff --git a/src/passes/parser/pascaligo/Tests/crowdfunding.ligo b/src/passes/1-parser/pascaligo/Tests/crowdfunding.ligo similarity index 100% rename from src/passes/parser/pascaligo/Tests/crowdfunding.ligo rename to src/passes/1-parser/pascaligo/Tests/crowdfunding.ligo diff --git a/src/passes/parser/pascaligo/check_dot_git_is_dir.sh b/src/passes/1-parser/pascaligo/check_dot_git_is_dir.sh similarity index 100% rename from src/passes/parser/pascaligo/check_dot_git_is_dir.sh rename to src/passes/1-parser/pascaligo/check_dot_git_is_dir.sh diff --git a/src/passes/parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune similarity index 100% rename from src/passes/parser/pascaligo/dune rename to src/passes/1-parser/pascaligo/dune diff --git a/src/passes/parser/pascaligo/pascaligo.ml b/src/passes/1-parser/pascaligo/pascaligo.ml similarity index 100% rename from src/passes/parser/pascaligo/pascaligo.ml rename to src/passes/1-parser/pascaligo/pascaligo.ml diff --git a/src/passes/parser/shared/.links b/src/passes/1-parser/shared/.links similarity index 100% rename from src/passes/parser/shared/.links rename to src/passes/1-parser/shared/.links diff --git a/src/passes/parser/shared/Doc/shared.txt b/src/passes/1-parser/shared/Doc/shared.txt similarity index 100% rename from src/passes/parser/shared/Doc/shared.txt rename to src/passes/1-parser/shared/Doc/shared.txt diff --git a/src/passes/parser/shared/Error.mli b/src/passes/1-parser/shared/Error.mli similarity index 100% rename from src/passes/parser/shared/Error.mli rename to src/passes/1-parser/shared/Error.mli diff --git a/src/passes/parser/shared/EvalOpt.ml b/src/passes/1-parser/shared/EvalOpt.ml similarity index 100% rename from src/passes/parser/shared/EvalOpt.ml rename to src/passes/1-parser/shared/EvalOpt.ml diff --git a/src/passes/parser/shared/EvalOpt.mli b/src/passes/1-parser/shared/EvalOpt.mli similarity index 100% rename from src/passes/parser/shared/EvalOpt.mli rename to src/passes/1-parser/shared/EvalOpt.mli diff --git a/src/passes/parser/shared/FQueue.ml b/src/passes/1-parser/shared/FQueue.ml similarity index 100% rename from src/passes/parser/shared/FQueue.ml rename to src/passes/1-parser/shared/FQueue.ml diff --git a/src/passes/parser/shared/FQueue.mli b/src/passes/1-parser/shared/FQueue.mli similarity index 100% rename from src/passes/parser/shared/FQueue.mli rename to src/passes/1-parser/shared/FQueue.mli diff --git a/src/passes/parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli similarity index 100% rename from src/passes/parser/shared/Lexer.mli rename to src/passes/1-parser/shared/Lexer.mli diff --git a/src/passes/parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll similarity index 100% rename from src/passes/parser/shared/Lexer.mll rename to src/passes/1-parser/shared/Lexer.mll diff --git a/src/passes/parser/shared/LexerLog.ml b/src/passes/1-parser/shared/LexerLog.ml similarity index 100% rename from src/passes/parser/shared/LexerLog.ml rename to src/passes/1-parser/shared/LexerLog.ml diff --git a/src/passes/parser/shared/LexerLog.mli b/src/passes/1-parser/shared/LexerLog.mli similarity index 100% rename from src/passes/parser/shared/LexerLog.mli rename to src/passes/1-parser/shared/LexerLog.mli diff --git a/src/passes/parser/shared/Markup.ml b/src/passes/1-parser/shared/Markup.ml similarity index 100% rename from src/passes/parser/shared/Markup.ml rename to src/passes/1-parser/shared/Markup.ml diff --git a/src/passes/parser/shared/Markup.mli b/src/passes/1-parser/shared/Markup.mli similarity index 100% rename from src/passes/parser/shared/Markup.mli rename to src/passes/1-parser/shared/Markup.mli diff --git a/src/passes/parser/shared/Utils.ml b/src/passes/1-parser/shared/Utils.ml similarity index 100% rename from src/passes/parser/shared/Utils.ml rename to src/passes/1-parser/shared/Utils.ml diff --git a/src/passes/parser/shared/Utils.mli b/src/passes/1-parser/shared/Utils.mli similarity index 100% rename from src/passes/parser/shared/Utils.mli rename to src/passes/1-parser/shared/Utils.mli diff --git a/src/passes/parser/shared/dune b/src/passes/1-parser/shared/dune similarity index 100% rename from src/passes/parser/shared/dune rename to src/passes/1-parser/shared/dune diff --git a/src/passes/simplify/camligo.ml.old b/src/passes/2-simplify/camligo.ml.old similarity index 100% rename from src/passes/simplify/camligo.ml.old rename to src/passes/2-simplify/camligo.ml.old diff --git a/src/passes/simplify/dune b/src/passes/2-simplify/dune similarity index 100% rename from src/passes/simplify/dune rename to src/passes/2-simplify/dune diff --git a/src/passes/simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml similarity index 99% rename from src/passes/simplify/ligodity.ml rename to src/passes/2-simplify/ligodity.ml index 34866fd91..10a9b346a 100644 --- a/src/passes/simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -162,7 +162,6 @@ module Errors = struct let message () = "a map definition is a list of pairs" in info title message - let corner_case ~loc message = let title () = "corner case" in let content () = "We don't have a good error message for this case. \ diff --git a/src/passes/simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml similarity index 94% rename from src/passes/simplify/pascaligo.ml rename to src/passes/2-simplify/pascaligo.ml index 4aeab4d2a..92250a149 100644 --- a/src/passes/simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -301,17 +301,31 @@ open Operators.Simplify.Pascaligo let r_split = Location.r_split -let return expr = ok @@ fun expr'_opt -> - let expr = expr in - match expr'_opt with - | None -> ok @@ expr - | Some expr' -> ok @@ e_sequence expr expr' +(* + Statements can't be simplified in isolation. `a ; b ; c` can get simplified either + as `let x = expr in (b ; c)` if `a` is a ` const x = expr` declaration or as + `sequence(a , sequence(b , c))` for everything else. + Because of this, simplifying sequences depend on their contents. To avoid peeking in + their contents, we instead simplify sequences elements as functions from their next + elements to the actual result. + For `return_let_in`, if there is no follow-up element, an error is triggered, as + you can't have `let x = expr in ...` with no `...`. A cleaner option might be to add + a `unit` instead of erroring. + + `return_statement` is used for non-let_in statements. +*) let return_let_in ?loc binder rhs = ok @@ fun expr'_opt -> match expr'_opt with | None -> fail @@ corner_case ~loc:__LOC__ "missing return" | Some expr' -> ok @@ e_let_in ?loc binder rhs expr' +let return_statement expr = ok @@ fun expr'_opt -> + let expr = expr in + match expr'_opt with + | None -> ok @@ expr + | Some expr' -> ok @@ e_sequence expr expr' + let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = match t with | TPar x -> simpl_type_expression x.value.inside @@ -336,10 +350,13 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = ok @@ T_constant (cst , lst') | TProd p -> let%bind tpl = simpl_list_type_expression - @@ npseq_to_list p.value in + @@ npseq_to_list p.value in ok tpl | TRecord r -> - let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in + let aux = fun (x, y) -> + let%bind y = simpl_type_expression y in + ok (x, y) + in let apply = fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in let%bind lst = bind_list @@ -373,34 +390,30 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result let%bind lst = bind_list @@ List.map simpl_type_expression lst in ok @@ T_tuple lst +let simpl_projection : Raw.projection Region.reg -> _ = fun p -> + let (p' , loc) = r_split p in + let var = + let name = p'.struct_name.value in + e_variable name in + let path = p'.field_path in + let path' = + let aux (s:Raw.selection) = + match s with + | FieldName property -> Access_record property.value + | Component index -> Access_tuple (Z.to_int (snd index.value)) + in + List.map aux @@ npseq_to_list path in + ok @@ e_accessor ~loc var path' + + let rec simpl_expression (t:Raw.expr) : expr result = let return x = ok x in - let simpl_projection = fun (p : Raw.projection Region.reg) -> - let (p' , loc) = r_split p in - let var = - let name = p'.struct_name.value in - e_variable name in - let path = p'.field_path in - let path' = - let aux (s:Raw.selection) = - match s with - | FieldName property -> Access_record property.value - | Component index -> Access_tuple (Z.to_int (snd index.value)) - in - List.map aux @@ npseq_to_list path in - return @@ e_accessor ~loc var path' - in match t with | EAnnot a -> ( let ((expr , type_expr) , loc) = r_split a in let%bind expr' = simpl_expression expr in let%bind type_expr' = simpl_type_expression type_expr in - match (Location.unwrap expr', type_expr') with - | (E_literal (Literal_string str) , T_constant ("bytes" , [])) -> - trace_strong (bad_bytes loc str) @@ - e_bytes ~loc str - | _ -> - return @@ e_annotation ~loc expr' type_expr' + return @@ e_annotation ~loc expr' type_expr' ) | EVar c -> ( let (c' , loc) = r_split c in @@ -767,31 +780,25 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu match List.assoc_opt f constants with | None -> let%bind arg = simpl_tuple_expression ~loc:args_loc args' in - return @@ e_application ~loc (e_variable ~loc:f_loc f) arg + return_statement @@ e_application ~loc (e_variable ~loc:f_loc f) arg | Some s -> let%bind lst = bind_map_list simpl_expression args' in - return @@ e_constant ~loc s lst + return_statement @@ e_constant ~loc s lst ) | Fail e -> ( let%bind expr = simpl_expression e.value.fail_expr in - return @@ e_failwith expr + return_statement @@ e_failwith expr ) | Skip reg -> ( let loc = Location.lift reg in - return @@ e_skip ~loc () + return_statement @@ e_skip ~loc () ) | Loop (While l) -> let l = l.value in let%bind cond = simpl_expression l.cond in let%bind body = simpl_block l.block.value in let%bind body = body None in - return @@ e_loop cond body - (* | Loop (For (ForCollect x)) -> ( - * let (x' , loc) = r_split x in - * let%bind expr = simpl_expression x'.expr in - * let%bind body = simpl_block x'.block.value in - * ok _ - * ) *) + return_statement @@ e_loop cond body | Loop (For (ForInt {region; _} | ForCollect {region ; _})) -> fail @@ unsupported_for_loops region | Cond c -> ( @@ -805,7 +812,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu | ClauseBlock b -> simpl_statements @@ fst b.value.inside in let%bind match_true = match_true None in let%bind match_false = match_false None in - return @@ e_matching expr ~loc (Match_bool {match_true; match_false}) + return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false}) ) | Assign a -> ( let (a , loc) = r_split a in @@ -816,7 +823,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu match a.lhs with | Path path -> ( let (name , path') = simpl_path path in - return @@ e_assign ~loc name path' value_expr + return_statement @@ e_assign ~loc name path' value_expr ) | MapPath v -> ( let v' = v.value in @@ -826,7 +833,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let%bind key_expr = simpl_expression v'.index.value.inside in let old_expr = e_variable name.value in let expr' = e_map_add key_expr value_expr old_expr in - return @@ e_assign ~loc name.value [] expr' + return_statement @@ e_assign ~loc name.value [] expr' ) ) | CaseInstr c -> ( @@ -841,7 +848,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu @@ List.map aux @@ npseq_to_list c.cases.value in let%bind m = simpl_cases cases in - return @@ e_matching ~loc expr m + return_statement @@ e_matching ~loc expr m ) | RecordPatch r -> ( let r = r.value in @@ -858,14 +865,13 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu e_assign ~loc name (access_path @ [ Access_record access ]) v in let assigns = List.map aux inj in match assigns with - (* E_sequence (E_skip, E_skip) ? *) | [] -> fail @@ unsupported_empty_record_patch r.record_inj | hd :: tl -> ( let aux acc cur = e_sequence acc cur in ok @@ List.fold_left aux hd tl ) in - return @@ expr + return_statement @@ expr ) | MapPatch patch -> fail @@ unsupported_map_patches patch @@ -879,7 +885,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu | Path path -> fail @@ unsupported_deep_map_rm path in let%bind key' = simpl_expression key in let expr = e_constant ~loc "MAP_REMOVE" [key' ; e_variable map] in - return @@ e_assign ~loc map [] expr + return_statement @@ e_assign ~loc map [] expr ) | SetRemove r -> fail @@ unsupported_set_removal r diff --git a/src/passes/simplify/simplify.ml b/src/passes/2-simplify/simplify.ml similarity index 100% rename from src/passes/simplify/simplify.ml rename to src/passes/2-simplify/simplify.ml diff --git a/src/passes/3-self_ast_simplified/dune b/src/passes/3-self_ast_simplified/dune new file mode 100644 index 000000000..39eacaf3e --- /dev/null +++ b/src/passes/3-self_ast_simplified/dune @@ -0,0 +1,12 @@ +(library + (name self_ast_simplified) + (public_name ligo.self_ast_simplified) + (libraries + simple-utils + ast_simplified + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml new file mode 100644 index 000000000..8b41248eb --- /dev/null +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -0,0 +1,127 @@ +open Ast_simplified +open Trace + +type mapper = expression -> expression result + +let rec map_expression : mapper -> expression -> expression result = fun f e -> + let self = map_expression f in + let%bind e' = f e in + let return expression = ok { e' with expression } in + match e'.expression with + | E_list lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_list lst' + ) + | E_set lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_set lst' + ) + | E_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_map lst' + ) + | E_sequence ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_sequence ab' + ) + | E_look_up ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_look_up ab' + ) + | E_loop ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_loop ab' + ) + | E_annotation (e , t) -> ( + let%bind e' = self e in + return @@ E_annotation (e' , t) + ) + | E_assign (name , path , e) -> ( + let%bind e' = self e in + let%bind path' = map_path f path in + return @@ E_assign (name , path' , e') + ) + | E_failwith e -> ( + let%bind e' = self e in + return @@ E_failwith e' + ) + | E_matching (e , cases) -> ( + let%bind e' = self e in + let%bind cases' = map_cases f cases in + return @@ E_matching (e' , cases') + ) + | E_accessor (e , path) -> ( + let%bind e' = self e in + let%bind path' = map_path f path in + return @@ E_accessor (e' , path') + ) + | E_record m -> ( + let%bind m' = bind_map_smap self m in + return @@ E_record m' + ) + | E_constructor (name , e) -> ( + let%bind e' = self e in + return @@ E_constructor (name , e') + ) + | E_tuple lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_tuple lst' + ) + | E_application ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_application ab' + ) + | E_let_in { binder ; rhs ; result } -> ( + let%bind rhs = self rhs in + let%bind result = self result in + return @@ E_let_in { binder ; rhs ; result } + ) + | E_lambda { binder ; input_type ; output_type ; result } -> ( + let%bind result = self result in + return @@ E_lambda { binder ; input_type ; output_type ; result } + ) + | E_constant (name , lst) -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_constant (name , lst') + ) + | E_literal _ | E_variable _ | E_skip as e' -> return e' + +and map_path : mapper -> access_path -> access_path result = fun f p -> bind_map_list (map_access f) p + +and map_access : mapper -> access -> access result = fun f a -> + match a with + | Access_map e -> ( + let%bind e' = map_expression f e in + ok @@ Access_map e' + ) + | a -> ok a + +and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind match_true = map_expression f match_true in + let%bind match_false = map_expression f match_false in + ok @@ Match_bool { match_true ; match_false } + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( + let%bind match_nil = map_expression f match_nil in + let%bind cons = map_expression f cons in + ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) } + ) + | Match_option { match_none ; match_some = (name , some) } -> ( + let%bind match_none = map_expression f match_none in + let%bind some = map_expression f some in + ok @@ Match_option { match_none ; match_some = (name , some) } + ) + | Match_tuple (names , e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_tuple (names , e') + ) + | Match_variant lst -> ( + let aux ((a , b) , e) = + let%bind e' = map_expression f e in + ok ((a , b) , e') + in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant lst' + ) diff --git a/src/passes/3-self_ast_simplified/main.ml b/src/passes/3-self_ast_simplified/main.ml new file mode 100644 index 000000000..e69de29bb diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml new file mode 100644 index 000000000..48ec6fc50 --- /dev/null +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -0,0 +1 @@ +let convert_annotation = Helpers.map_expression Tezos_type_annotation.peephole_expression diff --git a/src/passes/3-self_ast_simplified/tezos_type_annotation.ml b/src/passes/3-self_ast_simplified/tezos_type_annotation.ml new file mode 100644 index 000000000..cf664cfab --- /dev/null +++ b/src/passes/3-self_ast_simplified/tezos_type_annotation.ml @@ -0,0 +1,16 @@ +open Ast_simplified +open Trace + +let peephole_expression : expression -> expression result = fun e -> + let return expression = ok { e with expression } in + match e.expression with + | E_annotation (e' , t) as e -> ( + match (e'.expression , t) with + | (E_literal (Literal_string str) , T_constant ("address" , [])) -> return @@ E_literal (Literal_address str) + | (E_literal (Literal_string str) , T_constant ("bytes" , [])) -> ( + let%bind e' = e'_bytes str in + return e' + ) + | _ -> return e + ) + | e -> return e diff --git a/src/passes/typer/dune b/src/passes/4-typer/dune similarity index 100% rename from src/passes/typer/dune rename to src/passes/4-typer/dune diff --git a/src/passes/typer/typer.ml b/src/passes/4-typer/typer.ml similarity index 98% rename from src/passes/typer/typer.ml rename to src/passes/4-typer/typer.ml index 5c962cc10..9e2679a1b 100644 --- a/src/passes/typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -382,19 +382,19 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a match tv_opt with | None -> ok () | Some tv' -> O.assert_type_value_eq (tv' , tv) in - let location = Location.get_location ae in + let location = ae.location in ok @@ make_a_e ~location expr tv e in let main_error = let title () = "typing expression" in let content () = "" in let data = [ ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp @@ Location.get_location ae) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) ; ("misc" , fun () -> L.get ()) ; ] in error ~data title content in trace main_error @@ - match Location.unwrap ae with + match ae.expression with (* Basic *) | E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword" | E_variable name -> @@ -406,12 +406,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_literal (Literal_bool b)) (t_bool ()) | E_literal Literal_unit | E_skip -> return (E_literal (Literal_unit)) (t_unit ()) - | E_literal (Literal_string s) -> ( - L.log (Format.asprintf "literal_string option type: %a" PP_helpers.(option O.PP.type_value) tv_opt) ; - match Option.map Ast_typed.get_type' tv_opt with - | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) - | _ -> return (E_literal (Literal_string s)) (t_string ()) - ) + | E_literal (Literal_string s) -> + return (E_literal (Literal_string s)) (t_string ()) | E_literal (Literal_bytes s) -> return (E_literal (Literal_bytes s)) (t_bytes ()) | E_literal (Literal_int n) -> @@ -459,7 +455,6 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a in trace (simple_info "accessing") @@ bind_fold_list aux e' path - (* Sum *) | E_constructor (c, expr) -> let%bind (c_tv, sum_tv) = @@ -569,9 +564,9 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a match input_type with | Some ty -> ok ty | None -> ( - match Location.unwrap result with + match result.expression with | I.E_let_in li -> ( - match Location.unwrap li.rhs with + match li.rhs.expression with | I.E_variable name when name = (fst binder) -> ( match snd li.binder with | Some ty -> ok ty diff --git a/src/stages/transpiler/dune b/src/passes/6-transpiler/dune similarity index 100% rename from src/stages/transpiler/dune rename to src/passes/6-transpiler/dune diff --git a/src/stages/transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml similarity index 100% rename from src/stages/transpiler/transpiler.ml rename to src/passes/6-transpiler/transpiler.ml diff --git a/src/stages/compiler/compiler.ml b/src/passes/8-compiler/compiler.ml similarity index 100% rename from src/stages/compiler/compiler.ml rename to src/passes/8-compiler/compiler.ml diff --git a/src/stages/compiler/compiler_environment.ml b/src/passes/8-compiler/compiler_environment.ml similarity index 100% rename from src/stages/compiler/compiler_environment.ml rename to src/passes/8-compiler/compiler_environment.ml diff --git a/src/stages/compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml similarity index 100% rename from src/stages/compiler/compiler_program.ml rename to src/passes/8-compiler/compiler_program.ml diff --git a/src/stages/compiler/compiler_type.ml b/src/passes/8-compiler/compiler_type.ml similarity index 100% rename from src/stages/compiler/compiler_type.ml rename to src/passes/8-compiler/compiler_type.ml diff --git a/src/stages/compiler/dune b/src/passes/8-compiler/dune similarity index 100% rename from src/stages/compiler/dune rename to src/passes/8-compiler/dune diff --git a/src/stages/compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml similarity index 100% rename from src/stages/compiler/uncompiler.ml rename to src/passes/8-compiler/uncompiler.ml diff --git a/src/run/main/display.ml b/src/run/display.ml similarity index 100% rename from src/run/main/display.ml rename to src/run/display.ml diff --git a/src/run/main/dune b/src/run/dune similarity index 100% rename from src/run/main/dune rename to src/run/dune diff --git a/src/run/main/main.ml b/src/run/main.ml similarity index 100% rename from src/run/main/main.ml rename to src/run/main.ml diff --git a/src/run/main/run_mini_c.ml b/src/run/run_mini_c.ml similarity index 100% rename from src/run/main/run_mini_c.ml rename to src/run/run_mini_c.ml diff --git a/src/run/main/run_simplified.ml b/src/run/run_simplified.ml similarity index 100% rename from src/run/main/run_simplified.ml rename to src/run/run_simplified.ml diff --git a/src/run/main/run_source.ml b/src/run/run_source.ml similarity index 100% rename from src/run/main/run_source.ml rename to src/run/run_source.ml diff --git a/src/run/main/run_typed.ml b/src/run/run_typed.ml similarity index 100% rename from src/run/main/run_typed.ml rename to src/run/run_typed.ml diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 07277c664..01fee164d 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -31,7 +31,7 @@ let literal ppf (l:literal) = match l with | Literal_address s -> fprintf ppf "@%S" s | Literal_operation _ -> fprintf ppf "Operation(...bytes)" -let rec expression ppf (e:expression) = match Location.unwrap e with +let rec expression ppf (e:expression) = match e.expression with | E_literal l -> literal ppf l | E_variable name -> fprintf ppf "%s" name | E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index 622e1039c..a25a08543 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -47,45 +47,52 @@ let t_set key = (T_constant ("set", [key])) let make_name (s : string) : name = s -let e_var ?loc (s : string) : expression = Location.wrap ?loc @@ E_variable s -let e_literal ?loc l : expression = Location.wrap ?loc @@ E_literal l -let e_unit ?loc () : expression = Location.wrap ?loc @@ E_literal (Literal_unit) -let e_int ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_int n) -let e_nat ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_nat n) -let e_timestamp ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_timestamp n) -let e_bool ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bool b) -let e_string ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_string s) -let e_address ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_address s) -let e_tez ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_tez s) -let e_bytes ?loc b : expression result = +let location_wrap ?(loc = Location.generated) expression = + let location = loc in + { location ; expression } + +let e_var ?loc (s : string) : expression = location_wrap ?loc @@ E_variable s +let e_literal ?loc l : expression = location_wrap ?loc @@ E_literal l +let e_unit ?loc () : expression = location_wrap ?loc @@ E_literal (Literal_unit) +let e_int ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_int n) +let e_nat ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_nat n) +let e_timestamp ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_timestamp n) +let e_bool ?loc b : expression = location_wrap ?loc @@ E_literal (Literal_bool b) +let e_string ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_string s) +let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_address s) +let e_tez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_tez s) +let e'_bytes b : expression' result = let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in - ok @@ Location.wrap ?loc @@ E_literal (Literal_bytes bytes) -let e_record ?loc map : expression = Location.wrap ?loc @@ E_record map -let e_tuple ?loc lst : expression = Location.wrap ?loc @@ E_tuple lst -let e_some ?loc s : expression = Location.wrap ?loc @@ E_constant ("SOME", [s]) -let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", []) -let e_map_add ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old]) -let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst -let e_set ?loc lst : expression = Location.wrap ?loc @@ E_set lst -let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst -let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b] -let e_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a) -let e_matching ?loc a b : expression = Location.wrap ?loc @@ E_matching (a , b) + ok @@ E_literal (Literal_bytes bytes) +let e_bytes ?loc b : expression result = + let%bind e' = e'_bytes b in + ok @@ location_wrap ?loc e' +let e_record ?loc map : expression = location_wrap ?loc @@ E_record map +let e_tuple ?loc lst : expression = location_wrap ?loc @@ E_tuple lst +let e_some ?loc s : expression = location_wrap ?loc @@ E_constant ("SOME", [s]) +let e_none ?loc () : expression = location_wrap ?loc @@ E_constant ("NONE", []) +let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old]) +let e_map ?loc lst : expression = location_wrap ?loc @@ E_map lst +let e_set ?loc lst : expression = location_wrap ?loc @@ E_set lst +let e_list ?loc lst : expression = location_wrap ?loc @@ E_list lst +let e_pair ?loc a b : expression = location_wrap ?loc @@ E_tuple [a; b] +let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor (s , a) +let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching (a , b) let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = Location.wrap ?loc @@ E_accessor (a , b) +let e_accessor ?loc a b = location_wrap ?loc @@ E_accessor (a , b) let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b) -let e_variable ?loc v = Location.wrap ?loc @@ E_variable v -let e_failwith ?loc v = Location.wrap ?loc @@ E_failwith v -let e_skip ?loc () = Location.wrap ?loc @@ E_skip -let e_loop ?loc cond body = Location.wrap ?loc @@ E_loop (cond , body) -let e_sequence ?loc a b = Location.wrap ?loc @@ E_sequence (a , b) -let e_let_in ?loc binder rhs result = Location.wrap ?loc @@ E_let_in { binder ; rhs ; result } -let e_annotation ?loc expr ty = Location.wrap ?loc @@ E_annotation (expr , ty) -let e_application ?loc a b = Location.wrap ?loc @@ E_application (a , b) -let e_binop ?loc name a b = Location.wrap ?loc @@ E_constant (name , [a ; b]) -let e_constant ?loc name lst = Location.wrap ?loc @@ E_constant (name , lst) -let e_look_up ?loc x y = Location.wrap ?loc @@ E_look_up (x , y) -let e_assign ?loc a b c = Location.wrap ?loc @@ E_assign (a , b , c) +let e_variable ?loc v = location_wrap ?loc @@ E_variable v +let e_failwith ?loc v = location_wrap ?loc @@ E_failwith v +let e_skip ?loc () = location_wrap ?loc @@ E_skip +let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body) +let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b) +let e_let_in ?loc binder rhs result = location_wrap ?loc @@ E_let_in { binder ; rhs ; result } +let e_annotation ?loc expr ty = location_wrap ?loc @@ E_annotation (expr , ty) +let e_application ?loc a b = location_wrap ?loc @@ E_application (a , b) +let e_binop ?loc name a b = location_wrap ?loc @@ E_constant (name , [a ; b]) +let e_constant ?loc name lst = location_wrap ?loc @@ E_constant (name , lst) +let e_look_up ?loc x y = location_wrap ?loc @@ E_look_up (x , y) +let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (a , b , c) let make_option_typed ?loc e t_opt = match t_opt with @@ -114,14 +121,14 @@ let e_lambda ?loc (binder : string) (output_type : type_expression option) (result : expression) : expression = - Location.wrap ?loc @@ E_lambda { + location_wrap ?loc @@ E_lambda { binder = (make_name binder , input_type) ; input_type = input_type ; output_type = output_type ; result ; } -let e_record ?loc map = Location.wrap ?loc @@ E_record map +let e_record ?loc map = location_wrap ?loc @@ E_record map let e_ez_record ?loc (lst : (string * expr) list) : expression = let map = SMap.of_list lst in @@ -153,28 +160,28 @@ let get_e_list = fun t -> | _ -> simple_fail "not a list" let get_e_failwith = fun e -> - match Location.unwrap e with + match e.expression with | E_failwith fw -> ok fw | _ -> simple_fail "not a failwith" let is_e_failwith e = to_bool @@ get_e_failwith e let extract_pair : expression -> (expression * expression) result = fun e -> - match Location.unwrap e with + match e.expression with | E_tuple [ a ; b ] -> ok (a , b) | _ -> fail @@ bad_kind "pair" e.location let extract_list : expression -> (expression list) result = fun e -> - match Location.unwrap e with + match e.expression with | E_list lst -> ok lst | _ -> fail @@ bad_kind "list" e.location let extract_record : expression -> (string * expression) list result = fun e -> - match Location.unwrap e with + match e.expression with | E_record lst -> ok @@ SMap.to_kv_list lst | _ -> fail @@ bad_kind "record" e.location let extract_map : expression -> (expression * expression) list result = fun e -> - match Location.unwrap e with + match e.expression with | E_map lst -> ok lst | _ -> fail @@ bad_kind "map" e.location diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index e1582b073..7e0dc76ab 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -67,7 +67,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b in trace (fun () -> error (thunk "not equal") error_content ()) @@ - match (Location.unwrap a , Location.unwrap b) with + match (a.expression , b.expression) with | E_literal a , E_literal b -> assert_literal_eq (a, b) | E_literal _ , _ -> diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 88b93beda..1e92cfc67 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -73,7 +73,10 @@ and expression' = (* Annotate *) | E_annotation of expr * type_expression -and expression = expression' Location.wrap +and expression = { + expression : expression' ; + location : Location.t ; +} and access = | Access_tuple of int diff --git a/test/.merlin b/test/.merlin index f2a72b2ea..ae626d691 100644 --- a/test/.merlin +++ b/test/.merlin @@ -66,32 +66,32 @@ B /home/cc/Programming/ligo/_opam/lib/uuidm B /home/cc/Programming/ligo/_opam/lib/uutf B /home/cc/Programming/ligo/_opam/lib/yojson B /home/cc/Programming/ligo/_opam/lib/zarith -B ../../_build/default/src/.ligo.objs/byte -B ../../_build/default/src/ast_simplified/.ast_simplified.objs/byte -B ../../_build/default/src/ast_typed/.ast_typed.objs/byte -B ../../_build/default/src/compiler/.compiler.objs/byte -B ../../_build/default/src/mini_c/.mini_c.objs/byte -B ../../_build/default/src/operators/.operators.objs/byte -B ../../_build/default/src/parser/.parser.objs/byte -B ../../_build/default/src/parser/camligo/.parser_camligo.objs/byte -B ../../_build/default/src/parser/camligo/lex/.lex.objs/byte -B ../../_build/default/src/parser/ligodity/.parser_ligodity.objs/byte -B ../../_build/default/src/parser/pascaligo/.parser_pascaligo.objs/byte -B ../../_build/default/src/parser/shared/.parser_shared.objs/byte -B ../../_build/default/src/run/.run.objs/byte -B ../../_build/default/src/simplify/.simplify.objs/byte -B ../../_build/default/src/test/.test.eobjs/byte -B ../../_build/default/src/transpiler/.transpiler.objs/byte -B ../../_build/default/src/typer/.typer.objs/byte -B ../../_build/default/vendors/ligo-utils/memory-proto-alpha/.memory_proto_alpha.objs/byte -B ../../_build/default/vendors/ligo-utils/proto-alpha-utils/.proto_alpha_utils.objs/byte -B ../../_build/default/vendors/ligo-utils/simple-utils/.simple_utils.objs/byte -B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha-parameters/.tezos_protocol_alpha_parameters.objs/byte -B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_alpha.objs/byte -B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_environment_alpha.objs/byte -B ../../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_raw_protocol_alpha.objs/byte -B ../../_build/default/vendors/ligo-utils/tezos-utils/.tezos_utils.objs/byte -B ../../_build/default/vendors/ligo-utils/tezos-utils/michelson-parser/.michelson_parser.objs/byte +B ../_build/default/src/.ligo.objs/byte +B ../_build/default/src/passes/1-parser/.parser.objs/byte +B ../_build/default/src/passes/1-parser/camligo/.parser_camligo.objs/byte +B ../_build/default/src/passes/1-parser/camligo/lex/.lex.objs/byte +B ../_build/default/src/passes/1-parser/ligodity/.parser_ligodity.objs/byte +B ../_build/default/src/passes/1-parser/pascaligo/.parser_pascaligo.objs/byte +B ../_build/default/src/passes/1-parser/shared/.parser_shared.objs/byte +B ../_build/default/src/passes/2-simplify/.simplify.objs/byte +B ../_build/default/src/passes/4-typer/.typer.objs/byte +B ../_build/default/src/passes/6-transpiler/.transpiler.objs/byte +B ../_build/default/src/passes/8-compiler/.compiler.objs/byte +B ../_build/default/src/passes/operators/.operators.objs/byte +B ../_build/default/src/run/main/.main.objs/byte +B ../_build/default/src/stages/ast_simplified/.ast_simplified.objs/byte +B ../_build/default/src/stages/ast_typed/.ast_typed.objs/byte +B ../_build/default/src/stages/mini_c/.mini_c.objs/byte +B ../_build/default/test/.test.eobjs/byte +B ../_build/default/vendors/ligo-utils/memory-proto-alpha/.memory_proto_alpha.objs/byte +B ../_build/default/vendors/ligo-utils/proto-alpha-utils/.proto_alpha_utils.objs/byte +B ../_build/default/vendors/ligo-utils/simple-utils/.simple_utils.objs/byte +B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha-parameters/.tezos_protocol_alpha_parameters.objs/byte +B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_alpha.objs/byte +B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_environment_alpha.objs/byte +B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_raw_protocol_alpha.objs/byte +B ../_build/default/vendors/ligo-utils/tezos-utils/.tezos_utils.objs/byte +B ../_build/default/vendors/ligo-utils/tezos-utils/michelson-parser/.michelson_parser.objs/byte S /home/cc/Programming/ligo/_opam/lib/alcotest S /home/cc/Programming/ligo/_opam/lib/astring S /home/cc/Programming/ligo/_opam/lib/base/caml @@ -159,29 +159,29 @@ S /home/cc/Programming/ligo/_opam/lib/uuidm S /home/cc/Programming/ligo/_opam/lib/uutf S /home/cc/Programming/ligo/_opam/lib/yojson S /home/cc/Programming/ligo/_opam/lib/zarith -S .. -S ../ast_simplified -S ../ast_typed -S ../compiler -S ../mini_c -S ../operators -S ../parser -S ../parser/camligo -S ../parser/camligo/lex -S ../parser/ligodity -S ../parser/pascaligo -S ../parser/shared -S ../run -S ../simplify +S ../src +S ../src/passes/1-parser +S ../src/passes/1-parser/camligo +S ../src/passes/1-parser/camligo/lex +S ../src/passes/1-parser/ligodity +S ../src/passes/1-parser/pascaligo +S ../src/passes/1-parser/shared +S ../src/passes/2-simplify +S ../src/passes/4-typer +S ../src/passes/6-transpiler +S ../src/passes/8-compiler +S ../src/passes/operators +S ../src/run/main +S ../src/stages/ast_simplified +S ../src/stages/ast_typed +S ../src/stages/mini_c S . -S ../transpiler -S ../typer -S ../../vendors/ligo-utils/memory-proto-alpha -S ../../vendors/ligo-utils/proto-alpha-utils -S ../../vendors/ligo-utils/simple-utils -S ../../vendors/ligo-utils/tezos-protocol-alpha -S ../../vendors/ligo-utils/tezos-protocol-alpha-parameters -S ../../vendors/ligo-utils/tezos-utils -S ../../vendors/ligo-utils/tezos-utils/michelson-parser +S ../vendors/ligo-utils/memory-proto-alpha +S ../vendors/ligo-utils/proto-alpha-utils +S ../vendors/ligo-utils/simple-utils +S ../vendors/ligo-utils/tezos-protocol-alpha +S ../vendors/ligo-utils/tezos-protocol-alpha-parameters +S ../vendors/ligo-utils/tezos-utils +S ../vendors/ligo-utils/tezos-utils/michelson-parser FLG -ppx '/home/cc/Programming/ligo/_build/default/.ppx/0af9cc0ed9166d3107af7264d5703b53/ppx.exe --as-ppx' FLG -w @1..3@5..28@30..39@43@46..47@49..57@61..62-40 -strict-sequence -strict-formats -short-paths -keep-locs -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils diff --git a/test/coase_tests.ml b/test/coase_tests.ml index 1931b9857..bbfd75b51 100644 --- a/test/coase_tests.ml +++ b/test/coase_tests.ml @@ -210,9 +210,9 @@ let sell () = e_pair sell_action storage in let make_expecter : int -> expression -> unit result = fun n result -> - let%bind (ops , storage) = get_e_pair @@ Location.unwrap result in + let%bind (ops , storage) = get_e_pair result.expression in let%bind () = - let%bind lst = get_e_list @@ Location.unwrap ops in + let%bind lst = get_e_list ops.expression in Assert.assert_list_size lst 1 in let expected_storage = let cards = List.hds @@ cards_ez first_owner n in diff --git a/test/dune b/test/dune index 021ae172f..dda46f5e8 100644 --- a/test/dune +++ b/test/dune @@ -10,3 +10,20 @@ ) (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils )) ) + +(alias + (name ligo-test) + (action (run ./test.exe)) + (deps (glob_files contracts/*)) +) + +(alias + (name runtest) + (deps (alias ligo-test)) +) + +(alias + (name manual-test) + (action (run ./manual_test.exe)) + (deps (glob_files contracts/*)) +) From 715812b2c395d6fbd57161ff24978af64b0756e6 Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 10 Sep 2019 15:19:15 +0200 Subject: [PATCH 04/53] more modifications --- src/main/compile/dune | 21 ++ src/main/compile/helpers.ml | 72 +++++++ src/main/compile/michelson.ml | 0 src/main/compile/of_mini_c.ml | 12 ++ src/main/compile/of_simplified.ml | 6 + src/main/compile/of_source.ml | 1 + src/main/compile/of_typed.ml | 11 ++ src/{ => main}/run/display.ml | 0 src/{ => main}/run/dune | 4 +- src/main/run/from_michelson.ml | 25 +++ src/{ => main}/run/main.ml | 0 src/main/run/run_mini_c.ml | 38 ++++ src/{ => main}/run/run_simplified.ml | 0 src/{ => main}/run/run_source.ml | 83 +------- src/{ => main}/run/run_typed.ml | 0 src/passes/8-compiler/compiler_environment.ml | 2 + src/run/run_mini_c.ml | 55 ------ test/.merlin | 187 ------------------ test/coase_tests.ml | 2 +- test/heap_tests.ml | 2 +- test/integration_tests.ml | 4 +- test/vote_tests.ml | 2 +- 22 files changed, 197 insertions(+), 330 deletions(-) create mode 100644 src/main/compile/dune create mode 100644 src/main/compile/helpers.ml create mode 100644 src/main/compile/michelson.ml create mode 100644 src/main/compile/of_mini_c.ml create mode 100644 src/main/compile/of_simplified.ml create mode 100644 src/main/compile/of_source.ml create mode 100644 src/main/compile/of_typed.ml rename src/{ => main}/run/display.ml (100%) rename src/{ => main}/run/dune (88%) create mode 100644 src/main/run/from_michelson.ml rename src/{ => main}/run/main.ml (100%) create mode 100644 src/main/run/run_mini_c.ml rename src/{ => main}/run/run_simplified.ml (100%) rename src/{ => main}/run/run_source.ml (74%) rename src/{ => main}/run/run_typed.ml (100%) delete mode 100644 src/run/run_mini_c.ml delete mode 100644 test/.merlin diff --git a/src/main/compile/dune b/src/main/compile/dune new file mode 100644 index 000000000..bd1ac2d33 --- /dev/null +++ b/src/main/compile/dune @@ -0,0 +1,21 @@ +(library + (name compile) + (public_name ligo.compile) + (libraries + simple-utils + tezos-utils + parser + simplify + ast_simplified + typer + ast_typed + transpiler + mini_c + operators + compiler + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) +) diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml new file mode 100644 index 000000000..5e47665a4 --- /dev/null +++ b/src/main/compile/helpers.ml @@ -0,0 +1,72 @@ +open Trace + +type s_syntax = Syntax_name of string +type v_syntax = Pascaligo | Cameligo + +let syntax_to_variant : s_syntax -> string option -> v_syntax result = + fun syntax source_filename -> + let subr s n = + String.sub s (String.length s - n) n in + let endswith s suffix = + let suffixlen = String.length suffix in + ( String.length s >= suffixlen + && String.equal (subr s suffixlen) suffix) + in + let (Syntax_name syntax) = syntax in + match (syntax , source_filename) with + | "auto" , Some sf when endswith sf ".ligo" -> ok Pascaligo + | "auto" , Some sf when endswith sf ".mligo" -> ok Cameligo + | "auto" , _ -> simple_fail "cannot auto-detect syntax, pleas use -s name_of_syntax" + | "pascaligo" , _ -> ok Pascaligo + | "cameligo" , _ -> ok Cameligo + | _ -> simple_fail "unrecognized parser" + +let parsify_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Pascaligo.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Pascaligo.simpl_program raw in + ok simplified + +let parsify_expression_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Pascaligo.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Pascaligo.simpl_expression raw in + ok simplified + +let parsify_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Ligodity.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Ligodity.simpl_program raw in + ok simplified + +let parsify_expression_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Ligodity.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Ligodity.simpl_expression raw in + ok simplified + +let parsify = fun (syntax : v_syntax) source_filename -> + let%bind parsify = match syntax with + | Pascaligo -> ok parsify_pascaligo + | Cameligo -> ok parsify_ligodity + in + parsify source_filename + +let parsify_expression = fun syntax source -> + let%bind parsify = match syntax with + | Pascaligo -> ok parsify_expression_pascaligo + | Cameligo -> ok parsify_expression_ligodity + in + parsify source diff --git a/src/main/compile/michelson.ml b/src/main/compile/michelson.ml new file mode 100644 index 000000000..e69de29bb diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml new file mode 100644 index 000000000..ea964be97 --- /dev/null +++ b/src/main/compile/of_mini_c.ml @@ -0,0 +1,12 @@ +open Trace +open Mini_c +open Tezos_utils + +let compile_value : value -> type_value -> Michelson.t result = + Compiler.Program.translate_value + +let compile_expression : expression -> Michelson.t result = fun e -> + Compiler.Program.translate_expression e Compiler.Environment.empty + +let compile_function : anon_function -> type_value -> type_value -> Compiler.Program.compiled_program result = fun f in_ty out_ty -> + Compiler.Program.translate_entry f (in_ty , out_ty) diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml new file mode 100644 index 000000000..b8b0ff78e --- /dev/null +++ b/src/main/compile/of_simplified.ml @@ -0,0 +1,6 @@ +open Ast_simplified +open Trace + +let compile_entry (program : program) entry_point = + let%bind typed_program = Typer.type_program program in + Of_typed.compile_entry typed_program entry_point diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml new file mode 100644 index 000000000..f286ab848 --- /dev/null +++ b/src/main/compile/of_source.ml @@ -0,0 +1 @@ +open Trace diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml new file mode 100644 index 000000000..b7a60fa3c --- /dev/null +++ b/src/main/compile/of_typed.ml @@ -0,0 +1,11 @@ +open Trace +open Ast_typed +open Tezos_utils + +let compile_expression : annotated_expression -> Michelson.t result = fun e -> + let%bind mini_c_expression = Transpiler.translate_annotated_expression e in + Of_mini_c.compile_expression mini_c_expression + +let compile_entry : program -> string -> _ = fun p entry -> + let%bind (f , (in_ty , out_ty)) = Transpiler.translate_entry p entry in + Of_mini_c.compile_function f in_ty out_ty diff --git a/src/run/display.ml b/src/main/run/display.ml similarity index 100% rename from src/run/display.ml rename to src/main/run/display.ml diff --git a/src/run/dune b/src/main/run/dune similarity index 88% rename from src/run/dune rename to src/main/run/dune index 747afb217..330bf32d5 100644 --- a/src/run/dune +++ b/src/main/run/dune @@ -1,6 +1,6 @@ (library - (name main) - (public_name ligo.main) + (name run) + (public_name ligo.run) (libraries simple-utils tezos-utils diff --git a/src/main/run/from_michelson.ml b/src/main/run/from_michelson.ml new file mode 100644 index 000000000..f34cb2333 --- /dev/null +++ b/src/main/run/from_michelson.ml @@ -0,0 +1,25 @@ +open Proto_alpha_utils +open Trace +open Compiler.Program +open Memory_proto_alpha.Protocol.Script_ir_translator +open Memory_proto_alpha.X + +type options = Memory_proto_alpha.options + +let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = + let Compiler.Program.{input;output;body} : compiled_program = program in + let (Ex_ty input_ty) = input in + let (Ex_ty output_ty) = output in + let%bind input = + Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ + Memory_proto_alpha.parse_michelson_data input_michelson input_ty in + let body = Michelson.strip_annots body in + let%bind descr = + Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ + Memory_proto_alpha.parse_michelson body + (Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in + let open! Memory_proto_alpha.Protocol.Script_interpreter in + let%bind (Item(output, Empty)) = + Trace.trace_tzresult_lwt (simple_error "error of execution") @@ + Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in + ok (Ex_typed_value (output_ty, output)) diff --git a/src/run/main.ml b/src/main/run/main.ml similarity index 100% rename from src/run/main.ml rename to src/main/run/main.ml diff --git a/src/main/run/run_mini_c.ml b/src/main/run/run_mini_c.ml new file mode 100644 index 000000000..dd3dba8f1 --- /dev/null +++ b/src/main/run/run_mini_c.ml @@ -0,0 +1,38 @@ +open Proto_alpha_utils +open Memory_proto_alpha.X +open Trace +open Mini_c +open Compiler.Program + +type options = { + entry_point : anon_function ; + input_type : type_value ; + output_type : type_value ; + input : value ; + michelson_options : From_michelson.options ; +} + +let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result = + let%bind compiled = + trace error @@ + translate_entry entry ty in + let%bind input_michelson = translate_value input (fst ty) in + if debug_michelson then ( + Format.printf "Program: %a\n" Michelson.pp compiled.body ; + Format.printf "Expression: %a\n" PP.expression entry.result ; + Format.printf "Input: %a\n" PP.value input ; + Format.printf "Input Type: %a\n" PP.type_ (fst ty) ; + Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; + ) ; + let%bind ex_ty_value = From_michelson.run ?options compiled input_michelson in + if debug_michelson then ( + let (Ex_typed_value (ty , v)) = ex_ty_value in + ignore @@ + let%bind michelson_value = + trace_tzresult_lwt (simple_error "debugging run_mini_c") @@ + Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in + Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; + ok () + ) ; + let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in + ok result diff --git a/src/run/run_simplified.ml b/src/main/run/run_simplified.ml similarity index 100% rename from src/run/run_simplified.ml rename to src/main/run/run_simplified.ml diff --git a/src/run/run_source.ml b/src/main/run/run_source.ml similarity index 74% rename from src/run/run_source.ml rename to src/main/run/run_source.ml index 10904914a..214d1e091 100644 --- a/src/run/run_source.ml +++ b/src/main/run/run_source.ml @@ -32,7 +32,7 @@ include struct trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ assert_t_list_operation ops in let%bind () = - trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@ + trace_strong (simple_error "entry-point doesn't identical type (storage) for second parameter and second result") @@ assert_type_value_eq (storage_param , storage_result) in ok (arg' , storage_param) @@ -59,86 +59,7 @@ let transpile_value let%bind r = Run_mini_c.run_entry f ty input in ok (r , snd ty) -let parsify_pascaligo = fun source -> - let%bind raw = - trace (simple_error "parsing") @@ - Parser.Pascaligo.parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Pascaligo.simpl_program raw in - ok simplified - -let parsify_expression_pascaligo = fun source -> - let%bind raw = - trace (simple_error "parsing expression") @@ - Parser.Pascaligo.parse_expression source in - let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Pascaligo.simpl_expression raw in - ok simplified - -let parsify_ligodity = fun source -> - let%bind raw = - trace (simple_error "parsing") @@ - Parser.Ligodity.parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Ligodity.simpl_program raw in - ok simplified - -let parsify_expression_ligodity = fun source -> - let%bind raw = - trace (simple_error "parsing expression") @@ - Parser.Ligodity.parse_expression source in - let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Ligodity.simpl_expression raw in - ok simplified - -type s_syntax = Syntax_name of string -type v_syntax = [`pascaligo | `cameligo ] - -let syntax_to_variant : s_syntax -> string option -> v_syntax result = - fun syntax source_filename -> - let subr s n = - String.sub s (String.length s - n) n in - let endswith s suffix = - let suffixlen = String.length suffix in - ( String.length s >= suffixlen - && String.equal (subr s suffixlen) suffix) - in - match syntax with - Syntax_name syntax -> - begin - if String.equal syntax "auto" then - begin - match source_filename with - | Some source_filename - when endswith source_filename ".ligo" - -> ok `pascaligo - | Some source_filename - when endswith source_filename ".mligo" - -> ok `cameligo - | _ -> simple_fail "cannot auto-detect syntax, pleas use -s name_of_syntax" - end - else if String.equal syntax "pascaligo" then ok `pascaligo - else if String.equal syntax "cameligo" then ok `cameligo - else simple_fail "unrecognized parser" - end - -let parsify = fun (syntax : v_syntax) source_filename -> - let%bind parsify = match syntax with - | `pascaligo -> ok parsify_pascaligo - | `cameligo -> ok parsify_ligodity - in - parsify source_filename - -let parsify_expression = fun syntax source -> - let%bind parsify = match syntax with - | `pascaligo -> ok parsify_expression_pascaligo - | `cameligo -> ok parsify_expression_ligodity - in - parsify source +open Helpers let compile_contract_file : string -> string -> s_syntax -> string result = fun source_filename entry_point syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in diff --git a/src/run/run_typed.ml b/src/main/run/run_typed.ml similarity index 100% rename from src/run/run_typed.ml rename to src/main/run/run_typed.ml diff --git a/src/passes/8-compiler/compiler_environment.ml b/src/passes/8-compiler/compiler_environment.ml index c5fcd040b..a196d9c49 100644 --- a/src/passes/8-compiler/compiler_environment.ml +++ b/src/passes/8-compiler/compiler_environment.ml @@ -3,6 +3,8 @@ open Mini_c open Environment open Michelson +let empty : environment = [] + let get : environment -> string -> michelson result = fun e s -> let%bind (_ , position) = let error = diff --git a/src/run/run_mini_c.ml b/src/run/run_mini_c.ml deleted file mode 100644 index d13b4cc54..000000000 --- a/src/run/run_mini_c.ml +++ /dev/null @@ -1,55 +0,0 @@ -open Proto_alpha_utils -open Trace -open Mini_c -open! Compiler.Program -open Memory_proto_alpha.Protocol.Script_ir_translator -open Memory_proto_alpha.X - -let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = - let Compiler.Program.{input;output;body} : compiled_program = program in - let (Ex_ty input_ty) = input in - let (Ex_ty output_ty) = output in - let%bind input = - Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ - Memory_proto_alpha.parse_michelson_data input_michelson input_ty in - let body = Michelson.strip_annots body in - let%bind descr = - Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ - Memory_proto_alpha.parse_michelson body - (Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in - let open! Memory_proto_alpha.Protocol.Script_interpreter in - let%bind (Item(output, Empty)) = - Trace.trace_tzresult_lwt (simple_error "error of execution") @@ - Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in - ok (Ex_typed_value (output_ty, output)) - -let run_entry ?(debug_michelson = false) ?options (entry:anon_function) ty (input:value) : value result = - let%bind compiled = - let error = - let title () = "compile entry" in - let content () = - Format.asprintf "%a" PP.function_ entry - in - error title content in - trace error @@ - translate_entry entry ty in - let%bind input_michelson = translate_value input (fst ty) in - if debug_michelson then ( - Format.printf "Program: %a\n" Michelson.pp compiled.body ; - Format.printf "Expression: %a\n" PP.expression entry.result ; - Format.printf "Input: %a\n" PP.value input ; - Format.printf "Input Type: %a\n" PP.type_ (fst ty) ; - Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; - ) ; - let%bind ex_ty_value = run_aux ?options compiled input_michelson in - if debug_michelson then ( - let (Ex_typed_value (ty , v)) = ex_ty_value in - ignore @@ - let%bind michelson_value = - trace_tzresult_lwt (simple_error "debugging run_mini_c") @@ - Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in - Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; - ok () - ) ; - let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in - ok result diff --git a/test/.merlin b/test/.merlin deleted file mode 100644 index ae626d691..000000000 --- a/test/.merlin +++ /dev/null @@ -1,187 +0,0 @@ -EXCLUDE_QUERY_DIR -B /home/cc/Programming/ligo/_opam/lib/alcotest -B /home/cc/Programming/ligo/_opam/lib/astring -B /home/cc/Programming/ligo/_opam/lib/base/caml -B /home/cc/Programming/ligo/_opam/lib/bigarray-compat -B /home/cc/Programming/ligo/_opam/lib/bigstring -B /home/cc/Programming/ligo/_opam/lib/biniou -B /home/cc/Programming/ligo/_opam/lib/blake2 -B /home/cc/Programming/ligo/_opam/lib/bytes -B /home/cc/Programming/ligo/_opam/lib/cmdliner -B /home/cc/Programming/ligo/_opam/lib/cstruct -B /home/cc/Programming/ligo/_opam/lib/easy-format -B /home/cc/Programming/ligo/_opam/lib/ezjsonm -B /home/cc/Programming/ligo/_opam/lib/fmt -B /home/cc/Programming/ligo/_opam/lib/getopt -B /home/cc/Programming/ligo/_opam/lib/hacl -B /home/cc/Programming/ligo/_opam/lib/hex -B /home/cc/Programming/ligo/_opam/lib/ipaddr -B /home/cc/Programming/ligo/_opam/lib/ipaddr/unix -B /home/cc/Programming/ligo/_opam/lib/jsonm -B /home/cc/Programming/ligo/_opam/lib/lwt -B /home/cc/Programming/ligo/_opam/lib/lwt/unix -B /home/cc/Programming/ligo/_opam/lib/lwt_log -B /home/cc/Programming/ligo/_opam/lib/lwt_log/core -B /home/cc/Programming/ligo/_opam/lib/macaddr -B /home/cc/Programming/ligo/_opam/lib/mmap -B /home/cc/Programming/ligo/_opam/lib/mtime -B /home/cc/Programming/ligo/_opam/lib/mtime/os -B /home/cc/Programming/ligo/_opam/lib/ocaml -B /home/cc/Programming/ligo/_opam/lib/ocaml/threads -B /home/cc/Programming/ligo/_opam/lib/ocplib-endian -B /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed -B /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed-bson -B /home/cc/Programming/ligo/_opam/lib/ocplib-resto -B /home/cc/Programming/ligo/_opam/lib/ocplib-resto-directory -B /home/cc/Programming/ligo/_opam/lib/parsexp -B /home/cc/Programming/ligo/_opam/lib/ppx_deriving/runtime -B /home/cc/Programming/ligo/_opam/lib/ptime -B /home/cc/Programming/ligo/_opam/lib/ptime/os -B /home/cc/Programming/ligo/_opam/lib/re -B /home/cc/Programming/ligo/_opam/lib/re/posix -B /home/cc/Programming/ligo/_opam/lib/re/str -B /home/cc/Programming/ligo/_opam/lib/result -B /home/cc/Programming/ligo/_opam/lib/secp256k1 -B /home/cc/Programming/ligo/_opam/lib/seq -B /home/cc/Programming/ligo/_opam/lib/sexplib -B /home/cc/Programming/ligo/_opam/lib/sexplib0 -B /home/cc/Programming/ligo/_opam/lib/stdlib-shims -B /home/cc/Programming/ligo/_opam/lib/stringext -B /home/cc/Programming/ligo/_opam/lib/tezos-base -B /home/cc/Programming/ligo/_opam/lib/tezos-clic -B /home/cc/Programming/ligo/_opam/lib/tezos-crypto -B /home/cc/Programming/ligo/_opam/lib/tezos-data-encoding -B /home/cc/Programming/ligo/_opam/lib/tezos-error-monad -B /home/cc/Programming/ligo/_opam/lib/tezos-event-logging -B /home/cc/Programming/ligo/_opam/lib/tezos-micheline -B /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment -B /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment-sigs -B /home/cc/Programming/ligo/_opam/lib/tezos-rpc -B /home/cc/Programming/ligo/_opam/lib/tezos-stdlib -B /home/cc/Programming/ligo/_opam/lib/tezos-stdlib-unix -B /home/cc/Programming/ligo/_opam/lib/uchar -B /home/cc/Programming/ligo/_opam/lib/uecc -B /home/cc/Programming/ligo/_opam/lib/uri -B /home/cc/Programming/ligo/_opam/lib/uuidm -B /home/cc/Programming/ligo/_opam/lib/uutf -B /home/cc/Programming/ligo/_opam/lib/yojson -B /home/cc/Programming/ligo/_opam/lib/zarith -B ../_build/default/src/.ligo.objs/byte -B ../_build/default/src/passes/1-parser/.parser.objs/byte -B ../_build/default/src/passes/1-parser/camligo/.parser_camligo.objs/byte -B ../_build/default/src/passes/1-parser/camligo/lex/.lex.objs/byte -B ../_build/default/src/passes/1-parser/ligodity/.parser_ligodity.objs/byte -B ../_build/default/src/passes/1-parser/pascaligo/.parser_pascaligo.objs/byte -B ../_build/default/src/passes/1-parser/shared/.parser_shared.objs/byte -B ../_build/default/src/passes/2-simplify/.simplify.objs/byte -B ../_build/default/src/passes/4-typer/.typer.objs/byte -B ../_build/default/src/passes/6-transpiler/.transpiler.objs/byte -B ../_build/default/src/passes/8-compiler/.compiler.objs/byte -B ../_build/default/src/passes/operators/.operators.objs/byte -B ../_build/default/src/run/main/.main.objs/byte -B ../_build/default/src/stages/ast_simplified/.ast_simplified.objs/byte -B ../_build/default/src/stages/ast_typed/.ast_typed.objs/byte -B ../_build/default/src/stages/mini_c/.mini_c.objs/byte -B ../_build/default/test/.test.eobjs/byte -B ../_build/default/vendors/ligo-utils/memory-proto-alpha/.memory_proto_alpha.objs/byte -B ../_build/default/vendors/ligo-utils/proto-alpha-utils/.proto_alpha_utils.objs/byte -B ../_build/default/vendors/ligo-utils/simple-utils/.simple_utils.objs/byte -B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha-parameters/.tezos_protocol_alpha_parameters.objs/byte -B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_alpha.objs/byte -B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_protocol_environment_alpha.objs/byte -B ../_build/default/vendors/ligo-utils/tezos-protocol-alpha/.tezos_raw_protocol_alpha.objs/byte -B ../_build/default/vendors/ligo-utils/tezos-utils/.tezos_utils.objs/byte -B ../_build/default/vendors/ligo-utils/tezos-utils/michelson-parser/.michelson_parser.objs/byte -S /home/cc/Programming/ligo/_opam/lib/alcotest -S /home/cc/Programming/ligo/_opam/lib/astring -S /home/cc/Programming/ligo/_opam/lib/base/caml -S /home/cc/Programming/ligo/_opam/lib/bigarray-compat -S /home/cc/Programming/ligo/_opam/lib/bigstring -S /home/cc/Programming/ligo/_opam/lib/biniou -S /home/cc/Programming/ligo/_opam/lib/blake2 -S /home/cc/Programming/ligo/_opam/lib/bytes -S /home/cc/Programming/ligo/_opam/lib/cmdliner -S /home/cc/Programming/ligo/_opam/lib/cstruct -S /home/cc/Programming/ligo/_opam/lib/easy-format -S /home/cc/Programming/ligo/_opam/lib/ezjsonm -S /home/cc/Programming/ligo/_opam/lib/fmt -S /home/cc/Programming/ligo/_opam/lib/getopt -S /home/cc/Programming/ligo/_opam/lib/hacl -S /home/cc/Programming/ligo/_opam/lib/hex -S /home/cc/Programming/ligo/_opam/lib/ipaddr -S /home/cc/Programming/ligo/_opam/lib/ipaddr/unix -S /home/cc/Programming/ligo/_opam/lib/jsonm -S /home/cc/Programming/ligo/_opam/lib/lwt -S /home/cc/Programming/ligo/_opam/lib/lwt/unix -S /home/cc/Programming/ligo/_opam/lib/lwt_log -S /home/cc/Programming/ligo/_opam/lib/lwt_log/core -S /home/cc/Programming/ligo/_opam/lib/macaddr -S /home/cc/Programming/ligo/_opam/lib/mmap -S /home/cc/Programming/ligo/_opam/lib/mtime -S /home/cc/Programming/ligo/_opam/lib/mtime/os -S /home/cc/Programming/ligo/_opam/lib/ocaml -S /home/cc/Programming/ligo/_opam/lib/ocaml/threads -S /home/cc/Programming/ligo/_opam/lib/ocplib-endian -S /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed -S /home/cc/Programming/ligo/_opam/lib/ocplib-json-typed-bson -S /home/cc/Programming/ligo/_opam/lib/ocplib-resto -S /home/cc/Programming/ligo/_opam/lib/ocplib-resto-directory -S /home/cc/Programming/ligo/_opam/lib/parsexp -S /home/cc/Programming/ligo/_opam/lib/ppx_deriving/runtime -S /home/cc/Programming/ligo/_opam/lib/ptime -S /home/cc/Programming/ligo/_opam/lib/ptime/os -S /home/cc/Programming/ligo/_opam/lib/re -S /home/cc/Programming/ligo/_opam/lib/re/posix -S /home/cc/Programming/ligo/_opam/lib/re/str -S /home/cc/Programming/ligo/_opam/lib/result -S /home/cc/Programming/ligo/_opam/lib/secp256k1 -S /home/cc/Programming/ligo/_opam/lib/seq -S /home/cc/Programming/ligo/_opam/lib/sexplib -S /home/cc/Programming/ligo/_opam/lib/sexplib0 -S /home/cc/Programming/ligo/_opam/lib/stdlib-shims -S /home/cc/Programming/ligo/_opam/lib/stringext -S /home/cc/Programming/ligo/_opam/lib/tezos-base -S /home/cc/Programming/ligo/_opam/lib/tezos-clic -S /home/cc/Programming/ligo/_opam/lib/tezos-crypto -S /home/cc/Programming/ligo/_opam/lib/tezos-data-encoding -S /home/cc/Programming/ligo/_opam/lib/tezos-error-monad -S /home/cc/Programming/ligo/_opam/lib/tezos-event-logging -S /home/cc/Programming/ligo/_opam/lib/tezos-micheline -S /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment -S /home/cc/Programming/ligo/_opam/lib/tezos-protocol-environment-sigs -S /home/cc/Programming/ligo/_opam/lib/tezos-rpc -S /home/cc/Programming/ligo/_opam/lib/tezos-stdlib -S /home/cc/Programming/ligo/_opam/lib/tezos-stdlib-unix -S /home/cc/Programming/ligo/_opam/lib/uchar -S /home/cc/Programming/ligo/_opam/lib/uecc -S /home/cc/Programming/ligo/_opam/lib/uri -S /home/cc/Programming/ligo/_opam/lib/uuidm -S /home/cc/Programming/ligo/_opam/lib/uutf -S /home/cc/Programming/ligo/_opam/lib/yojson -S /home/cc/Programming/ligo/_opam/lib/zarith -S ../src -S ../src/passes/1-parser -S ../src/passes/1-parser/camligo -S ../src/passes/1-parser/camligo/lex -S ../src/passes/1-parser/ligodity -S ../src/passes/1-parser/pascaligo -S ../src/passes/1-parser/shared -S ../src/passes/2-simplify -S ../src/passes/4-typer -S ../src/passes/6-transpiler -S ../src/passes/8-compiler -S ../src/passes/operators -S ../src/run/main -S ../src/stages/ast_simplified -S ../src/stages/ast_typed -S ../src/stages/mini_c -S . -S ../vendors/ligo-utils/memory-proto-alpha -S ../vendors/ligo-utils/proto-alpha-utils -S ../vendors/ligo-utils/simple-utils -S ../vendors/ligo-utils/tezos-protocol-alpha -S ../vendors/ligo-utils/tezos-protocol-alpha-parameters -S ../vendors/ligo-utils/tezos-utils -S ../vendors/ligo-utils/tezos-utils/michelson-parser -FLG -ppx '/home/cc/Programming/ligo/_build/default/.ppx/0af9cc0ed9166d3107af7264d5703b53/ppx.exe --as-ppx' -FLG -w @1..3@5..28@30..39@43@46..47@49..57@61..62-40 -strict-sequence -strict-formats -short-paths -keep-locs -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils diff --git a/test/coase_tests.ml b/test/coase_tests.ml index bbfd75b51..135f9b429 100644 --- a/test/coase_tests.ml +++ b/test/coase_tests.ml @@ -4,7 +4,7 @@ open Trace open Ligo.Run open Test_helpers -let type_file = type_file `pascaligo +let type_file = type_file Pascaligo let get_program = let s = ref None in diff --git a/test/heap_tests.ml b/test/heap_tests.ml index 5a6f440df..fb3821f27 100644 --- a/test/heap_tests.ml +++ b/test/heap_tests.ml @@ -2,7 +2,7 @@ open Trace open Ligo.Run open Test_helpers -let type_file = type_file `pascaligo +let type_file = type_file Pascaligo let get_program = let s = ref None in diff --git a/test/integration_tests.ml b/test/integration_tests.ml index 4432f07b9..781cb3a53 100644 --- a/test/integration_tests.ml +++ b/test/integration_tests.ml @@ -4,8 +4,8 @@ open Test_helpers open Ast_simplified.Combinators -let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed `cameligo -let type_file = type_file `pascaligo +let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed Cameligo +let type_file = type_file Pascaligo let type_alias () : unit result = let%bind program = type_file "./contracts/type-alias.ligo" in diff --git a/test/vote_tests.ml b/test/vote_tests.ml index d4d1f9336..fbcf2b7ee 100644 --- a/test/vote_tests.ml +++ b/test/vote_tests.ml @@ -7,7 +7,7 @@ let get_program = fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = type_file `cameligo "./contracts/vote.mligo" in + let%bind program = type_file Cameligo "./contracts/vote.mligo" in s := Some program ; ok program ) From 5566095e495cd8ff07a1ec406c7e64da6cd2bdc5 Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 11 Sep 2019 13:56:39 +0200 Subject: [PATCH 05/53] more stuff --- src/main/compile/of_simplified.ml | 13 +- src/main/compile/of_source.ml | 18 + src/main/compile/of_typed.ml | 112 ++++- src/main/dune | 12 + src/main/main.ml | 2 + src/main/run/run_mini_c.ml | 9 +- src/main/run/run_typed.ml | 7 +- src/passes/4-typer/typer.ml | 15 +- src/passes/6-transpiler/helpers.ml | 49 ++ src/passes/6-transpiler/transpiler.ml | 439 ++++-------------- src/passes/6-transpiler/untranspiler.ml | 193 ++++++++ src/passes/8-compiler/compiler_program.ml | 9 +- src/passes/operators/operators.ml | 7 +- src/stages/ast_typed/PP.ml | 7 +- src/stages/ast_typed/combinators.ml | 6 +- .../ast_typed/combinators_environment.ml | 2 +- src/stages/ast_typed/misc.ml | 2 +- src/stages/ast_typed/misc_smart.ml | 8 +- src/stages/ast_typed/types.ml | 8 +- src/stages/mini_c/combinators.ml | 4 +- 20 files changed, 523 insertions(+), 399 deletions(-) create mode 100644 src/main/dune create mode 100644 src/main/main.ml create mode 100644 src/passes/6-transpiler/helpers.ml create mode 100644 src/passes/6-transpiler/untranspiler.ml diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index b8b0ff78e..27bf6ebef 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -1,6 +1,15 @@ open Ast_simplified open Trace +open Tezos_utils -let compile_entry (program : program) entry_point = +let compile_function_entry (program : program) entry_point : Compiler.Program.compiled_program result = let%bind typed_program = Typer.type_program program in - Of_typed.compile_entry typed_program entry_point + Of_typed.compile_function_entry typed_program entry_point + +let compile_expression_entry (program : program) entry_point : Compiler.Program.compiled_program result = + let%bind typed_program = Typer.type_program program in + Of_typed.compile_expression_entry typed_program entry_point + +let compile_expression ae : Michelson.t result = + let%bind typed = Typer.type_expression Ast_typed.Environment.full_empty ae in + Of_typed.compile_expression typed diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index f286ab848..a4fd4e814 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -1 +1,19 @@ open Trace +open Helpers +open Tezos_utils + +let parse_file_program source_filename syntax = + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify syntax source_filename in + ok simplified + +let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compiled_program result = + fun source_filename entry_point syntax -> + let%bind simplified = parse_file_program source_filename syntax in + Of_simplified.compile_function_entry simplified entry_point + +let compile_file_parameter : string -> string -> string -> s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify_expression syntax expression in + Of_simplified.compile_expression simplified diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index b7a60fa3c..96adc461c 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -2,10 +2,116 @@ open Trace open Ast_typed open Tezos_utils +module Errors = struct + + let missing_entry_point name = + let title () = "missing entry point" in + let content () = "no entry point with the given name" in + let data = [ + ("name" , fun () -> name) ; + ] in + error ~data title content + + let not_functional_main location = + let title () = "not functional main" in + let content () = "main should be a function" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title content + +end + +(* + This converts `expr` in `fun () -> expr`. +*) +let functionalize (body : annotated_expression) : annotated_expression = + let expression = E_lambda { binder = "_" ; body } in + let type_annotation = t_function (t_unit ()) body.type_annotation () in + { body with expression ; type_annotation } + let compile_expression : annotated_expression -> Michelson.t result = fun e -> - let%bind mini_c_expression = Transpiler.translate_annotated_expression e in + let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in Of_mini_c.compile_expression mini_c_expression -let compile_entry : program -> string -> _ = fun p entry -> - let%bind (f , (in_ty , out_ty)) = Transpiler.translate_entry p entry in +(* + val compile_value : annotated_expression -> Michelson.t result + This requires writing a function + `transpile_expression_as_value : annotated_expression -> Mini_c.value result` + *) + +let compile_function expr = + let%bind l = get_lambda expr.expression in + let%bind io = get_t_function expr.type_annotation in + let%bind mini_c = Transpiler.transpile_lambda Mini_c.Environment.empty l io in + let%bind (f , (in_ty , out_ty)) = + match (mini_c.content , mini_c.type_value) with + | E_literal (D_function f) , T_function ty -> ok (f , ty) + | _ -> fail @@ Errors.not_functional_main expr.location + in Of_mini_c.compile_function f in_ty out_ty + +(* + Assume the following code: + ``` + const x = 42 + const y = 120 + const z = 423 + const f = () -> x + y + ``` + It is transformed in: + ``` + const f = () -> + let x = 42 in + let y = 120 in + let z = 423 in + x + y + ``` + + To do so, each declaration `const variable = expr` is translated in + a function `body -> let variable = expr in body`. Those functions are + then applied in order, which yields `let x = 42 in let y = 120 in ...`. + + The entry-point can be an expression, which is then functionalized if + `to_functionalize` is set to true. +*) +let aggregate_declarations_for_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result = + let rec aux acc (lst : program) = + let%bind acc = acc in + match lst with + | [] -> fail @@ Errors.missing_entry_point name + | hd :: tl -> ( + let (Declaration_constant (an , (pre_env , _))) = Location.unwrap hd in + if (an.name <> name) then ( + let next = fun expr -> + let cur = e_a_let_in an.name an.annotated_expression expr pre_env in + acc cur in + aux (ok next) tl + ) else ( + match (an.annotated_expression.expression , to_functionalize) with + | (E_lambda l , false) -> ( + let l' = { l with body = acc l.body } in + let e' = { an.annotated_expression with expression = E_lambda l' } in + ok e' + ) + | (_ , true) -> ( + ok @@ functionalize @@ acc an.annotated_expression + ) + | _ -> fail @@ Errors.not_functional_main an.annotated_expression.location + ) + ) + in + let%bind l = aux (ok (fun x -> x)) lst in + ok l + +let compile_function_entry : program -> string -> _ = fun p entry -> + let%bind expr = aggregate_declarations_for_entry p entry false in + compile_function expr + +let compile_expression_entry : program -> string -> _ = fun p entry -> + let%bind expr = aggregate_declarations_for_entry p entry true in + compile_function expr + +let compile_expression_as_function : annotated_expression -> Compiler.Program.compiled_program result = fun e -> + let expr = functionalize e in + compile_function expr diff --git a/src/main/dune b/src/main/dune new file mode 100644 index 000000000..f4bfd2efd --- /dev/null +++ b/src/main/dune @@ -0,0 +1,12 @@ +(library + (name main) + (public_name ligo.main) + (libraries + run + compile + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) +) diff --git a/src/main/main.ml b/src/main/main.ml new file mode 100644 index 000000000..5795d1e56 --- /dev/null +++ b/src/main/main.ml @@ -0,0 +1,2 @@ +module Run = Run +module Compile = Compile diff --git a/src/main/run/run_mini_c.ml b/src/main/run/run_mini_c.ml index dd3dba8f1..06864c223 100644 --- a/src/main/run/run_mini_c.ml +++ b/src/main/run/run_mini_c.ml @@ -4,6 +4,13 @@ open Trace open Mini_c open Compiler.Program +module Errors = struct + + let entry_error = + simple_error "error translating entry point" + +end + type options = { entry_point : anon_function ; input_type : type_value ; @@ -14,7 +21,7 @@ type options = { let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result = let%bind compiled = - trace error @@ + trace Errors.entry_error @@ translate_entry entry ty in let%bind input_michelson = translate_value input (fst ty) in if debug_michelson then ( diff --git a/src/main/run/run_typed.ml b/src/main/run/run_typed.ml index fc136c63c..0f41fe6fa 100644 --- a/src/main/run/run_typed.ml +++ b/src/main/run/run_typed.ml @@ -1,7 +1,7 @@ open Trace +open Ast_typed -let transpile_value - (e:Ast_typed.annotated_expression) : Mini_c.value result = +let evaluate (e : annotated_expression) : annotated_expression result = let%bind (f , ty) = let open Transpiler in let (f , _) = functionalize e in @@ -32,7 +32,8 @@ let evaluate_typed let run_typed ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) - (program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + (program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + let%bind let%bind () = let open Ast_typed in let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 9e2679a1b..edc9d05b8 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -582,9 +582,9 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a bind_map_option (evaluate_type e) output_type in let e' = Environment.add_ez_binder (fst binder) input_type e in - let%bind result = type_expression ?tv_opt:output_type e' result in - let output_type = result.type_annotation in - return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ()) + let%bind body = type_expression ?tv_opt:output_type e' result in + let output_type = body.type_annotation in + return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) ) | E_constant (name, lst) -> let%bind lst' = bind_list @@ List.map (type_expression e) lst in @@ -796,11 +796,12 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let%bind f' = untype_expression f in let%bind arg' = untype_expression arg in return (e_application f' arg') - | E_lambda {binder;input_type;output_type;result} -> - let%bind input_type = untype_type_value input_type in - let%bind output_type = untype_type_value output_type in - let%bind result = untype_expression result in + | E_lambda {binder ; body} -> ( + let%bind io = get_t_function e.type_annotation in + let%bind (input_type , output_type) = bind_map_pair untype_type_value io in + let%bind result = untype_expression body in return (e_lambda binder (Some input_type) (Some output_type) result) + ) | E_tuple lst -> let%bind lst' = bind_list @@ List.map untype_expression lst in diff --git a/src/passes/6-transpiler/helpers.ml b/src/passes/6-transpiler/helpers.ml new file mode 100644 index 000000000..2609123eb --- /dev/null +++ b/src/passes/6-transpiler/helpers.ml @@ -0,0 +1,49 @@ +module AST = Ast_typed +module Append_tree = Tree.Append + +open Trace +open Mini_c + +let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m [] +let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m [] +let map_of_kv_list lst = + let open AST.SMap in + List.fold_left (fun prev (k, v) -> add k v prev) empty lst + +let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = + let open Append_tree in + let rec aux tv : (string * value * AST.type_value) result= + match tv with + | Leaf (k, t), v -> ok (k, v, t) + | Node {a}, D_left v -> aux (a, v) + | Node {b}, D_right v -> aux (b, v) + | _ -> fail @@ internal_assertion_failure "bad constructor path" + in + let%bind (s, v, t) = aux (tree, v) in + ok (s, v, t) + +let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result = + let open Append_tree in + let rec aux tv : ((value * AST.type_value) list) result = + match tv with + | Leaf t, v -> ok @@ [v, t] + | Node {a;b}, D_pair (va, vb) -> + let%bind a' = aux (a, va) in + let%bind b' = aux (b, vb) in + ok (a' @ b') + | _ -> fail @@ internal_assertion_failure "bad tuple path" + in + aux (tree, v) + +let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result = + let open Append_tree in + let rec aux tv : ((string * (value * AST.type_value)) list) result = + match tv with + | Leaf (s, t), v -> ok @@ [s, (v, t)] + | Node {a;b}, D_pair (va, vb) -> + let%bind a' = aux (a, va) in + let%bind b' = aux (b, vb) in + ok (a' @ b') + | _ -> fail @@ internal_assertion_failure "bad record path" + in + aux (tree, v) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 7d4db9321..ef8d562c4 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -1,4 +1,5 @@ open! Trace +open Helpers module AST = Ast_typed module Append_tree = Tree.Append @@ -6,15 +7,11 @@ open AST.Combinators open Mini_c open Combinators +let untranspile = Untranspiler.untranspile + let temp_unwrap_loc = Location.unwrap let temp_unwrap_loc_list = List.map Location.unwrap -let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m [] -let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m [] -let map_of_kv_list lst = - let open AST.SMap in - List.fold_left (fun prev (k, v) -> add k v prev) empty lst - module Errors = struct let corner_case ~loc message = let title () = "corner case" in @@ -49,53 +46,10 @@ them. please report this to the developers." in row_loc location ; ] in error ~data title content - - let not_functional_main location = - let title () = "not functional main" in - let content () = "main should be a function" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title content - - let missing_entry_point name = - let title () = "missing entry point" in - let content () = "no entry point with the given name" in - let data = [ - ("name" , fun () -> name) ; - ] in - error ~data title content - - let wrong_mini_c_value expected_type actual = - let title () = "illed typed intermediary value" in - let content () = "type of intermediary value doesn't match what was expected" in - let data = [ - ("expected_type" , fun () -> expected_type) ; - ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ; - ] in - error ~data title content - - let bad_untranspile bad_type value = - let title () = "untranspiling bad value" in - let content () = Format.asprintf "can not untranspile %s" bad_type in - let data = [ - ("bad_type" , fun () -> bad_type) ; - ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; - ] in - error ~data title content - - let unknown_untranspile unknown_type value = - let title () = "untranspiling unknown value" in - let content () = Format.asprintf "can not untranspile %s" unknown_type in - let data = [ - ("unknown_type" , fun () -> unknown_type) ; - ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; - ] in - error ~data title content end open Errors -let rec translate_type (t:AST.type_value) : type_value result = +let rec transpile_type (t:AST.type_value) : type_value result = match t.type_value' with | T_constant ("bool", []) -> ok (T_base Base_bool) | T_constant ("int", []) -> ok (T_base Base_int) @@ -108,19 +62,19 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("unit", []) -> ok (T_base Base_unit) | T_constant ("operation", []) -> ok (T_base Base_operation) | T_constant ("contract", [x]) -> - let%bind x' = translate_type x in + let%bind x' = transpile_type x in ok (T_contract x') | T_constant ("map", [key;value]) -> - let%bind kv' = bind_map_pair translate_type (key, value) in + let%bind kv' = bind_map_pair transpile_type (key, value) in ok (T_map kv') | T_constant ("list", [t]) -> - let%bind t' = translate_type t in + let%bind t' = transpile_type t in ok (T_list t') | T_constant ("set", [t]) -> - let%bind t' = translate_type t in + let%bind t' = transpile_type t in ok (T_set t') | T_constant ("option", [o]) -> - let%bind o' = translate_type o in + let%bind o' = transpile_type o in ok (T_option o') | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name | T_sum m -> @@ -130,7 +84,7 @@ let rec translate_type (t:AST.type_value) : type_value result = let%bind b = b in ok (T_or (a, b)) in - Append_tree.fold_ne translate_type aux node + Append_tree.fold_ne transpile_type aux node | T_record m -> let node = Append_tree.of_list @@ list_of_map m in let aux a b : type_value result = @@ -138,7 +92,7 @@ let rec translate_type (t:AST.type_value) : type_value result = let%bind b = b in ok (T_pair (a, b)) in - Append_tree.fold_ne translate_type aux node + Append_tree.fold_ne transpile_type aux node | T_tuple lst -> let node = Append_tree.of_list lst in let aux a b : type_value result = @@ -146,10 +100,10 @@ let rec translate_type (t:AST.type_value) : type_value result = let%bind b = b in ok (T_pair (a, b)) in - Append_tree.fold_ne translate_type aux node + Append_tree.fold_ne transpile_type aux node | T_function (param, result) -> ( - let%bind param' = translate_type param in - let%bind result' = translate_type result in + let%bind param' = transpile_type param in + let%bind result' = transpile_type result in ok (T_function (param', result')) ) @@ -191,7 +145,7 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - bind_fold_list aux (ty , []) lr_path in ok lst -let rec translate_literal : AST.literal -> value = fun l -> match l with +let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_bool b -> D_bool b | Literal_int n -> D_int n | Literal_nat n -> D_nat n @@ -206,12 +160,12 @@ let rec translate_literal : AST.literal -> value = fun l -> match l with and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele -> match (AST.get_type' ele.type_value , ele.definition) with | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> - let%bind f' = translate_type f in - let%bind arg' = translate_type arg in + let%bind f' = transpile_type f in + let%bind arg' = transpile_type arg in let%bind env' = transpile_environment ae.environment in let sub_env = Mini_c.Environment.select captured_variables env' in ok @@ Combinators.t_deep_closure sub_env f' arg' - | _ -> translate_type ele.type_value + | _ -> transpile_type ele.type_value and transpile_small_environment : AST.small_environment -> Environment.t result = fun x -> let x' = AST.Environment.Small.get_environment x in @@ -231,10 +185,10 @@ and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t r let%bind map_tv = get_t_sum t in ok @@ Append_tree.of_list @@ kv_list_of_map map_tv -and translate_annotated_expression (ae:AST.annotated_expression) : expression result = - let%bind tv = translate_type ae.type_annotation in +and transpile_annotated_expression (ae:AST.annotated_expression) : expression result = + let%bind tv = transpile_type ae.type_annotation in let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in - let f = translate_annotated_expression in + let f = transpile_annotated_expression in let info = let title () = "translating expression" in let content () = Format.asprintf "%a" Location.pp ae.location in @@ -242,14 +196,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re trace info @@ match ae.expression with | E_let_in {binder; rhs; result} -> - let%bind rhs' = translate_annotated_expression rhs in - let%bind result' = translate_annotated_expression result in + let%bind rhs' = transpile_annotated_expression rhs in + let%bind result' = transpile_annotated_expression result in return (E_let_in ((binder, rhs'.type_value), rhs', result')) | E_failwith ae -> ( - let%bind ae' = translate_annotated_expression ae in + let%bind ae' = transpile_annotated_expression ae in return @@ E_constant ("FAILWITH" , [ae']) ) - | E_literal l -> return @@ E_literal (translate_literal l) + | E_literal l -> return @@ E_literal (transpile_literal l) | E_variable name -> ( let%bind ele = trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ @@ -258,11 +212,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re return ~tv @@ E_variable name ) | E_application (a, b) -> - let%bind a = translate_annotated_expression a in - let%bind b = translate_annotated_expression b in + let%bind a = transpile_annotated_expression a in + let%bind b = transpile_annotated_expression b in return @@ E_application (a, b) | E_constructor (m, param) -> ( - let%bind param' = translate_annotated_expression param in + let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in let%bind node_tv = trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@ @@ -274,7 +228,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re @@ AST.assert_type_value_eq (tv, param.type_annotation) in ok (Some (param'_expr), param'_tv) ) else ( - let%bind tv = translate_type tv in + let%bind tv = transpile_type tv in ok (None, tv) ) in let node a b : (expression' option * type_value) result = @@ -302,14 +256,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let tv = T_pair (a_ty , b_ty) in return ~tv @@ E_constant ("PAIR", [a; b]) in - Append_tree.fold_ne (translate_annotated_expression) aux node + Append_tree.fold_ne (transpile_annotated_expression) aux node ) | E_tuple_accessor (tpl, ind) -> ( - let%bind ty' = translate_type tpl.type_annotation in + let%bind ty' = transpile_type tpl.type_annotation in let%bind ty_lst = trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@ get_t_tuple tpl.type_annotation in - let%bind ty'_lst = bind_map_list translate_type ty_lst in + let%bind ty'_lst = bind_map_list transpile_type ty_lst in let%bind path = trace_strong (corner_case ~loc:__LOC__ "tuple access") @@ tuple_access_to_lr ty' ty'_lst ind in @@ -318,7 +272,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | `Left -> "CAR" | `Right -> "CDR" in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in - let%bind tpl' = translate_annotated_expression tpl in + let%bind tpl' = transpile_annotated_expression tpl in let expr = List.fold_left aux tpl' path in ok expr ) @@ -333,14 +287,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re return ~tv @@ E_constant ("PAIR", [a; b]) in trace_strong (corner_case ~loc:__LOC__ "record build") @@ - Append_tree.fold_ne (translate_annotated_expression) aux node + Append_tree.fold_ne (transpile_annotated_expression) aux node ) | E_record_accessor (record, property) -> - let%bind ty' = translate_type (get_type_annotation record) in + let%bind ty' = transpile_type (get_type_annotation record) in let%bind ty_smap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ get_t_record (get_type_annotation record) in - let%bind ty'_smap = bind_map_smap translate_type ty_smap in + let%bind ty'_smap = bind_map_smap transpile_type ty_smap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ record_access_to_lr ty' ty'_smap property in @@ -349,7 +303,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | `Left -> "CAR" | `Right -> "CDR" in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in - let%bind record' = translate_annotated_expression record in + let%bind record' = transpile_annotated_expression record in let expr = List.fold_left aux record' path in ok expr | E_constant (name , lst) -> ( @@ -358,8 +312,9 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | [i ; f] -> ( let%bind f' = match f.expression with | E_lambda l -> ( - let%bind body' = translate_annotated_expression l.result in - let%bind input' = translate_type l.input_type in + let%bind body' = transpile_annotated_expression l.body in + let%bind (input , _) = get_t_function f.type_annotation in + let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) | E_variable v -> ( @@ -370,8 +325,9 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | ED_declaration (f , _) -> ( match f.expression with | E_lambda l -> ( - let%bind body' = translate_annotated_expression l.result in - let%bind input' = translate_type l.input_type in + let%bind body' = transpile_annotated_expression l.body in + let%bind (input , _) = get_t_function f.type_annotation in + let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) | _ -> fail @@ unsupported_iterator f.location @@ -380,7 +336,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re ) | _ -> fail @@ unsupported_iterator f.location in - let%bind i' = translate_annotated_expression i in + let%bind i' = transpile_annotated_expression i in return @@ E_iterator (name , f' , i') ) | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity" @@ -393,7 +349,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | ("LIST_MAP" , lst) -> map lst | ("MAP_MAP" , lst) -> map lst | _ -> ( - let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let%bind lst' = bind_map_list (transpile_annotated_expression) lst in return @@ E_constant (name , lst') ) ) @@ -401,12 +357,13 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind env = trace_strong (corner_case ~loc:__LOC__ "environment") @@ transpile_environment ae.environment in - translate_lambda env l + let%bind io = get_t_function ae.type_annotation in + transpile_lambda env l io | E_list lst -> ( let%bind t = trace_strong (corner_case ~loc:__LOC__ "not a list") @@ Mini_c.Combinators.get_t_list tv in - let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let aux : expression -> expression -> expression result = fun prev cur -> return @@ E_constant ("CONS", [cur ; prev]) in let%bind (init : expression) = return @@ E_make_empty_list t in @@ -416,7 +373,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind t = trace_strong (corner_case ~loc:__LOC__ "not a set") @@ Mini_c.Combinators.get_t_set tv in - let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let aux : expression -> expression -> expression result = fun prev cur -> return @@ E_constant ("SET_ADD", [cur ; prev]) in let%bind (init : expression) = return @@ E_make_empty_set t in @@ -430,7 +387,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind prev' = prev in let%bind (k', v') = let v' = e_a_some v ae.environment in - bind_map_pair (translate_annotated_expression) (k , v') in + bind_map_pair (transpile_annotated_expression) (k , v') in return @@ E_constant ("UPDATE", [k' ; v' ; prev']) in let init = return @@ E_make_empty_map (src, dst) in @@ -441,26 +398,26 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re return @@ E_constant ("MAP_GET", [i' ; ds']) ) | E_sequence (a , b) -> ( - let%bind a' = translate_annotated_expression a in - let%bind b' = translate_annotated_expression b in + let%bind a' = transpile_annotated_expression a in + let%bind b' = transpile_annotated_expression b in return @@ E_sequence (a' , b') ) | E_loop (expr , body) -> ( - let%bind expr' = translate_annotated_expression expr in - let%bind body' = translate_annotated_expression body in + let%bind expr' = transpile_annotated_expression expr in + let%bind body' = transpile_annotated_expression body in return @@ E_while (expr' , body') ) | E_assign (typed_name , path , expr) -> ( let ty = typed_name.type_value in let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result = fun (prev, acc) cur -> - let%bind ty' = translate_type prev in + let%bind ty' = transpile_type prev in match cur with | Access_tuple ind -> ( let%bind ty_lst = trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@ AST.Combinators.get_t_tuple prev in - let%bind ty'_lst = bind_map_list translate_type ty_lst in + let%bind ty'_lst = bind_map_list transpile_type ty_lst in let%bind path = tuple_access_to_lr ty' ty'_lst ind in let path' = List.map snd path in ok (List.nth ty_lst ind, acc @ path') @@ -469,7 +426,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind ty_map = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ AST.Combinators.get_t_record prev in - let%bind ty'_map = bind_map_smap translate_type ty_map in + let%bind ty'_map = bind_map_smap transpile_type ty_map in let%bind path = record_access_to_lr ty' ty'_map prop in let path' = List.map snd path in ok (Map.String.find prop ty_map, acc @ path') @@ -477,20 +434,20 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet") in let%bind (_, path) = bind_fold_right_list aux (ty, []) path in - let%bind expr' = translate_annotated_expression expr in + let%bind expr' = transpile_annotated_expression expr in return (E_assignment (typed_name.type_name, path, expr')) ) | E_matching (expr, m) -> ( - let%bind expr' = translate_annotated_expression expr in + let%bind expr' = transpile_annotated_expression expr in match m with | Match_bool {match_true ; match_false} -> - let%bind (t , f) = bind_map_pair (translate_annotated_expression) (match_true, match_false) in + let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in return @@ E_if_bool (expr', t, f) | Match_option { match_none; match_some = ((name, tv), s) } -> - let%bind n = translate_annotated_expression match_none in + let%bind n = transpile_annotated_expression match_none in let%bind (tv' , s') = - let%bind tv' = translate_type tv in - let%bind s' = translate_annotated_expression s in + let%bind tv' = transpile_type tv in + let%bind s' = transpile_annotated_expression s in ok (tv' , s') in return @@ E_if_none (expr' , n , ((name , tv') , s')) | Match_variant (lst , variant) -> ( @@ -504,7 +461,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let rec aux t = match (t : _ Append_tree.t') with | Leaf (name , tv) -> - let%bind tv' = translate_type tv in + let%bind tv' = transpile_type tv in ok (`Leaf name , tv') | Node {a ; b} -> let%bind a' = aux a in @@ -520,7 +477,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind ((_ , name) , body) = trace_option (corner_case ~loc:__LOC__ "missing match clause") @@ List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in - let%bind body' = translate_annotated_expression body in + let%bind body' = transpile_annotated_expression body in return @@ E_let_in ((name , tv) , top , body') ) | ((`Node (a , b)) , tv) -> @@ -545,284 +502,54 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location ) -and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l -> - let { binder ; input_type ; output_type ; result } : AST.lambda = l in +and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.expression result = + fun env l (input_type , output_type)-> + let { binder ; body } : AST.lambda = l in (* Deep capture. Capture the relevant part of the environment. *) let%bind c_env = let free_variables = Ast_typed.Free_variables.lambda [] l in let sub_env = Mini_c.Environment.select free_variables env in ok sub_env in let%bind (f_expr' , input_tv , output_tv) = - let%bind raw_input = translate_type input_type in - let%bind output = translate_type output_type in - let%bind result = translate_annotated_expression result in + let%bind raw_input = transpile_type input_type in + let%bind output = transpile_type output_type in + let%bind result = transpile_annotated_expression body in let expr' = E_closure { binder ; result } in ok (expr' , raw_input , output) in let tv = Mini_c.t_deep_closure c_env input_tv output_tv in ok @@ Expression.make_tpl (f_expr' , tv) -and translate_lambda env l = - let { binder ; input_type ; output_type ; result } : AST.lambda = l in - (* Try to translate it in an empty env, if it succeeds, transpiles it as a quote value, else, as a closure expression. *) - let fvs = AST.Free_variables.(annotated_expression (singleton binder) result) in +and transpile_lambda env l (input_type , output_type) = + let { binder ; body } : AST.lambda = l in + let fvs = AST.Free_variables.(annotated_expression (singleton binder) body) in let%bind result = match fvs with | [] -> ( - let%bind result' = translate_annotated_expression result in - let result' = ez_e_return result' in - let%bind input = translate_type input_type in - let%bind output = translate_type output_type in + let%bind result' = transpile_annotated_expression body in + let%bind input = transpile_type input_type in + let%bind output = transpile_type output_type in let tv = Combinators.t_function input output in - let content = D_function {binder;result=result'} in + let content = D_function { binder ; result = result'} in ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( - translate_lambda_deep env l + transpile_lambda_deep env l (input_type , output_type) ) in ok result -let translate_declaration env (d:AST.declaration) : toplevel_statement result = +let transpile_declaration env (d:AST.declaration) : toplevel_statement result = match d with | Declaration_constant ({name;annotated_expression} , _) -> - let%bind expression = translate_annotated_expression annotated_expression in + let%bind expression = transpile_annotated_expression annotated_expression in let tv = Combinators.Expression.get_type expression in let env' = Environment.add (name, tv) env in ok @@ ((name, expression), environment_wrap env env') -let translate_program (lst:AST.program) : program result = +let transpile_program (lst:AST.program) : program result = let aux (prev:(toplevel_statement list * Environment.t) result) cur = let%bind (tl, env) = prev in - let%bind ((_, env') as cur') = translate_declaration env cur in + let%bind ((_, env') as cur') = transpile_declaration env cur in ok (cur' :: tl, env'.post_environment) in let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements - -let translate_main (l:AST.lambda) loc : (anon_function * _) result = - let%bind expr = translate_lambda Environment.empty l in - match expr.content , expr.type_value with - | E_literal (D_function f) , T_function ty -> ok (f , ty) - | _ -> fail @@ not_functional_main loc - -(* From an expression [expr], build the expression [fun () -> expr] *) -let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = - let t = e.type_annotation in - let open! AST in - { - binder = "_" ; - input_type = Combinators.t_unit () ; - output_type = t ; - result = e ; - }, Combinators.(t_function (t_unit ()) t ()) - -let translate_entry (lst:AST.program) (name:string) : (anon_function * _) result = - let rec aux acc (lst:AST.program) = - let%bind acc = acc in - match lst with - | [] -> fail @@ missing_entry_point name - | hd :: tl -> ( - let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in - match an.name = name with - | false -> ( - let next = fun expr -> - let cur = e_a_let_in an.name an.annotated_expression expr pre_env in - acc cur in - aux (ok next) tl - ) - | true -> ( - match an.annotated_expression.expression with - | E_lambda l -> - let l' = { l with result = acc l.result } in - translate_main l' an.annotated_expression.location - | _ -> - let (l , _) = functionalize an.annotated_expression in - let l' = { l with result = acc l.result } in - translate_main l' an.annotated_expression.location - ) - ) - in - let%bind l = aux (ok (fun x -> x)) lst in - ok l - -open Combinators - -let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = - let open Append_tree in - let rec aux tv : (string * value * AST.type_value) result= - match tv with - | Leaf (k, t), v -> ok (k, v, t) - | Node {a}, D_left v -> aux (a, v) - | Node {b}, D_right v -> aux (b, v) - | _ -> fail @@ internal_assertion_failure "bad constructor path" - in - let%bind (s, v, t) = aux (tree, v) in - ok (s, v, t) - -let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result = - let open Append_tree in - let rec aux tv : ((value * AST.type_value) list) result = - match tv with - | Leaf t, v -> ok @@ [v, t] - | Node {a;b}, D_pair (va, vb) -> - let%bind a' = aux (a, va) in - let%bind b' = aux (b, vb) in - ok (a' @ b') - | _ -> fail @@ internal_assertion_failure "bad tuple path" - in - aux (tree, v) - -let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result = - let open Append_tree in - let rec aux tv : ((string * (value * AST.type_value)) list) result = - match tv with - | Leaf (s, t), v -> ok @@ [s, (v, t)] - | Node {a;b}, D_pair (va, vb) -> - let%bind a' = aux (a, va) in - let%bind b' = aux (b, vb) in - ok (a' @ b') - | _ -> fail @@ internal_assertion_failure "bad record path" - in - aux (tree, v) - -let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result = - let open! AST in - let return e = ok (make_a_e_empty e t) in - match t.type_value' with - | T_constant ("unit", []) -> ( - let%bind () = - trace_strong (wrong_mini_c_value "unit" v) @@ - get_unit v in - return (E_literal Literal_unit) - ) - | T_constant ("bool", []) -> ( - let%bind b = - trace_strong (wrong_mini_c_value "bool" v) @@ - get_bool v in - return (E_literal (Literal_bool b)) - ) - | T_constant ("int", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "int" v) @@ - get_int v in - return (E_literal (Literal_int n)) - ) - | T_constant ("nat", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "nat" v) @@ - get_nat v in - return (E_literal (Literal_nat n)) - ) - | T_constant ("timestamp", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "timestamp" v) @@ - get_timestamp v in - return (E_literal (Literal_timestamp n)) - ) - | T_constant ("tez", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "tez" v) @@ - get_nat v in - return (E_literal (Literal_tez n)) - ) - | T_constant ("string", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "string" v) @@ - get_string v in - return (E_literal (Literal_string n)) - ) - | T_constant ("bytes", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "bytes" v) @@ - get_bytes v in - return (E_literal (Literal_bytes n)) - ) - | T_constant ("address", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "address" v) @@ - get_string v in - return (E_literal (Literal_address n)) - ) - | T_constant ("option", [o]) -> ( - let%bind opt = - trace_strong (wrong_mini_c_value "option" v) @@ - get_option v in - match opt with - | None -> ok (e_a_empty_none o) - | Some s -> - let%bind s' = untranspile s o in - ok (e_a_empty_some s') - ) - | T_constant ("map", [k_ty;v_ty]) -> ( - let%bind lst = - trace_strong (wrong_mini_c_value "map" v) @@ - get_map v in - let%bind lst' = - let aux = fun (k, v) -> - let%bind k' = untranspile k k_ty in - let%bind v' = untranspile v v_ty in - ok (k', v') in - bind_map_list aux lst in - return (E_map lst') - ) - | T_constant ("list", [ty]) -> ( - let%bind lst = - trace_strong (wrong_mini_c_value "list" v) @@ - get_list v in - let%bind lst' = - let aux = fun e -> untranspile e ty in - bind_map_list aux lst in - return (E_list lst') - ) - | T_constant ("set", [ty]) -> ( - let%bind lst = - trace_strong (wrong_mini_c_value "set" v) @@ - get_set v in - let%bind lst' = - let aux = fun e -> untranspile e ty in - bind_map_list aux lst in - return (E_set lst') - ) - | T_constant ("contract" , [_ty]) -> - fail @@ bad_untranspile "contract" v - | T_constant ("operation" , []) -> ( - let%bind op = - trace_strong (wrong_mini_c_value "operation" v) @@ - get_operation v in - return (E_literal (Literal_operation op)) - ) - | T_constant (name , _lst) -> - fail @@ unknown_untranspile name v - | T_sum m -> - let lst = kv_list_of_map m in - let%bind node = match Append_tree.of_list lst with - | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type" - | Full t -> ok t - in - let%bind (name, v, tv) = - trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@ - extract_constructor v node in - let%bind sub = untranspile v tv in - return (E_constructor (name, sub)) - | T_tuple lst -> - let%bind node = match Append_tree.of_list lst with - | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple" - | Full t -> ok t in - let%bind tpl = - trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@ - extract_tuple v node in - let%bind tpl' = bind_list - @@ List.map (fun (x, y) -> untranspile x y) tpl in - return (E_tuple tpl') - | T_record m -> - let lst = kv_list_of_map m in - let%bind node = match Append_tree.of_list lst with - | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" - | Full t -> ok t in - let%bind lst = - trace_strong (corner_case ~loc:__LOC__ "record extract") @@ - extract_record v node in - let%bind lst = bind_list - @@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in - let m' = map_of_kv_list lst in - return (E_record m') - | T_function _ -> fail @@ bad_untranspile "function" v diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml new file mode 100644 index 000000000..d79e842b4 --- /dev/null +++ b/src/passes/6-transpiler/untranspiler.ml @@ -0,0 +1,193 @@ +open Helpers + +module AST = Ast_typed +module Append_tree = Tree.Append +open Mini_c +open Trace + +module Errors = struct + + let corner_case ~loc message = + let title () = "corner case" in + let content () = "we don't have a good error message for this case. we are +striving find ways to better report them and find the use-cases that generate +them. please report this to the developers." in + let data = [ + ("location" , fun () -> loc) ; + ("message" , fun () -> message) ; + ] in + error ~data title content + + let wrong_mini_c_value expected_type actual = + let title () = "illed typed intermediary value" in + let content () = "type of intermediary value doesn't match what was expected" in + let data = [ + ("expected_type" , fun () -> expected_type) ; + ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ; + ] in + error ~data title content + + let bad_untranspile bad_type value = + let title () = "untranspiling bad value" in + let content () = Format.asprintf "can not untranspile %s" bad_type in + let data = [ + ("bad_type" , fun () -> bad_type) ; + ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; + ] in + error ~data title content + + let unknown_untranspile unknown_type value = + let title () = "untranspiling unknown value" in + let content () = Format.asprintf "can not untranspile %s" unknown_type in + let data = [ + ("unknown_type" , fun () -> unknown_type) ; + ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; + ] in + error ~data title content + +end + +open Errors + +let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result = + let open! AST in + let return e = ok (make_a_e_empty e t) in + match t.type_value' with + | T_constant ("unit", []) -> ( + let%bind () = + trace_strong (wrong_mini_c_value "unit" v) @@ + get_unit v in + return (E_literal Literal_unit) + ) + | T_constant ("bool", []) -> ( + let%bind b = + trace_strong (wrong_mini_c_value "bool" v) @@ + get_bool v in + return (E_literal (Literal_bool b)) + ) + | T_constant ("int", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "int" v) @@ + get_int v in + return (E_literal (Literal_int n)) + ) + | T_constant ("nat", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "nat" v) @@ + get_nat v in + return (E_literal (Literal_nat n)) + ) + | T_constant ("timestamp", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "timestamp" v) @@ + get_timestamp v in + return (E_literal (Literal_timestamp n)) + ) + | T_constant ("tez", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "tez" v) @@ + get_nat v in + return (E_literal (Literal_tez n)) + ) + | T_constant ("string", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "string" v) @@ + get_string v in + return (E_literal (Literal_string n)) + ) + | T_constant ("bytes", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "bytes" v) @@ + get_bytes v in + return (E_literal (Literal_bytes n)) + ) + | T_constant ("address", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "address" v) @@ + get_string v in + return (E_literal (Literal_address n)) + ) + | T_constant ("option", [o]) -> ( + let%bind opt = + trace_strong (wrong_mini_c_value "option" v) @@ + get_option v in + match opt with + | None -> ok (e_a_empty_none o) + | Some s -> + let%bind s' = untranspile s o in + ok (e_a_empty_some s') + ) + | T_constant ("map", [k_ty;v_ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "map" v) @@ + get_map v in + let%bind lst' = + let aux = fun (k, v) -> + let%bind k' = untranspile k k_ty in + let%bind v' = untranspile v v_ty in + ok (k', v') in + bind_map_list aux lst in + return (E_map lst') + ) + | T_constant ("list", [ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "list" v) @@ + get_list v in + let%bind lst' = + let aux = fun e -> untranspile e ty in + bind_map_list aux lst in + return (E_list lst') + ) + | T_constant ("set", [ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "set" v) @@ + get_set v in + let%bind lst' = + let aux = fun e -> untranspile e ty in + bind_map_list aux lst in + return (E_set lst') + ) + | T_constant ("contract" , [_ty]) -> + fail @@ bad_untranspile "contract" v + | T_constant ("operation" , []) -> ( + let%bind op = + trace_strong (wrong_mini_c_value "operation" v) @@ + get_operation v in + return (E_literal (Literal_operation op)) + ) + | T_constant (name , _lst) -> + fail @@ unknown_untranspile name v + | T_sum m -> + let lst = kv_list_of_map m in + let%bind node = match Append_tree.of_list lst with + | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type" + | Full t -> ok t + in + let%bind (name, v, tv) = + trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@ + extract_constructor v node in + let%bind sub = untranspile v tv in + return (E_constructor (name, sub)) + | T_tuple lst -> + let%bind node = match Append_tree.of_list lst with + | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple" + | Full t -> ok t in + let%bind tpl = + trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@ + extract_tuple v node in + let%bind tpl' = bind_list + @@ List.map (fun (x, y) -> untranspile x y) tpl in + return (E_tuple tpl') + | T_record m -> + let lst = kv_list_of_map m in + let%bind node = match Append_tree.of_list lst with + | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" + | Full t -> ok t in + let%bind lst = + trace_strong (corner_case ~loc:__LOC__ "record extract") @@ + extract_record v node in + let%bind lst = bind_list + @@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in + let m' = map_of_kv_list lst in + return (E_record m') + | T_function _ -> fail @@ bad_untranspile "function" v diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 789000391..a06fc2a6e 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -1,14 +1,11 @@ open Trace open Mini_c - open Michelson - open Memory_proto_alpha.Protocol.Script_ir_translator - open Operators.Compiler -let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst -> - match Map.String.find_opt s Operators.Compiler.predicates with +let get_operator : string -> type_value -> expression list -> predicate result = fun s ty lst -> + match Map.String.find_opt s Operators.Compiler.operators with | Some x -> ok x | None -> ( match s with @@ -196,7 +193,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result PP.environment env ; ok (seq [ expr_code ; dip code ]) in bind_fold_right_list aux (seq []) lst in - let%bind predicate = get_predicate str ty lst in + let%bind predicate = get_operator str ty lst in let%bind code = match (predicate, List.length lst) with | Constant c, 0 -> ok @@ seq [ pre_code ; diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index cdf983b6a..23c6aaf44 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -639,7 +639,7 @@ module Compiler = struct include Helpers.Compiler open Tezos_utils.Michelson - let predicates = Map.String.of_list [ + let operators = Map.String.of_list [ ("ADD" , simple_binary @@ prim I_ADD) ; ("SUB" , simple_binary @@ prim I_SUB) ; ("TIMES" , simple_binary @@ prim I_MUL) ; @@ -693,6 +693,9 @@ module Compiler = struct ("CONCAT" , simple_binary @@ prim I_CONCAT) ; ] - (* Some complex predicates will need to be added in compiler/compiler_program *) + (* + Some complex operators will need to be added in compiler/compiler_program. + All operators whose compilations involve a type are found there. + *) end diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 3e8edf30c..514a091df 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -24,10 +24,9 @@ let rec annotated_expression ppf (ae:annotated_expression) : unit = | _ -> fprintf ppf "@[%a@]" expression ae.expression and lambda ppf l = - let {binder;input_type;output_type;result} = l in - fprintf ppf "lambda (%s:%a) : %a return %a" - binder type_value input_type type_value output_type - annotated_expression result + let ({ binder ; body } : lambda) = l in + fprintf ppf "lambda (%s) -> %a" + binder annotated_expression body and expression ppf (e:expression) : unit = match e with diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index ec745fabc..6b2358c28 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -56,6 +56,10 @@ let get_type' (x:type_value) = x.type_value' let get_environment (x:annotated_expression) = x.environment let get_expression (x:annotated_expression) = x.expression +let get_lambda e : _ result = match e with + | E_lambda l -> ok l + | _ -> simple_fail "not a lambda" + let get_t_bool (t:type_value) : unit result = match t.type_value' with | T_constant ("bool", []) -> ok () | _ -> simple_fail "not a bool" @@ -235,7 +239,7 @@ let e_a_string s = make_a_e (e_string s) (t_string ()) let e_a_address s = make_a_e (e_address s) (t_address ()) let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ()) let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ()) -let e_a_lambda l = make_a_e (e_lambda l) (t_function l.input_type l.output_type ()) +let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ()) let e_a_none t = make_a_e e_none (t_option t ()) let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ()) let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ()) diff --git a/src/stages/ast_typed/combinators_environment.ml b/src/stages/ast_typed/combinators_environment.ml index e8ca37530..4c41f7296 100644 --- a/src/stages/ast_typed/combinators_environment.ml +++ b/src/stages/ast_typed/combinators_environment.ml @@ -18,7 +18,7 @@ let e_a_empty_record r = e_a_record r Environment.full_empty let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty let e_a_empty_list lst t = e_a_list lst t Environment.full_empty let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty -let e_a_empty_lambda l = e_a_lambda l Environment.full_empty +let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty open Environment diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 091531789..a71ff3fae 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -171,7 +171,7 @@ module Free_variables = struct and lambda : bindings -> lambda -> bindings = fun b l -> let b' = union (singleton l.binder) b in - annotated_expression b' l.result + annotated_expression b' l.body and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae -> expression b ae.expression diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index 0d0e8cd02..9e9520e3d 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -4,7 +4,7 @@ open Combinators open Misc let program_to_main : program -> string -> lambda result = fun p s -> - let%bind (main , input_type , output_type) = + let%bind (main , input_type , _) = let pred = fun d -> match d with | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression @@ -25,15 +25,13 @@ let program_to_main : program -> string -> lambda result = fun p s -> | Declaration_constant (_ , (_ , post_env)) -> post_env in List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in let binder = "@contract_input" in - let result = + let body = let input_expr = e_a_variable binder input_type env in let main_expr = e_a_variable s (get_type_annotation main) env in e_a_application main_expr input_expr env in ok { binder ; - input_type ; - output_type ; - result ; + body ; } module Captured_variables = struct diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index cf8c40fec..6fe7f921e 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -69,10 +69,10 @@ and named_type_value = { } and lambda = { - binder: name ; - input_type: tv ; - output_type: tv ; - result: ae ; + binder : name ; + (* input_type: tv ; + * output_type: tv ; *) + body : ae ; } and let_in = { diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index f7342987e..9e8467207 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -164,12 +164,10 @@ let e_let_int v tv expr body : expression = Expression.(make_tpl ( let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl (a , t_unit) , b) , get_type b)) -let ez_e_return e : expression = e - let d_unit : value = D_unit let basic_quote expr : anon_function result = - ok @@ quote "input" (ez_e_return expr) + ok @@ quote "input" expr let basic_int_quote expr : anon_function result = basic_quote expr From d8b7a12c690d7cea4bd0ae7a808b3e6bb555c06f Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 15 Sep 2019 13:12:19 +0200 Subject: [PATCH 06/53] more refactoring --- src/bin/cli_helpers.ml | 2 +- src/main/compile/of_mini_c.ml | 3 + src/main/compile/of_simplified.ml | 21 +- src/main/compile/of_source.ml | 35 +++ src/main/compile/of_typed.ml | 98 ++++++--- src/main/{run => }/display.ml | 0 src/main/run/dune | 1 + src/main/run/main.ml | 137 ------------ .../{from_michelson.ml => of_michelson.ml} | 0 src/main/run/{run_mini_c.ml => of_mini_c.ml} | 6 +- src/main/run/of_simplified.ml | 31 +++ src/main/run/of_source.ml | 92 ++++++++ src/main/run/of_typed.ml | 34 +++ src/main/run/run.ml | 4 + src/main/run/run_simplified.ml | 27 --- src/main/run/run_source.ml | 207 ------------------ src/main/run/run_typed.ml | 71 ------ {test => src/test}/.gitignore | 0 {test => src/test}/bin_tests.ml | 0 {test => src/test}/coase_tests.ml | 0 {test => src/test}/compiler_tests.ml | 0 {test => src/test}/contracts/amount.mligo | 0 {test => src/test}/contracts/annotation.ligo | 0 {test => src/test}/contracts/arithmetic.ligo | 0 {test => src/test}/contracts/assign.ligo | 0 {test => src/test}/contracts/basic.mligo | 0 .../test}/contracts/bitwise_arithmetic.ligo | 0 .../test}/contracts/boolean_operators.ligo | 0 .../test}/contracts/bytes_arithmetic.ligo | 0 {test => src/test}/contracts/closure-1.ligo | 0 {test => src/test}/contracts/closure-2.ligo | 0 {test => src/test}/contracts/closure-3.ligo | 0 {test => src/test}/contracts/closure.ligo | 0 {test => src/test}/contracts/coase.ligo | 0 .../test}/contracts/condition-simple.ligo | 0 {test => src/test}/contracts/condition.ligo | 0 {test => src/test}/contracts/counter.ligo | 0 {test => src/test}/contracts/counter.mligo | 0 .../test}/contracts/declaration-local.ligo | 0 .../test}/contracts/declarations.ligo | 0 .../test}/contracts/dispatch-counter.ligo | 0 .../test}/contracts/error_syntax.ligo | 0 {test => src/test}/contracts/error_type.ligo | 0 {test => src/test}/contracts/failwith.mligo | 0 .../test}/contracts/function-complex.ligo | 0 .../test}/contracts/function-shared.ligo | 0 {test => src/test}/contracts/function.ligo | 0 .../test}/contracts/guess_string.mligo | 0 .../test}/contracts/heap-instance.ligo | 0 {test => src/test}/contracts/heap.ligo | 0 {test => src/test}/contracts/high-order.ligo | 0 {test => src/test}/contracts/included.ligo | 0 {test => src/test}/contracts/includer.ligo | 0 {test => src/test}/contracts/lambda.ligo | 0 {test => src/test}/contracts/lambda.mligo | 0 {test => src/test}/contracts/lambda2.mligo | 0 {test => src/test}/contracts/letin.mligo | 0 {test => src/test}/contracts/list.ligo | 0 {test => src/test}/contracts/list.mligo | 0 {test => src/test}/contracts/loop.ligo | 0 {test => src/test}/contracts/map.ligo | 0 {test => src/test}/contracts/match.ligo | 0 {test => src/test}/contracts/match.mligo | 0 {test => src/test}/contracts/match_bis.mligo | 0 .../test}/contracts/multiple-parameters.ligo | 0 {test => src/test}/contracts/new-syntax.mligo | 0 {test => src/test}/contracts/option.ligo | 0 .../contracts/parser-bad-reported-term.ligo | 0 .../test}/contracts/quote-declaration.ligo | 0 .../test}/contracts/quote-declarations.ligo | 0 {test => src/test}/contracts/record.ligo | 0 {test => src/test}/contracts/record.mligo | 0 .../test}/contracts/set_arithmetic-1.ligo | 0 .../test}/contracts/set_arithmetic.ligo | 0 {test => src/test}/contracts/shadow.ligo | 0 {test => src/test}/contracts/string.ligo | 0 .../test}/contracts/string_arithmetic.ligo | 0 .../test}/contracts/super-counter.ligo | 0 .../test}/contracts/super-counter.mligo | 0 {test => src/test}/contracts/toto.ligo | 0 {test => src/test}/contracts/tuple.ligo | 0 {test => src/test}/contracts/type-alias.ligo | 0 {test => src/test}/contracts/unit.ligo | 0 .../test}/contracts/variant-matching.ligo | 0 {test => src/test}/contracts/variant.ligo | 0 {test => src/test}/contracts/vote.mligo | 0 {test => src/test}/contracts/website1.ligo | 0 {test => src/test}/contracts/website2.ligo | 0 {test => src/test}/dune | 0 {test => src/test}/heap_tests.ml | 0 {test => src/test}/integration_tests.ml | 0 {test => src/test}/manual_test.ml | 0 {test => src/test}/multifix_tests.ml | 0 {test => src/test}/test.ml | 0 {test => src/test}/test_helpers.ml | 0 {test => src/test}/transpiler_tests.ml | 0 {test => src/test}/typer_tests.ml | 0 {test => src/test}/vote_tests.ml | 0 98 files changed, 288 insertions(+), 481 deletions(-) rename src/main/{run => }/display.ml (100%) delete mode 100644 src/main/run/main.ml rename src/main/run/{from_michelson.ml => of_michelson.ml} (100%) rename src/main/run/{run_mini_c.ml => of_mini_c.ml} (86%) create mode 100644 src/main/run/of_simplified.ml create mode 100644 src/main/run/of_source.ml create mode 100644 src/main/run/of_typed.ml create mode 100644 src/main/run/run.ml delete mode 100644 src/main/run/run_simplified.ml delete mode 100644 src/main/run/run_source.ml delete mode 100644 src/main/run/run_typed.ml rename {test => src/test}/.gitignore (100%) rename {test => src/test}/bin_tests.ml (100%) rename {test => src/test}/coase_tests.ml (100%) rename {test => src/test}/compiler_tests.ml (100%) rename {test => src/test}/contracts/amount.mligo (100%) rename {test => src/test}/contracts/annotation.ligo (100%) rename {test => src/test}/contracts/arithmetic.ligo (100%) rename {test => src/test}/contracts/assign.ligo (100%) rename {test => src/test}/contracts/basic.mligo (100%) rename {test => src/test}/contracts/bitwise_arithmetic.ligo (100%) rename {test => src/test}/contracts/boolean_operators.ligo (100%) rename {test => src/test}/contracts/bytes_arithmetic.ligo (100%) rename {test => src/test}/contracts/closure-1.ligo (100%) rename {test => src/test}/contracts/closure-2.ligo (100%) rename {test => src/test}/contracts/closure-3.ligo (100%) rename {test => src/test}/contracts/closure.ligo (100%) rename {test => src/test}/contracts/coase.ligo (100%) rename {test => src/test}/contracts/condition-simple.ligo (100%) rename {test => src/test}/contracts/condition.ligo (100%) rename {test => src/test}/contracts/counter.ligo (100%) rename {test => src/test}/contracts/counter.mligo (100%) rename {test => src/test}/contracts/declaration-local.ligo (100%) rename {test => src/test}/contracts/declarations.ligo (100%) rename {test => src/test}/contracts/dispatch-counter.ligo (100%) rename {test => src/test}/contracts/error_syntax.ligo (100%) rename {test => src/test}/contracts/error_type.ligo (100%) rename {test => src/test}/contracts/failwith.mligo (100%) rename {test => src/test}/contracts/function-complex.ligo (100%) rename {test => src/test}/contracts/function-shared.ligo (100%) rename {test => src/test}/contracts/function.ligo (100%) rename {test => src/test}/contracts/guess_string.mligo (100%) rename {test => src/test}/contracts/heap-instance.ligo (100%) rename {test => src/test}/contracts/heap.ligo (100%) rename {test => src/test}/contracts/high-order.ligo (100%) rename {test => src/test}/contracts/included.ligo (100%) rename {test => src/test}/contracts/includer.ligo (100%) rename {test => src/test}/contracts/lambda.ligo (100%) rename {test => src/test}/contracts/lambda.mligo (100%) rename {test => src/test}/contracts/lambda2.mligo (100%) rename {test => src/test}/contracts/letin.mligo (100%) rename {test => src/test}/contracts/list.ligo (100%) rename {test => src/test}/contracts/list.mligo (100%) rename {test => src/test}/contracts/loop.ligo (100%) rename {test => src/test}/contracts/map.ligo (100%) rename {test => src/test}/contracts/match.ligo (100%) rename {test => src/test}/contracts/match.mligo (100%) rename {test => src/test}/contracts/match_bis.mligo (100%) rename {test => src/test}/contracts/multiple-parameters.ligo (100%) rename {test => src/test}/contracts/new-syntax.mligo (100%) rename {test => src/test}/contracts/option.ligo (100%) rename {test => src/test}/contracts/parser-bad-reported-term.ligo (100%) rename {test => src/test}/contracts/quote-declaration.ligo (100%) rename {test => src/test}/contracts/quote-declarations.ligo (100%) rename {test => src/test}/contracts/record.ligo (100%) rename {test => src/test}/contracts/record.mligo (100%) rename {test => src/test}/contracts/set_arithmetic-1.ligo (100%) rename {test => src/test}/contracts/set_arithmetic.ligo (100%) rename {test => src/test}/contracts/shadow.ligo (100%) rename {test => src/test}/contracts/string.ligo (100%) rename {test => src/test}/contracts/string_arithmetic.ligo (100%) rename {test => src/test}/contracts/super-counter.ligo (100%) rename {test => src/test}/contracts/super-counter.mligo (100%) rename {test => src/test}/contracts/toto.ligo (100%) rename {test => src/test}/contracts/tuple.ligo (100%) rename {test => src/test}/contracts/type-alias.ligo (100%) rename {test => src/test}/contracts/unit.ligo (100%) rename {test => src/test}/contracts/variant-matching.ligo (100%) rename {test => src/test}/contracts/variant.ligo (100%) rename {test => src/test}/contracts/vote.mligo (100%) rename {test => src/test}/contracts/website1.ligo (100%) rename {test => src/test}/contracts/website2.ligo (100%) rename {test => src/test}/dune (100%) rename {test => src/test}/heap_tests.ml (100%) rename {test => src/test}/integration_tests.ml (100%) rename {test => src/test}/manual_test.ml (100%) rename {test => src/test}/multifix_tests.ml (100%) rename {test => src/test}/test.ml (100%) rename {test => src/test}/test_helpers.ml (100%) rename {test => src/test}/transpiler_tests.ml (100%) rename {test => src/test}/typer_tests.ml (100%) rename {test => src/test}/vote_tests.ml (100%) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index 068f2bf1d..28a565e40 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -4,6 +4,6 @@ let toplevel x = match x with | Trace.Ok ((), annotations) -> ignore annotations; () | Error ss -> ( - Format.printf "%a%!" Ligo.Display.error_pp (ss ()) + Format.printf "%a%!" Display.error_pp (ss ()) ) diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index ea964be97..ffd31b259 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -10,3 +10,6 @@ let compile_expression : expression -> Michelson.t result = fun e -> let compile_function : anon_function -> type_value -> type_value -> Compiler.Program.compiled_program result = fun f in_ty out_ty -> Compiler.Program.translate_entry f (in_ty , out_ty) + +let uncompile_value : Proto_alpha_utils.Memory_proto_alpha.X.ex_typed_value -> value result = fun x -> + Compiler.Uncompiler.translate_value x diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 27bf6ebef..f6c4500ac 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -10,6 +10,23 @@ let compile_expression_entry (program : program) entry_point : Compiler.Program. let%bind typed_program = Typer.type_program program in Of_typed.compile_expression_entry typed_program entry_point -let compile_expression ae : Michelson.t result = - let%bind typed = Typer.type_expression Ast_typed.Environment.full_empty ae in +let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = + let%bind typed = Typer.type_expression env ae in Of_typed.compile_expression typed + +let uncompile_typed_program_entry_expression_result program entry ex_ty_value = + let%bind output_type = + let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in + ok entry_expression.type_annotation + in + let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in + Typer.untype_expression typed + +let uncompile_typed_program_entry_function_result program entry ex_ty_value = + let%bind output_type = + let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in + let%bind (_ , output_type) = Ast_typed.get_t_function entry_expression.type_annotation in + ok output_type + in + let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in + Typer.untype_expression typed diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index a4fd4e814..9d6005e4d 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -17,3 +17,38 @@ let compile_file_parameter : string -> string -> string -> s_syntax -> Michelson let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind simplified = parsify_expression syntax expression in Of_simplified.compile_expression simplified + +let compile_file_expression : string -> string -> string -> s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify_expression syntax expression in + Of_simplified.compile_expression simplified + +let compile_file_storage : string -> string -> string -> s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify_expression syntax expression in + Of_simplified.compile_expression simplified + +let compile_file_contract_args = + fun source_filename _entry_point storage parameter syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind storage_simplified = parsify_expression syntax storage in + let%bind parameter_simplified = parsify_expression syntax parameter in + let args = Ast_simplified.e_pair storage_simplified parameter_simplified in + Of_simplified.compile_expression args + +let type_file ?(debug_simplify = false) ?(debug_typed = false) + syntax (source_filename:string) : Ast_typed.program result = + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simpl = parsify syntax source_filename in + (if debug_simplify then + Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) + ) ; + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simpl in + (if debug_typed then ( + Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) + )) ; + ok typed diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 96adc461c..962543444 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -51,6 +51,27 @@ let compile_function expr = in Of_mini_c.compile_function f in_ty out_ty + +let get_entry (lst : program) (name : string) : (annotated_expression * int) result = + let%bind entry_expression = + trace_option (Errors.missing_entry_point name) @@ + let aux x = + let (Declaration_constant (an , _)) = Location.unwrap x in + if (an.name = name) + then Some an.annotated_expression + else None + in + List.find_map aux lst + in + let entry_index = + let aux x = + let (Declaration_constant (an , _)) = Location.unwrap x in + an.name = name + in + List.find_index aux lst + in + ok (entry_expression , entry_index) + (* Assume the following code: ``` @@ -68,50 +89,61 @@ let compile_function expr = x + y ``` - To do so, each declaration `const variable = expr` is translated in - a function `body -> let variable = expr in body`. Those functions are - then applied in order, which yields `let x = 42 in let y = 120 in ...`. - The entry-point can be an expression, which is then functionalized if `to_functionalize` is set to true. *) -let aggregate_declarations_for_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result = - let rec aux acc (lst : program) = - let%bind acc = acc in - match lst with - | [] -> fail @@ Errors.missing_entry_point name - | hd :: tl -> ( - let (Declaration_constant (an , (pre_env , _))) = Location.unwrap hd in - if (an.name <> name) then ( - let next = fun expr -> - let cur = e_a_let_in an.name an.annotated_expression expr pre_env in - acc cur in - aux (ok next) tl - ) else ( - match (an.annotated_expression.expression , to_functionalize) with - | (E_lambda l , false) -> ( - let l' = { l with body = acc l.body } in - let e' = { an.annotated_expression with expression = E_lambda l' } in - ok e' - ) - | (_ , true) -> ( - ok @@ functionalize @@ acc an.annotated_expression - ) - | _ -> fail @@ Errors.not_functional_main an.annotated_expression.location - ) - ) +let get_aggregated_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result = + let%bind (entry_expression , entry_index) = get_entry lst name in + let pre_declarations = + let sub_program = List.until entry_index lst in + let aux x = Location.unwrap x in + List.map aux sub_program in - let%bind l = aux (ok (fun x -> x)) lst in - ok l + let wrapper = + let aux prec cur = + let (Declaration_constant (an , (pre_env , _))) = cur in + e_a_let_in an.name an.annotated_expression prec pre_env + in + fun expr -> List.fold_right' aux expr pre_declarations + in + match (entry_expression.expression , to_functionalize) with + | (E_lambda l , false) -> ( + let l' = { l with body = wrapper l.body } in + let e' = { entry_expression with expression = E_lambda l' } in + ok e' + ) + | (_ , true) -> ( + ok @@ functionalize @@ wrapper entry_expression + ) + | _ -> fail @@ Errors.not_functional_main entry_expression.location let compile_function_entry : program -> string -> _ = fun p entry -> - let%bind expr = aggregate_declarations_for_entry p entry false in + let%bind expr = get_aggregated_entry p entry false in compile_function expr let compile_expression_entry : program -> string -> _ = fun p entry -> - let%bind expr = aggregate_declarations_for_entry p entry true in + let%bind expr = get_aggregated_entry p entry true in compile_function expr let compile_expression_as_function : annotated_expression -> Compiler.Program.compiled_program result = fun e -> let expr = functionalize e in compile_function expr + +let uncompile_value : _ -> _ -> annotated_expression result = fun x ty -> + let%bind mini_c = Of_mini_c.uncompile_value x in + Transpiler.untranspile mini_c ty + +let uncompile_entry_function_result = fun program entry ex_ty_value -> + let%bind output_type = + let%bind (entry_expression , _ ) = get_entry program entry in + let%bind (_ , output_type) = get_t_function entry_expression.type_annotation in + ok output_type + in + uncompile_value ex_ty_value output_type + +let uncompile_entry_expression_result = fun program entry ex_ty_value -> + let%bind output_type = + let%bind (entry_expression , _ ) = get_entry program entry in + ok entry_expression.type_annotation + in + uncompile_value ex_ty_value output_type diff --git a/src/main/run/display.ml b/src/main/display.ml similarity index 100% rename from src/main/run/display.ml rename to src/main/display.ml diff --git a/src/main/run/dune b/src/main/run/dune index 330bf32d5..34f7986af 100644 --- a/src/main/run/dune +++ b/src/main/run/dune @@ -13,6 +13,7 @@ mini_c operators compiler + compile ) (preprocess (pps ppx_let) diff --git a/src/main/run/main.ml b/src/main/run/main.ml deleted file mode 100644 index 1c4afcd58..000000000 --- a/src/main/run/main.ml +++ /dev/null @@ -1,137 +0,0 @@ -module Run_mini_c = Run_mini_c - -(* open Trace *) -module Parser = Parser -module AST_Raw = Parser.Pascaligo.AST -module AST_Simplified = Ast_simplified -module AST_Typed = Ast_typed -module Mini_c = Mini_c -module Typer = Typer -module Transpiler = Transpiler - -module Run = struct - include Run_source - include Run_simplified - include Run_typed - include Run_mini_c -end - -module Display = Display - -(* module Parser_multifix = Multifix - * module Simplify_multifix = Simplify_multifix *) - - -(* let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p - * let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e - * let unparse_simplified_expr (e:AST_Simplified.expression) : string result = - * ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e - * - * let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p - * let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) - * (e:AST_Simplified.expression) : AST_Typed.annotated_expression result = - * Typer.type_expression env e - * let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e - * - * let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p - * let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name - * let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e - * - * let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = - * Transpiler.untranspile v e - * - * let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program - * - * let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = - * let%bind result = - * let%bind mini_c_main = - * transpile_entry program entry in - * Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - * let%bind typed_result = - * let%bind typed_main = Ast_typed.get_entry program entry in - * untranspile_value result typed_main.type_annotation in - * ok typed_result - * - * - * let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") - * - * - * let easy_run_typed - * ?(debug_mini_c = false) ?options (entry:string) - * (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = - * let%bind () = - * let open Ast_typed in - * let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in - * let%bind (arg_ty , _) = - * trace_strong (simple_error "entry-point doesn't have a function type") @@ - * get_t_function @@ get_type_annotation d.annotated_expression in - * Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) - * in - * - * let%bind mini_c_main = - * trace (simple_error "transpile mini_c entry") @@ - * transpile_entry program entry in - * (if debug_mini_c then - * Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - * ) ; - * - * let%bind mini_c_value = transpile_value input in - * - * let%bind mini_c_result = - * let error = - * let title () = "run Mini_c" in - * let content () = - * Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - * in - * error title content in - * trace error @@ - * Run_mini_c.run_entry ?options mini_c_main mini_c_value in - * let%bind typed_result = - * let%bind main_result_type = - * let%bind typed_main = Ast_typed.get_functional_entry program entry in - * match (snd typed_main).type_value' with - * | T_function (_, result) -> ok result - * | _ -> simple_fail "main doesn't have fun type" in - * untranspile_value mini_c_result main_result_type in - * ok typed_result - * - * let easy_run_typed_simplified - * ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) - * (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result = - * let%bind mini_c_main = - * trace (simple_error "transpile mini_c entry") @@ - * transpile_entry program entry in - * (if debug_mini_c then - * Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - * ) ; - * - * let%bind typed_value = - * let env = - * let last_declaration = Location.unwrap List.(hd @@ rev program) in - * match last_declaration with - * | Declaration_constant (_ , (_ , post_env)) -> post_env - * in - * type_expression ~env input in - * let%bind mini_c_value = transpile_value typed_value in - * - * let%bind mini_c_result = - * let error = - * let title () = "run Mini_c" in - * let content () = - * Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - * in - * error title content in - * trace error @@ - * Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in - * let%bind typed_result = - * let%bind main_result_type = - * let%bind typed_main = Ast_typed.get_functional_entry program entry in - * match (snd typed_main).type_value' with - * | T_function (_, result) -> ok result - * | _ -> simple_fail "main doesn't have fun type" in - * untranspile_value mini_c_result main_result_type in - * let%bind annotated_result = untype_expression typed_result in - * ok annotated_result *) - - -(* module Contract = Contract *) diff --git a/src/main/run/from_michelson.ml b/src/main/run/of_michelson.ml similarity index 100% rename from src/main/run/from_michelson.ml rename to src/main/run/of_michelson.ml diff --git a/src/main/run/run_mini_c.ml b/src/main/run/of_mini_c.ml similarity index 86% rename from src/main/run/run_mini_c.ml rename to src/main/run/of_mini_c.ml index 06864c223..8e22c8a54 100644 --- a/src/main/run/run_mini_c.ml +++ b/src/main/run/of_mini_c.ml @@ -16,7 +16,7 @@ type options = { input_type : type_value ; output_type : type_value ; input : value ; - michelson_options : From_michelson.options ; + michelson_options : Of_michelson.options ; } let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result = @@ -31,7 +31,7 @@ let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (in Format.printf "Input Type: %a\n" PP.type_ (fst ty) ; Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; ) ; - let%bind ex_ty_value = From_michelson.run ?options compiled input_michelson in + let%bind ex_ty_value = Of_michelson.run ?options compiled input_michelson in if debug_michelson then ( let (Ex_typed_value (ty , v)) = ex_ty_value in ignore @@ @@ -41,5 +41,5 @@ let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (in Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; ok () ) ; - let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in + let%bind (result : value) = Compile.Of_mini_c.uncompile_value ex_ty_value in ok result diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml new file mode 100644 index 000000000..22e3d7026 --- /dev/null +++ b/src/main/run/of_simplified.ml @@ -0,0 +1,31 @@ +open Trace +open Ast_simplified + +let get_final_environment program = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + let (Ast_typed.Declaration_constant (_ , (_ , post_env))) = last_declaration in + post_env + +let run_typed_program + ?options + (program : Ast_typed.program) (entry : string) + (input : expression) : expression result = + let%bind code = Compile.Of_typed.compile_function_entry program entry in + let%bind input = + let env = get_final_environment program in + Compile.Of_simplified.compile_expression ~env input + in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value + +let evaluate_typed_program_entry + ?options + (program : Ast_typed.program) (entry : string) + : Ast_simplified.expression result = + let%bind code = Compile.Of_typed.compile_expression_entry program entry in + let%bind input = + let fake_input = Ast_typed.(e_a_unit Environment.full_empty) in + Compile.Of_typed.compile_expression fake_input + in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml new file mode 100644 index 000000000..55a455f9e --- /dev/null +++ b/src/main/run/of_source.ml @@ -0,0 +1,92 @@ +open Trace + +include struct + open Ast_simplified + + let assert_entry_point_defined : program -> string -> unit result = + fun program entry_point -> + let aux : declaration -> bool = fun declaration -> + match declaration with + | Declaration_type _ -> false + | Declaration_constant (name , _ , _) -> name = entry_point + in + trace_strong (simple_error "no entry-point with given name") @@ + Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program +end + +include struct + open Ast_typed + open Combinators + + let get_entry_point_type : type_value -> (type_value * type_value) result = fun t -> + let%bind (arg , result) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function t in + let%bind (arg' , storage_param) = + trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ + get_t_pair arg in + let%bind (ops , storage_result) = + trace_strong (simple_error "entry-point doesn't have 2 results") @@ + get_t_pair result in + let%bind () = + trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ + assert_t_list_operation ops in + let%bind () = + trace_strong (simple_error "entry-point doesn't identical type (storage) for second parameter and second result") @@ + assert_type_value_eq (storage_param , storage_result) in + ok (arg' , storage_param) + + let get_entry_point : program -> string -> (type_value * type_value) result = fun p e -> + let%bind declaration = get_declaration_by_name p e in + match declaration with + | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation + + let assert_valid_entry_point = fun p e -> + let%bind _ = get_entry_point p e in + ok () +end + +let run_contract ?amount source_filename entry_point storage parameter syntax = + let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind code = Compile.Of_typed.compile_function_entry program entry_point in + let%bind args = Compile.Of_source.compile_file_contract_args source_filename entry_point storage parameter syntax in + let%bind ex_value_ty = + let options = + let open Proto_alpha_utils.Memory_proto_alpha in + let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in + (make_options ?amount ()) + in + Of_michelson.run ~options code args + in + Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty + +let run_function ?amount source_filename entry_point input syntax = + let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind code = Compile.Of_typed.compile_function_entry program entry_point in + let%bind args = Compile.Of_source.compile_file_expression source_filename entry_point input syntax in + let%bind ex_value_ty = + let options = + let open Proto_alpha_utils.Memory_proto_alpha in + let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in + (make_options ?amount ()) + in + Of_michelson.run ~options code args + in + Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty + +let evaluate ?amount source_filename entry_point syntax = + let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind code = Compile.Of_typed.compile_expression_entry program entry_point in + let%bind input = + let fake_input = Ast_simplified.e_unit () in + Compile.Of_simplified.compile_expression fake_input + in + let%bind ex_value_ty = + let options = + let open Proto_alpha_utils.Memory_proto_alpha in + let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in + (make_options ?amount ()) + in + Of_michelson.run ~options code input + in + Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry_point ex_value_ty diff --git a/src/main/run/of_typed.ml b/src/main/run/of_typed.ml new file mode 100644 index 000000000..a7bbcb88c --- /dev/null +++ b/src/main/run/of_typed.ml @@ -0,0 +1,34 @@ +open Trace +open Ast_typed + +let run_function ?options f input = + let%bind code = Compile.Of_typed.compile_function f in + let%bind input = Compile.Of_typed.compile_expression input in + let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind ty = + let%bind (_ , output_ty) = get_t_function f.type_annotation in + ok output_ty + in + Compile.Of_typed.uncompile_value ex_ty_value ty + +let run_entry + ?options (entry : string) + (program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + let%bind code = Compile.Of_typed.compile_function_entry program entry in + let%bind input = Compile.Of_typed.compile_expression input in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_typed.uncompile_entry_function_result program entry ex_ty_value + +let evaluate ?options (e : annotated_expression) : annotated_expression result = + let%bind code = Compile.Of_typed.compile_expression_as_function e in + let fake_input = e_a_unit Environment.full_empty in + let%bind input = Compile.Of_typed.compile_expression fake_input in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_typed.uncompile_value ex_ty_value e.type_annotation + +let evaluate_entry ?options program entry = + let%bind code = Compile.Of_typed.compile_expression_entry program entry in + let fake_input = e_a_unit Environment.full_empty in + let%bind input = Compile.Of_typed.compile_expression fake_input in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_typed.uncompile_entry_expression_result program entry ex_ty_value diff --git a/src/main/run/run.ml b/src/main/run/run.ml new file mode 100644 index 000000000..10ca5ed1d --- /dev/null +++ b/src/main/run/run.ml @@ -0,0 +1,4 @@ +module Of_typed = Of_typed +module Of_simplified = Of_simplified +module Of_mini_c = Of_mini_c +module Of_michelson = Of_michelson diff --git a/src/main/run/run_simplified.ml b/src/main/run/run_simplified.ml deleted file mode 100644 index 4faf34aaf..000000000 --- a/src/main/run/run_simplified.ml +++ /dev/null @@ -1,27 +0,0 @@ -open Trace - -let run_simplityped - ?options - ?(debug_mini_c = false) ?(debug_michelson = false) - (program : Ast_typed.program) (entry : string) - (input : Ast_simplified.expression) : Ast_simplified.expression result = - let%bind typed_input = - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - Typer.type_expression env input in - let%bind typed_result = - Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in - let%bind annotated_result = Typer.untype_expression typed_result in - ok annotated_result - -let evaluate_simplityped - ?options - ?(debug_mini_c = false) ?(debug_michelson = false) - (program : Ast_typed.program) (entry : string) - : Ast_simplified.expression result = - let%bind typed_result = Run_typed.evaluate_typed ?options ~debug_mini_c ~debug_michelson entry program in - let%bind annotated_result = Typer.untype_expression typed_result in - ok annotated_result diff --git a/src/main/run/run_source.ml b/src/main/run/run_source.ml deleted file mode 100644 index 214d1e091..000000000 --- a/src/main/run/run_source.ml +++ /dev/null @@ -1,207 +0,0 @@ -open Trace - -include struct - open Ast_simplified - - let assert_entry_point_defined : program -> string -> unit result = - fun program entry_point -> - let aux : declaration -> bool = fun declaration -> - match declaration with - | Declaration_type _ -> false - | Declaration_constant (name , _ , _) -> name = entry_point - in - trace_strong (simple_error "no entry-point with given name") @@ - Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program -end - -include struct - open Ast_typed - open Combinators - - let get_entry_point_type : type_value -> (type_value * type_value) result = fun t -> - let%bind (arg , result) = - trace_strong (simple_error "entry-point doesn't have a function type") @@ - get_t_function t in - let%bind (arg' , storage_param) = - trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ - get_t_pair arg in - let%bind (ops , storage_result) = - trace_strong (simple_error "entry-point doesn't have 2 results") @@ - get_t_pair result in - let%bind () = - trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ - assert_t_list_operation ops in - let%bind () = - trace_strong (simple_error "entry-point doesn't identical type (storage) for second parameter and second result") @@ - assert_type_value_eq (storage_param , storage_result) in - ok (arg' , storage_param) - - let get_entry_point : program -> string -> (type_value * type_value) result = fun p e -> - let%bind declaration = get_declaration_by_name p e in - match declaration with - | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation - - let assert_valid_entry_point = fun p e -> - let%bind _ = get_entry_point p e in - ok () -end - -let transpile_value - (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result = - let%bind (f , ty) = - let open Transpiler in - let (f , _) = functionalize e in - let%bind main = translate_main f e.location in - ok main - in - - let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f ty input in - ok (r , snd ty) - -open Helpers - -let compile_contract_file : string -> string -> s_syntax -> string result = fun source_filename entry_point syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind simplified = parsify syntax source_filename in - let%bind () = - assert_entry_point_defined simplified entry_point in - let%bind typed = - trace (simple_error "typing") @@ - Typer.type_program simplified in - let%bind (mini_c , mini_c_ty) = - trace (simple_error "transpiling") @@ - Transpiler.translate_entry typed entry_point in - let%bind michelson = - trace (simple_error "compiling") @@ - Compiler.translate_contract mini_c mini_c_ty in - let str = - Format.asprintf "%a" Michelson.pp_stripped michelson in - ok str - -let compile_contract_parameter : string -> string -> string -> s_syntax -> string result = fun source_filename entry_point expression syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind (program , parameter_tv) = - let%bind simplified = parsify syntax source_filename in - let%bind () = - assert_entry_point_defined simplified entry_point in - let%bind typed = - trace (simple_error "typing file") @@ - Typer.type_program simplified in - let%bind (param_ty , _) = - get_entry_point typed entry_point in - ok (typed , param_ty) - in - let%bind expr = - let%bind typed = - let%bind simplified = parsify_expression syntax expression in - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - trace (simple_error "typing expression") @@ - Typer.type_expression env simplified in - let%bind () = - trace (simple_error "expression type doesn't match type parameter") @@ - Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in - let%bind (mini_c , mini_c_ty) = - trace (simple_error "transpiling expression") @@ - transpile_value typed in - let%bind michelson = - trace (simple_error "compiling expression") @@ - Compiler.translate_value mini_c mini_c_ty in - let str = - Format.asprintf "%a" Michelson.pp_stripped michelson in - ok str - in - ok expr - - -let compile_contract_storage : string -> string -> string -> s_syntax -> string result = fun source_filename entry_point expression syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind (program , storage_tv) = - let%bind simplified = parsify syntax source_filename in - let%bind () = - assert_entry_point_defined simplified entry_point in - let%bind typed = - trace (simple_error "typing file") @@ - Typer.type_program simplified in - let%bind (_ , storage_ty) = - get_entry_point typed entry_point in - ok (typed , storage_ty) - in - let%bind expr = - let%bind simplified = parsify_expression syntax expression in - let%bind typed = - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - trace (simple_error "typing expression") @@ - Typer.type_expression env simplified in - let%bind () = - trace (simple_error "expression type doesn't match type storage") @@ - Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in - let%bind (mini_c , mini_c_ty) = - trace (simple_error "transpiling expression") @@ - transpile_value typed in - let%bind michelson = - trace (simple_error "compiling expression") @@ - Compiler.translate_value mini_c mini_c_ty in - let str = - Format.asprintf "%a" Michelson.pp_stripped michelson in - ok str - in - ok expr - -let type_file ?(debug_simplify = false) ?(debug_typed = false) - syntax (source_filename:string) : Ast_typed.program result = - let%bind simpl = parsify syntax source_filename in - (if debug_simplify then - Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) - ) ; - let%bind typed = - trace (simple_error "typing") @@ - Typer.type_program simpl in - (if debug_typed then ( - Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) - )) ; - ok typed - -let run_contract ?amount source_filename entry_point storage input syntax = - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind typed = - type_file syntax source_filename in - let%bind storage_simpl = - parsify_expression syntax storage in - let%bind input_simpl = - parsify_expression syntax input in - let options = - let open Proto_alpha_utils.Memory_proto_alpha in - let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in - (make_options ?amount ()) in - Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) - -let run_function ?amount source_filename entry_point parameter syntax = - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind typed = - type_file syntax source_filename in - let%bind parameter' = - parsify_expression syntax parameter in - let options = - let open Proto_alpha_utils.Memory_proto_alpha in - let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in - (make_options ?amount ()) in - Run_simplified.run_simplityped ~options typed entry_point parameter' - -let evaluate_value ?amount source_filename entry_point syntax = - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind typed = - type_file syntax source_filename in - let options = - let open Proto_alpha_utils.Memory_proto_alpha in - let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in - (make_options ?amount ()) in - Run_simplified.evaluate_simplityped ~options typed entry_point diff --git a/src/main/run/run_typed.ml b/src/main/run/run_typed.ml deleted file mode 100644 index 0f41fe6fa..000000000 --- a/src/main/run/run_typed.ml +++ /dev/null @@ -1,71 +0,0 @@ -open Trace -open Ast_typed - -let evaluate (e : annotated_expression) : annotated_expression result = - let%bind (f , ty) = - let open Transpiler in - let (f , _) = functionalize e in - let%bind main = translate_main f e.location in - ok main - in - - let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f ty input in - ok r - -let evaluate_typed - ?(debug_mini_c = false) ?(debug_michelson = false) - ?options (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = - trace (simple_error "easy evaluate typed") @@ - let%bind result = - let%bind (mini_c_main , ty) = - Transpiler.translate_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - ) ; - Run_mini_c.run_entry ?options ~debug_michelson mini_c_main ty (Mini_c.Combinators.d_unit) - in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - Transpiler.untranspile result typed_main.type_annotation in - ok typed_result - -let run_typed - ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) - (program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = - let%bind - let%bind () = - let open Ast_typed in - let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in - let%bind (arg_ty , _) = - trace_strong (simple_error "entry-point doesn't have a function type") @@ - get_t_function @@ get_type_annotation d.annotated_expression in - Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) - in - - let%bind (mini_c_main , ty) = - trace (simple_error "transpile mini_c entry") @@ - Transpiler.translate_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - ) ; - - let%bind mini_c_value = transpile_value input in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - in - error title content in - trace error @@ - Run_mini_c.run_entry ~debug_michelson ?options mini_c_main ty mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - Transpiler.untranspile mini_c_result main_result_type in - ok typed_result diff --git a/test/.gitignore b/src/test/.gitignore similarity index 100% rename from test/.gitignore rename to src/test/.gitignore diff --git a/test/bin_tests.ml b/src/test/bin_tests.ml similarity index 100% rename from test/bin_tests.ml rename to src/test/bin_tests.ml diff --git a/test/coase_tests.ml b/src/test/coase_tests.ml similarity index 100% rename from test/coase_tests.ml rename to src/test/coase_tests.ml diff --git a/test/compiler_tests.ml b/src/test/compiler_tests.ml similarity index 100% rename from test/compiler_tests.ml rename to src/test/compiler_tests.ml diff --git a/test/contracts/amount.mligo b/src/test/contracts/amount.mligo similarity index 100% rename from test/contracts/amount.mligo rename to src/test/contracts/amount.mligo diff --git a/test/contracts/annotation.ligo b/src/test/contracts/annotation.ligo similarity index 100% rename from test/contracts/annotation.ligo rename to src/test/contracts/annotation.ligo diff --git a/test/contracts/arithmetic.ligo b/src/test/contracts/arithmetic.ligo similarity index 100% rename from test/contracts/arithmetic.ligo rename to src/test/contracts/arithmetic.ligo diff --git a/test/contracts/assign.ligo b/src/test/contracts/assign.ligo similarity index 100% rename from test/contracts/assign.ligo rename to src/test/contracts/assign.ligo diff --git a/test/contracts/basic.mligo b/src/test/contracts/basic.mligo similarity index 100% rename from test/contracts/basic.mligo rename to src/test/contracts/basic.mligo diff --git a/test/contracts/bitwise_arithmetic.ligo b/src/test/contracts/bitwise_arithmetic.ligo similarity index 100% rename from test/contracts/bitwise_arithmetic.ligo rename to src/test/contracts/bitwise_arithmetic.ligo diff --git a/test/contracts/boolean_operators.ligo b/src/test/contracts/boolean_operators.ligo similarity index 100% rename from test/contracts/boolean_operators.ligo rename to src/test/contracts/boolean_operators.ligo diff --git a/test/contracts/bytes_arithmetic.ligo b/src/test/contracts/bytes_arithmetic.ligo similarity index 100% rename from test/contracts/bytes_arithmetic.ligo rename to src/test/contracts/bytes_arithmetic.ligo diff --git a/test/contracts/closure-1.ligo b/src/test/contracts/closure-1.ligo similarity index 100% rename from test/contracts/closure-1.ligo rename to src/test/contracts/closure-1.ligo diff --git a/test/contracts/closure-2.ligo b/src/test/contracts/closure-2.ligo similarity index 100% rename from test/contracts/closure-2.ligo rename to src/test/contracts/closure-2.ligo diff --git a/test/contracts/closure-3.ligo b/src/test/contracts/closure-3.ligo similarity index 100% rename from test/contracts/closure-3.ligo rename to src/test/contracts/closure-3.ligo diff --git a/test/contracts/closure.ligo b/src/test/contracts/closure.ligo similarity index 100% rename from test/contracts/closure.ligo rename to src/test/contracts/closure.ligo diff --git a/test/contracts/coase.ligo b/src/test/contracts/coase.ligo similarity index 100% rename from test/contracts/coase.ligo rename to src/test/contracts/coase.ligo diff --git a/test/contracts/condition-simple.ligo b/src/test/contracts/condition-simple.ligo similarity index 100% rename from test/contracts/condition-simple.ligo rename to src/test/contracts/condition-simple.ligo diff --git a/test/contracts/condition.ligo b/src/test/contracts/condition.ligo similarity index 100% rename from test/contracts/condition.ligo rename to src/test/contracts/condition.ligo diff --git a/test/contracts/counter.ligo b/src/test/contracts/counter.ligo similarity index 100% rename from test/contracts/counter.ligo rename to src/test/contracts/counter.ligo diff --git a/test/contracts/counter.mligo b/src/test/contracts/counter.mligo similarity index 100% rename from test/contracts/counter.mligo rename to src/test/contracts/counter.mligo diff --git a/test/contracts/declaration-local.ligo b/src/test/contracts/declaration-local.ligo similarity index 100% rename from test/contracts/declaration-local.ligo rename to src/test/contracts/declaration-local.ligo diff --git a/test/contracts/declarations.ligo b/src/test/contracts/declarations.ligo similarity index 100% rename from test/contracts/declarations.ligo rename to src/test/contracts/declarations.ligo diff --git a/test/contracts/dispatch-counter.ligo b/src/test/contracts/dispatch-counter.ligo similarity index 100% rename from test/contracts/dispatch-counter.ligo rename to src/test/contracts/dispatch-counter.ligo diff --git a/test/contracts/error_syntax.ligo b/src/test/contracts/error_syntax.ligo similarity index 100% rename from test/contracts/error_syntax.ligo rename to src/test/contracts/error_syntax.ligo diff --git a/test/contracts/error_type.ligo b/src/test/contracts/error_type.ligo similarity index 100% rename from test/contracts/error_type.ligo rename to src/test/contracts/error_type.ligo diff --git a/test/contracts/failwith.mligo b/src/test/contracts/failwith.mligo similarity index 100% rename from test/contracts/failwith.mligo rename to src/test/contracts/failwith.mligo diff --git a/test/contracts/function-complex.ligo b/src/test/contracts/function-complex.ligo similarity index 100% rename from test/contracts/function-complex.ligo rename to src/test/contracts/function-complex.ligo diff --git a/test/contracts/function-shared.ligo b/src/test/contracts/function-shared.ligo similarity index 100% rename from test/contracts/function-shared.ligo rename to src/test/contracts/function-shared.ligo diff --git a/test/contracts/function.ligo b/src/test/contracts/function.ligo similarity index 100% rename from test/contracts/function.ligo rename to src/test/contracts/function.ligo diff --git a/test/contracts/guess_string.mligo b/src/test/contracts/guess_string.mligo similarity index 100% rename from test/contracts/guess_string.mligo rename to src/test/contracts/guess_string.mligo diff --git a/test/contracts/heap-instance.ligo b/src/test/contracts/heap-instance.ligo similarity index 100% rename from test/contracts/heap-instance.ligo rename to src/test/contracts/heap-instance.ligo diff --git a/test/contracts/heap.ligo b/src/test/contracts/heap.ligo similarity index 100% rename from test/contracts/heap.ligo rename to src/test/contracts/heap.ligo diff --git a/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo similarity index 100% rename from test/contracts/high-order.ligo rename to src/test/contracts/high-order.ligo diff --git a/test/contracts/included.ligo b/src/test/contracts/included.ligo similarity index 100% rename from test/contracts/included.ligo rename to src/test/contracts/included.ligo diff --git a/test/contracts/includer.ligo b/src/test/contracts/includer.ligo similarity index 100% rename from test/contracts/includer.ligo rename to src/test/contracts/includer.ligo diff --git a/test/contracts/lambda.ligo b/src/test/contracts/lambda.ligo similarity index 100% rename from test/contracts/lambda.ligo rename to src/test/contracts/lambda.ligo diff --git a/test/contracts/lambda.mligo b/src/test/contracts/lambda.mligo similarity index 100% rename from test/contracts/lambda.mligo rename to src/test/contracts/lambda.mligo diff --git a/test/contracts/lambda2.mligo b/src/test/contracts/lambda2.mligo similarity index 100% rename from test/contracts/lambda2.mligo rename to src/test/contracts/lambda2.mligo diff --git a/test/contracts/letin.mligo b/src/test/contracts/letin.mligo similarity index 100% rename from test/contracts/letin.mligo rename to src/test/contracts/letin.mligo diff --git a/test/contracts/list.ligo b/src/test/contracts/list.ligo similarity index 100% rename from test/contracts/list.ligo rename to src/test/contracts/list.ligo diff --git a/test/contracts/list.mligo b/src/test/contracts/list.mligo similarity index 100% rename from test/contracts/list.mligo rename to src/test/contracts/list.mligo diff --git a/test/contracts/loop.ligo b/src/test/contracts/loop.ligo similarity index 100% rename from test/contracts/loop.ligo rename to src/test/contracts/loop.ligo diff --git a/test/contracts/map.ligo b/src/test/contracts/map.ligo similarity index 100% rename from test/contracts/map.ligo rename to src/test/contracts/map.ligo diff --git a/test/contracts/match.ligo b/src/test/contracts/match.ligo similarity index 100% rename from test/contracts/match.ligo rename to src/test/contracts/match.ligo diff --git a/test/contracts/match.mligo b/src/test/contracts/match.mligo similarity index 100% rename from test/contracts/match.mligo rename to src/test/contracts/match.mligo diff --git a/test/contracts/match_bis.mligo b/src/test/contracts/match_bis.mligo similarity index 100% rename from test/contracts/match_bis.mligo rename to src/test/contracts/match_bis.mligo diff --git a/test/contracts/multiple-parameters.ligo b/src/test/contracts/multiple-parameters.ligo similarity index 100% rename from test/contracts/multiple-parameters.ligo rename to src/test/contracts/multiple-parameters.ligo diff --git a/test/contracts/new-syntax.mligo b/src/test/contracts/new-syntax.mligo similarity index 100% rename from test/contracts/new-syntax.mligo rename to src/test/contracts/new-syntax.mligo diff --git a/test/contracts/option.ligo b/src/test/contracts/option.ligo similarity index 100% rename from test/contracts/option.ligo rename to src/test/contracts/option.ligo diff --git a/test/contracts/parser-bad-reported-term.ligo b/src/test/contracts/parser-bad-reported-term.ligo similarity index 100% rename from test/contracts/parser-bad-reported-term.ligo rename to src/test/contracts/parser-bad-reported-term.ligo diff --git a/test/contracts/quote-declaration.ligo b/src/test/contracts/quote-declaration.ligo similarity index 100% rename from test/contracts/quote-declaration.ligo rename to src/test/contracts/quote-declaration.ligo diff --git a/test/contracts/quote-declarations.ligo b/src/test/contracts/quote-declarations.ligo similarity index 100% rename from test/contracts/quote-declarations.ligo rename to src/test/contracts/quote-declarations.ligo diff --git a/test/contracts/record.ligo b/src/test/contracts/record.ligo similarity index 100% rename from test/contracts/record.ligo rename to src/test/contracts/record.ligo diff --git a/test/contracts/record.mligo b/src/test/contracts/record.mligo similarity index 100% rename from test/contracts/record.mligo rename to src/test/contracts/record.mligo diff --git a/test/contracts/set_arithmetic-1.ligo b/src/test/contracts/set_arithmetic-1.ligo similarity index 100% rename from test/contracts/set_arithmetic-1.ligo rename to src/test/contracts/set_arithmetic-1.ligo diff --git a/test/contracts/set_arithmetic.ligo b/src/test/contracts/set_arithmetic.ligo similarity index 100% rename from test/contracts/set_arithmetic.ligo rename to src/test/contracts/set_arithmetic.ligo diff --git a/test/contracts/shadow.ligo b/src/test/contracts/shadow.ligo similarity index 100% rename from test/contracts/shadow.ligo rename to src/test/contracts/shadow.ligo diff --git a/test/contracts/string.ligo b/src/test/contracts/string.ligo similarity index 100% rename from test/contracts/string.ligo rename to src/test/contracts/string.ligo diff --git a/test/contracts/string_arithmetic.ligo b/src/test/contracts/string_arithmetic.ligo similarity index 100% rename from test/contracts/string_arithmetic.ligo rename to src/test/contracts/string_arithmetic.ligo diff --git a/test/contracts/super-counter.ligo b/src/test/contracts/super-counter.ligo similarity index 100% rename from test/contracts/super-counter.ligo rename to src/test/contracts/super-counter.ligo diff --git a/test/contracts/super-counter.mligo b/src/test/contracts/super-counter.mligo similarity index 100% rename from test/contracts/super-counter.mligo rename to src/test/contracts/super-counter.mligo diff --git a/test/contracts/toto.ligo b/src/test/contracts/toto.ligo similarity index 100% rename from test/contracts/toto.ligo rename to src/test/contracts/toto.ligo diff --git a/test/contracts/tuple.ligo b/src/test/contracts/tuple.ligo similarity index 100% rename from test/contracts/tuple.ligo rename to src/test/contracts/tuple.ligo diff --git a/test/contracts/type-alias.ligo b/src/test/contracts/type-alias.ligo similarity index 100% rename from test/contracts/type-alias.ligo rename to src/test/contracts/type-alias.ligo diff --git a/test/contracts/unit.ligo b/src/test/contracts/unit.ligo similarity index 100% rename from test/contracts/unit.ligo rename to src/test/contracts/unit.ligo diff --git a/test/contracts/variant-matching.ligo b/src/test/contracts/variant-matching.ligo similarity index 100% rename from test/contracts/variant-matching.ligo rename to src/test/contracts/variant-matching.ligo diff --git a/test/contracts/variant.ligo b/src/test/contracts/variant.ligo similarity index 100% rename from test/contracts/variant.ligo rename to src/test/contracts/variant.ligo diff --git a/test/contracts/vote.mligo b/src/test/contracts/vote.mligo similarity index 100% rename from test/contracts/vote.mligo rename to src/test/contracts/vote.mligo diff --git a/test/contracts/website1.ligo b/src/test/contracts/website1.ligo similarity index 100% rename from test/contracts/website1.ligo rename to src/test/contracts/website1.ligo diff --git a/test/contracts/website2.ligo b/src/test/contracts/website2.ligo similarity index 100% rename from test/contracts/website2.ligo rename to src/test/contracts/website2.ligo diff --git a/test/dune b/src/test/dune similarity index 100% rename from test/dune rename to src/test/dune diff --git a/test/heap_tests.ml b/src/test/heap_tests.ml similarity index 100% rename from test/heap_tests.ml rename to src/test/heap_tests.ml diff --git a/test/integration_tests.ml b/src/test/integration_tests.ml similarity index 100% rename from test/integration_tests.ml rename to src/test/integration_tests.ml diff --git a/test/manual_test.ml b/src/test/manual_test.ml similarity index 100% rename from test/manual_test.ml rename to src/test/manual_test.ml diff --git a/test/multifix_tests.ml b/src/test/multifix_tests.ml similarity index 100% rename from test/multifix_tests.ml rename to src/test/multifix_tests.ml diff --git a/test/test.ml b/src/test/test.ml similarity index 100% rename from test/test.ml rename to src/test/test.ml diff --git a/test/test_helpers.ml b/src/test/test_helpers.ml similarity index 100% rename from test/test_helpers.ml rename to src/test/test_helpers.ml diff --git a/test/transpiler_tests.ml b/src/test/transpiler_tests.ml similarity index 100% rename from test/transpiler_tests.ml rename to src/test/transpiler_tests.ml diff --git a/test/typer_tests.ml b/src/test/typer_tests.ml similarity index 100% rename from test/typer_tests.ml rename to src/test/typer_tests.ml diff --git a/test/vote_tests.ml b/src/test/vote_tests.ml similarity index 100% rename from test/vote_tests.ml rename to src/test/vote_tests.ml From b619fa1f1712284dbdda65e224cdf7589f5ac4dd Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 18 Sep 2019 18:49:33 +0200 Subject: [PATCH 07/53] further down the road --- src/bin/cli.ml | 18 +++++++++--------- src/bin/cli_helpers.ml | 2 +- src/main/compile/of_source.ml | 10 ++++++++-- src/main/main.ml | 1 + src/main/run/of_simplified.ml | 3 ++- src/main/run/run.ml | 1 + src/passes/1-parser/pascaligo.ml | 2 +- src/test/bin_tests.ml | 3 +-- src/test/coase_tests.ml | 3 +-- src/test/compiler_tests.ml | 4 ++-- src/test/heap_tests.ml | 5 +++-- src/test/integration_tests.ml | 15 +++++++-------- src/test/test_helpers.ml | 6 +++--- src/test/typer_tests.ml | 8 ++++---- src/test/vote_tests.ml | 7 ++++--- vendors/ligo-utils/simple-utils/x_list.ml | 1 - 16 files changed, 48 insertions(+), 41 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 11777b504..29fa6247c 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -50,8 +50,8 @@ let compile_file = toplevel @@ let%bind contract = trace (simple_info "compiling contract to michelson") @@ - Ligo.Run.compile_contract_file source entry_point (Syntax_name syntax) in - Format.printf "%s\n" contract ; + Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in + Format.printf "%a\n" Tezos_utils.Michelson.pp contract ; ok () in let term = @@ -65,8 +65,8 @@ let compile_parameter = toplevel @@ let%bind value = trace (simple_error "compile-input") @@ - Ligo.Run.compile_contract_parameter source entry_point expression (Syntax_name syntax) in - Format.printf "%s\n" value; + Ligo.Compile.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in + Format.printf "%a\n" Tezos_utils.Michelson.pp value; ok () in let term = @@ -80,8 +80,8 @@ let compile_storage = toplevel @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Run.compile_contract_storage source entry_point expression (Syntax_name syntax) in - Format.printf "%s\n" value; + Ligo.Compile.Of_source.compile_file_contract_storage source entry_point expression (Syntax_name syntax) in + Format.printf "%a\n" Tezos_utils.Michelson.pp value; ok () in let term = @@ -94,7 +94,7 @@ let dry_run = let f source entry_point storage input amount syntax = toplevel @@ let%bind output = - Ligo.Run.run_contract ~amount source entry_point storage input (Syntax_name syntax) in + Ligo.Run.Of_source.run_contract ~amount source entry_point storage input (Syntax_name syntax) in Format.printf "%a\n" Ast_simplified.PP.expression output ; ok () in @@ -108,7 +108,7 @@ let run_function = let f source entry_point parameter amount syntax = toplevel @@ let%bind output = - Ligo.Run.run_function ~amount source entry_point parameter (Syntax_name syntax) in + Ligo.Run.Of_source.run_function ~amount source entry_point parameter (Syntax_name syntax) in Format.printf "%a\n" Ast_simplified.PP.expression output ; ok () in @@ -122,7 +122,7 @@ let evaluate_value = let f source entry_point amount syntax = toplevel @@ let%bind output = - Ligo.Run.evaluate_value ~amount source entry_point (Syntax_name syntax) in + Ligo.Run.Of_source.evaluate ~amount source entry_point (Syntax_name syntax) in Format.printf "%a\n" Ast_simplified.PP.expression output ; ok () in diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index 28a565e40..ac0354368 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -4,6 +4,6 @@ let toplevel x = match x with | Trace.Ok ((), annotations) -> ignore annotations; () | Error ss -> ( - Format.printf "%a%!" Display.error_pp (ss ()) + Format.printf "%a%!" Main.Display.error_pp (ss ()) ) diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 9d6005e4d..15134ee93 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -12,7 +12,13 @@ let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compil let%bind simplified = parse_file_program source_filename syntax in Of_simplified.compile_function_entry simplified entry_point -let compile_file_parameter : string -> string -> string -> s_syntax -> Michelson.t result = +let compile_file_contract_entry : string -> string -> s_syntax -> Michelson.t result = + fun source_filename entry_point syntax -> + let%bind simplified = parse_file_program source_filename syntax in + let%bind f = Of_simplified.compile_function_entry simplified entry_point in + ok f.body + +let compile_file_contract_parameter : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind simplified = parsify_expression syntax expression in @@ -24,7 +30,7 @@ let compile_file_expression : string -> string -> string -> s_syntax -> Michelso let%bind simplified = parsify_expression syntax expression in Of_simplified.compile_expression simplified -let compile_file_storage : string -> string -> string -> s_syntax -> Michelson.t result = +let compile_file_contract_storage : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind simplified = parsify_expression syntax expression in diff --git a/src/main/main.ml b/src/main/main.ml index 5795d1e56..e5214bc31 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -1,2 +1,3 @@ module Run = Run module Compile = Compile +module Display = Display diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 22e3d7026..8937fd83f 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -18,6 +18,7 @@ let run_typed_program let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value + let evaluate_typed_program_entry ?options (program : Ast_typed.program) (entry : string) @@ -25,7 +26,7 @@ let evaluate_typed_program_entry let%bind code = Compile.Of_typed.compile_expression_entry program entry in let%bind input = let fake_input = Ast_typed.(e_a_unit Environment.full_empty) in - Compile.Of_typed.compile_expression fake_input + in let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value diff --git a/src/main/run/run.ml b/src/main/run/run.ml index 10ca5ed1d..2436e3455 100644 --- a/src/main/run/run.ml +++ b/src/main/run/run.ml @@ -1,3 +1,4 @@ +module Of_source = Of_source module Of_typed = Of_typed module Of_simplified = Of_simplified module Of_mini_c = Of_mini_c diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index 1f95166e2..9fffdcb46 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/src/passes/1-parser/pascaligo.ml @@ -4,7 +4,7 @@ module Parser = Parser_pascaligo.Parser module AST = Parser_pascaligo.AST module ParserLog = Parser_pascaligo.ParserLog -let parse_file (source: string) : AST.t result = +let parse_file (source: string) : AST.t result = let pp_input = let prefix = Filename.(source |> basename |> remove_extension) and suffix = ".pp.ligo" diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index 2ee1485bc..6e109d6fd 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -1,10 +1,9 @@ open Trace -open Ligo.Run open Test_helpers let compile_contract_basic () : unit result = let%bind _ = - compile_contract_file "./contracts/dispatch-counter.ligo" "main" (Syntax_name "pascaligo") + Ligo.Compile.Of_source.compile_file_entry "./contracts/dispatch-counter.ligo" "main" (Syntax_name "pascaligo") in ok () diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 135f9b429..7b7b38ae8 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -1,10 +1,9 @@ (* Copyright Coase, Inc 2019 *) open Trace -open Ligo.Run open Test_helpers -let type_file = type_file Pascaligo +let type_file = Ligo.Compile.Of_source.type_file (Syntax_name "pascaligo") let get_program = let s = ref None in diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index 0407c281f..b77c595f5 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -1,11 +1,11 @@ open Trace -open Ligo.Mini_c +open Mini_c open Combinators open Test_helpers let run_entry_int (e:anon_function) (n:int) : int result = let param : value = D_int n in - let%bind result = Main.Run_mini_c.run_entry e (t_int , t_int) param in + let%bind result = Run.Of_mini_c.run_entry e (t_int , t_int) param in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index fb3821f27..2b66de488 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -1,8 +1,7 @@ open Trace -open Ligo.Run open Test_helpers -let type_file = type_file Pascaligo +let type_file = Ligo.Compile.Of_source.type_file (Syntax_name "pascaligo") let get_program = let s = ref None in @@ -45,6 +44,8 @@ let dummy n = @@ range (n + 1) ) +let run_typed = Run.Of_typed.run_entry + let is_empty () : unit result = let%bind program = get_program () in let aux n = diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 781cb3a53..f2dcd21c1 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1,11 +1,10 @@ open Trace -open Ligo.Run open Test_helpers open Ast_simplified.Combinators -let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed Cameligo -let type_file = type_file Pascaligo +let mtype_file ?debug_simplify ?debug_typed = Ligo.Compile.Of_source.type_file ?debug_simplify ?debug_typed (Syntax_name "cameligo") +let type_file = Ligo.Compile.Of_source.type_file (Syntax_name "pascaligo") let type_alias () : unit result = let%bind program = type_file "./contracts/type-alias.ligo" in @@ -184,9 +183,9 @@ let bytes_arithmetic () : unit result = let%bind () = expect_eq program "slice_op" tata at in let%bind () = expect_fail program "slice_op" foo in let%bind () = expect_fail program "slice_op" ba in - let%bind b1 = run_simplityped program "hasherman" foo in + let%bind b1 = Run.Of_simplified.run_typed_program program "hasherman" foo in let%bind () = expect_eq program "hasherman" foo b1 in - let%bind b3 = run_simplityped program "hasherman" foototo in + let%bind b3 = Run.Of_simplified.run_typed_program program "hasherman" foototo in let%bind () = Assert.assert_fail @@ Ast_simplified.Misc.assert_value_eq (b3 , b1) in ok () @@ -577,9 +576,9 @@ let guess_string_mligo () : unit result = let basic_mligo () : unit result = let%bind typed = mtype_file ~debug_simplify:true "./contracts/basic.mligo" in - let%bind result = evaluate_typed "foo" typed in - Ligo.AST_Typed.assert_value_eq - (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result) + let%bind result = Run.Of_typed.evaluate_entry typed "foo" in + Ast_typed.assert_value_eq + (Ast_typed.Combinators.e_a_empty_int (42 + 127), result) let counter_mligo () : unit result = let%bind program = mtype_file "./contracts/counter.mligo" in diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index f1a51a794..8b1bab00b 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -38,7 +38,7 @@ let expect ?options program entry_point input expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in + Ligo.Run.Of_simplified.run_typed_program ?options program entry_point input in expecter result let expect_fail ?options program entry_point input = @@ -49,7 +49,7 @@ let expect_fail ?options program entry_point input = in trace run_error @@ Assert.assert_fail - @@ Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input + @@ Ligo.Run.Of_simplified.run_typed_program ?options program entry_point input let expect_eq ?options program entry_point input expected = @@ -70,7 +70,7 @@ let expect_evaluate program entry_point expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace error @@ - let%bind result = Ligo.Run.evaluate_simplityped ~debug_mini_c:true ~debug_michelson:true program entry_point in + let%bind result = Ligo.Run.Of_simplified.evaluate_typed_program_entry program entry_point in expecter result let expect_eq_evaluate program entry_point expected = diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index b61da4bd0..b22fb01db 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -1,10 +1,10 @@ open Trace -open Ligo.AST_Simplified +open Ast_simplified open Test_helpers -module Typed = Ligo.AST_Typed -module Typer = Ligo.Typer -module Simplified = Ligo.AST_Simplified +module Typed = Ast_typed +module Typer = Typer +module Simplified = Ast_simplified let int () : unit result = let open Combinators in diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml index fbcf2b7ee..683169ee2 100644 --- a/src/test/vote_tests.ml +++ b/src/test/vote_tests.ml @@ -1,13 +1,14 @@ open Trace -open Ligo.Run open Test_helpers +let type_file = Ligo.Compile.Of_source.type_file (Syntax_name "cameligo") + let get_program = let s = ref None in fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = type_file Cameligo "./contracts/vote.mligo" in + let%bind program = type_file "./contracts/vote.mligo" in s := Some program ; ok program ) @@ -39,7 +40,7 @@ let vote str = let init_vote () = let%bind program = get_program () in - let%bind result = Ligo.Run.run_simplityped program "main" (e_pair (vote "Yes") (init_storage "basic")) in + let%bind result = Ligo.Run.Of_simplified.run_typed_program program "main" (e_pair (vote "Yes") (init_storage "basic")) in let%bind (_ , storage) = extract_pair result in let%bind storage' = extract_record storage in let votes = List.assoc "candidates" storage' in diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 9037b0e9e..67ee96331 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -5,7 +5,6 @@ let rec remove n = function | _ :: tl when n = 0 -> tl | hd :: tl -> hd :: remove (n - 1) tl - let map ?(acc = []) f lst = let rec aux acc f = function | [] -> acc From 015e1971839c7c77e3102413bd781c91308c881c Mon Sep 17 00:00:00 2001 From: galfour Date: Thu, 19 Sep 2019 01:34:37 +0200 Subject: [PATCH 08/53] back on track --- src/bin/cli.ml | 2 +- src/main/compile/of_mini_c.ml | 30 +++- src/main/compile/of_simplified.ml | 14 +- src/main/compile/of_source.ml | 7 +- src/main/compile/of_typed.ml | 138 +++--------------- src/main/run/of_michelson.ml | 14 +- src/main/run/of_mini_c.ml | 52 +++---- src/main/run/of_simplified.ml | 9 +- src/main/run/of_source.ml | 2 +- src/main/run/of_typed.ml | 10 +- src/passes/6-transpiler/transpiler.ml | 14 +- src/passes/8-compiler/compiler_program.ml | 4 +- src/stages/ast_typed/combinators.ml | 5 + src/stages/ast_typed/misc.ml | 27 ++++ src/stages/ast_typed/types.ml | 20 --- src/stages/mini_c/PP.ml | 4 +- src/stages/mini_c/combinators.ml | 36 +++-- src/stages/mini_c/mini_c.ml | 1 + src/stages/mini_c/misc.ml | 93 ++++++++++++ src/stages/mini_c/types.ml | 3 +- src/test/compiler_tests.ml | 12 +- vendors/ligo-utils/tezos-utils/x_michelson.ml | 4 +- 22 files changed, 276 insertions(+), 225 deletions(-) create mode 100644 src/stages/mini_c/misc.ml diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 29fa6247c..8d051dd83 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -51,7 +51,7 @@ let compile_file = let%bind contract = trace (simple_info "compiling contract to michelson") @@ Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp contract ; + Format.printf "%a\n" Tezos_utils.Michelson.pp contract.body ; ok () in let term = diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index ffd31b259..b8d685975 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -5,11 +5,35 @@ open Tezos_utils let compile_value : value -> type_value -> Michelson.t result = Compiler.Program.translate_value -let compile_expression : expression -> Michelson.t result = fun e -> +let compile_expression : expression -> _ result = fun e -> Compiler.Program.translate_expression e Compiler.Environment.empty -let compile_function : anon_function -> type_value -> type_value -> Compiler.Program.compiled_program result = fun f in_ty out_ty -> - Compiler.Program.translate_entry f (in_ty , out_ty) +let compile_expression_as_function : expression -> _ result = fun e -> + let (input , output) = t_unit , e.type_value in + let%bind body = get_function e in + let%bind body = compile_value body (t_function input output) in + let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in + let open! Compiler.Program in + ok { input ; output ; body } + +let compile_function = fun e -> + let%bind (input , output) = get_t_function e.type_value in + let%bind body = get_function e in + let%bind body = compile_value body (t_function input output) in + let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in + let open! Compiler.Program in + ok { input ; output ; body } + +(* let compile_function : anon_function -> (type_value * type_value) -> Compiler.Program.compiled_program result = fun f io -> + * Compiler.Program.translate_entry f io *) + +let compile_expression_as_function_entry = fun program name -> + let%bind aggregated = aggregate_entry program name true in + compile_function aggregated + +let compile_function_entry = fun program name -> + let%bind aggregated = aggregate_entry program name false in + compile_function aggregated let uncompile_value : Proto_alpha_utils.Memory_proto_alpha.X.ex_typed_value -> value result = fun x -> Compiler.Uncompiler.translate_value x diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index f6c4500ac..1e2a11ca9 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -2,13 +2,13 @@ open Ast_simplified open Trace open Tezos_utils -let compile_function_entry (program : program) entry_point : Compiler.Program.compiled_program result = - let%bind typed_program = Typer.type_program program in - Of_typed.compile_function_entry typed_program entry_point +let compile_function_entry (program : program) entry_point : _ result = + let%bind prog_typed = Typer.type_program program in + Of_typed.compile_function_entry prog_typed entry_point -let compile_expression_entry (program : program) entry_point : Compiler.Program.compiled_program result = +let compile_expression_as_function_entry (program : program) entry_point : _ result = let%bind typed_program = Typer.type_program program in - Of_typed.compile_expression_entry typed_program entry_point + Of_typed.compile_expression_as_function_entry typed_program entry_point let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = let%bind typed = Typer.type_expression env ae in @@ -16,7 +16,7 @@ let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson. let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let%bind output_type = - let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in + let%bind entry_expression = Ast_typed.get_entry program entry in ok entry_expression.type_annotation in let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in @@ -24,7 +24,7 @@ let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let uncompile_typed_program_entry_function_result program entry ex_ty_value = let%bind output_type = - let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in + let%bind entry_expression = Ast_typed.get_entry program entry in let%bind (_ , output_type) = Ast_typed.get_t_function entry_expression.type_annotation in ok output_type in diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 15134ee93..fd0b93dc7 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -7,16 +7,15 @@ let parse_file_program source_filename syntax = let%bind simplified = parsify syntax source_filename in ok simplified -let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compiled_program result = +let compile_file_entry : string -> string -> s_syntax -> _ result = fun source_filename entry_point syntax -> let%bind simplified = parse_file_program source_filename syntax in Of_simplified.compile_function_entry simplified entry_point -let compile_file_contract_entry : string -> string -> s_syntax -> Michelson.t result = +let compile_file_contract_entry : string -> string -> s_syntax -> _ result = fun source_filename entry_point syntax -> let%bind simplified = parse_file_program source_filename syntax in - let%bind f = Of_simplified.compile_function_entry simplified entry_point in - ok f.body + Of_simplified.compile_function_entry simplified entry_point let compile_file_contract_parameter : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 962543444..a8855e904 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -2,37 +2,21 @@ open Trace open Ast_typed open Tezos_utils -module Errors = struct - - let missing_entry_point name = - let title () = "missing entry point" in - let content () = "no entry point with the given name" in - let data = [ - ("name" , fun () -> name) ; - ] in - error ~data title content - - let not_functional_main location = - let title () = "not functional main" in - let content () = "main should be a function" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title content - -end - -(* - This converts `expr` in `fun () -> expr`. -*) -let functionalize (body : annotated_expression) : annotated_expression = - let expression = E_lambda { binder = "_" ; body } in - let type_annotation = t_function (t_unit ()) body.type_annotation () in - { body with expression ; type_annotation } let compile_expression : annotated_expression -> Michelson.t result = fun e -> let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in - Of_mini_c.compile_expression mini_c_expression + let%bind expr = Of_mini_c.compile_expression mini_c_expression in + ok expr + +let compile_expression_as_function : annotated_expression -> _ result = fun e -> + let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in + let%bind expr = Of_mini_c.compile_expression_as_function mini_c_expression in + ok expr + +let compile_function : annotated_expression -> _ result = fun e -> + let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in + let%bind expr = Of_mini_c.compile_function mini_c_expression in + ok expr (* val compile_value : annotated_expression -> Michelson.t result @@ -40,102 +24,22 @@ let compile_expression : annotated_expression -> Michelson.t result = fun e -> `transpile_expression_as_value : annotated_expression -> Mini_c.value result` *) -let compile_function expr = - let%bind l = get_lambda expr.expression in - let%bind io = get_t_function expr.type_annotation in - let%bind mini_c = Transpiler.transpile_lambda Mini_c.Environment.empty l io in - let%bind (f , (in_ty , out_ty)) = - match (mini_c.content , mini_c.type_value) with - | E_literal (D_function f) , T_function ty -> ok (f , ty) - | _ -> fail @@ Errors.not_functional_main expr.location - in - Of_mini_c.compile_function f in_ty out_ty - - -let get_entry (lst : program) (name : string) : (annotated_expression * int) result = - let%bind entry_expression = - trace_option (Errors.missing_entry_point name) @@ - let aux x = - let (Declaration_constant (an , _)) = Location.unwrap x in - if (an.name = name) - then Some an.annotated_expression - else None - in - List.find_map aux lst - in - let entry_index = - let aux x = - let (Declaration_constant (an , _)) = Location.unwrap x in - an.name = name - in - List.find_index aux lst - in - ok (entry_expression , entry_index) - -(* - Assume the following code: - ``` - const x = 42 - const y = 120 - const z = 423 - const f = () -> x + y - ``` - It is transformed in: - ``` - const f = () -> - let x = 42 in - let y = 120 in - let z = 423 in - x + y - ``` - - The entry-point can be an expression, which is then functionalized if - `to_functionalize` is set to true. -*) -let get_aggregated_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result = - let%bind (entry_expression , entry_index) = get_entry lst name in - let pre_declarations = - let sub_program = List.until entry_index lst in - let aux x = Location.unwrap x in - List.map aux sub_program - in - let wrapper = - let aux prec cur = - let (Declaration_constant (an , (pre_env , _))) = cur in - e_a_let_in an.name an.annotated_expression prec pre_env - in - fun expr -> List.fold_right' aux expr pre_declarations - in - match (entry_expression.expression , to_functionalize) with - | (E_lambda l , false) -> ( - let l' = { l with body = wrapper l.body } in - let e' = { entry_expression with expression = E_lambda l' } in - ok e' - ) - | (_ , true) -> ( - ok @@ functionalize @@ wrapper entry_expression - ) - | _ -> fail @@ Errors.not_functional_main entry_expression.location - let compile_function_entry : program -> string -> _ = fun p entry -> - let%bind expr = get_aggregated_entry p entry false in - compile_function expr + let%bind prog_mini_c = Transpiler.transpile_program p in + Of_mini_c.compile_function_entry prog_mini_c entry -let compile_expression_entry : program -> string -> _ = fun p entry -> - let%bind expr = get_aggregated_entry p entry true in - compile_function expr - -let compile_expression_as_function : annotated_expression -> Compiler.Program.compiled_program result = fun e -> - let expr = functionalize e in - compile_function expr +let compile_expression_as_function_entry : program -> string -> _ = fun p entry -> + let%bind prog_mini_c = Transpiler.transpile_program p in + Of_mini_c.compile_expression_as_function_entry prog_mini_c entry let uncompile_value : _ -> _ -> annotated_expression result = fun x ty -> let%bind mini_c = Of_mini_c.uncompile_value x in - Transpiler.untranspile mini_c ty + let%bind typed = Transpiler.untranspile mini_c ty in + ok typed let uncompile_entry_function_result = fun program entry ex_ty_value -> let%bind output_type = - let%bind (entry_expression , _ ) = get_entry program entry in + let%bind entry_expression = get_entry program entry in let%bind (_ , output_type) = get_t_function entry_expression.type_annotation in ok output_type in @@ -143,7 +47,7 @@ let uncompile_entry_function_result = fun program entry ex_ty_value -> let uncompile_entry_expression_result = fun program entry ex_ty_value -> let%bind output_type = - let%bind (entry_expression , _ ) = get_entry program entry in + let%bind entry_expression = get_entry program entry in ok entry_expression.type_annotation in uncompile_value ex_ty_value output_type diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index f34cb2333..4eb9d9c9a 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -13,7 +13,17 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t let%bind input = Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ Memory_proto_alpha.parse_michelson_data input_michelson input_ty in - let body = Michelson.strip_annots body in + let body = Michelson.(strip_nops @@ strip_annots body) in + + let%bind input_ty_mich = + Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ + Memory_proto_alpha.unparse_michelson_ty input_ty in + let%bind output_ty_mich = + Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ + Memory_proto_alpha.unparse_michelson_ty output_ty in + Format.printf "code: %a\n" Michelson.pp program.body ; + Format.printf "input: %a\n" Michelson.pp input_ty_mich ; + Format.printf "output: %a\n" Michelson.pp output_ty_mich ; let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Memory_proto_alpha.parse_michelson body @@ -23,3 +33,5 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t Trace.trace_tzresult_lwt (simple_error "error of execution") @@ Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) + +let evaluate ?options program = run ?options program Michelson.d_unit diff --git a/src/main/run/of_mini_c.ml b/src/main/run/of_mini_c.ml index 8e22c8a54..0fecd02bb 100644 --- a/src/main/run/of_mini_c.ml +++ b/src/main/run/of_mini_c.ml @@ -2,7 +2,7 @@ open Proto_alpha_utils open Memory_proto_alpha.X open Trace open Mini_c -open Compiler.Program +open! Compiler.Program module Errors = struct @@ -19,27 +19,29 @@ type options = { michelson_options : Of_michelson.options ; } -let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result = - let%bind compiled = - trace Errors.entry_error @@ - translate_entry entry ty in - let%bind input_michelson = translate_value input (fst ty) in - if debug_michelson then ( - Format.printf "Program: %a\n" Michelson.pp compiled.body ; - Format.printf "Expression: %a\n" PP.expression entry.result ; - Format.printf "Input: %a\n" PP.value input ; - Format.printf "Input Type: %a\n" PP.type_ (fst ty) ; - Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; - ) ; - let%bind ex_ty_value = Of_michelson.run ?options compiled input_michelson in - if debug_michelson then ( - let (Ex_typed_value (ty , v)) = ex_ty_value in - ignore @@ - let%bind michelson_value = - trace_tzresult_lwt (simple_error "debugging run_mini_c") @@ - Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in - Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; - ok () - ) ; - let%bind (result : value) = Compile.Of_mini_c.uncompile_value ex_ty_value in - ok result +let evaluate ?options expression = + let%bind code = Compile.Of_mini_c.compile_expression_as_function expression in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in + Compile.Of_mini_c.uncompile_value ex_ty_value + +let evaluate_entry ?options program entry = + let%bind code = Compile.Of_mini_c.compile_expression_as_function_entry program entry in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in + Compile.Of_mini_c.uncompile_value ex_ty_value + +let run_function ?options expression input ty = + let%bind code = Compile.Of_mini_c.compile_function expression in + let%bind input = Compile.Of_mini_c.compile_value input ty in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_mini_c.uncompile_value ex_ty_value + +let run_function_entry ?options program entry input = + let%bind code = Compile.Of_mini_c.compile_function_entry program entry in + let%bind input_michelson = + let%bind code = Compile.Of_mini_c.compile_expression_as_function input in + let%bind (Ex_typed_value (ty , value)) = Of_michelson.evaluate ?options code in + Trace.trace_tzresult_lwt (simple_error "error unparsing input") @@ + Memory_proto_alpha.unparse_michelson_data ty value + in + let%bind ex_ty_value = Of_michelson.run ?options code input_michelson in + Compile.Of_mini_c.uncompile_value ex_ty_value diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 8937fd83f..4332ca9e5 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -18,15 +18,10 @@ let run_typed_program let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value - let evaluate_typed_program_entry ?options (program : Ast_typed.program) (entry : string) : Ast_simplified.expression result = - let%bind code = Compile.Of_typed.compile_expression_entry program entry in - let%bind input = - let fake_input = Ast_typed.(e_a_unit Environment.full_empty) in - - in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index 55a455f9e..5bc8b421c 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -76,7 +76,7 @@ let run_function ?amount source_filename entry_point input syntax = let evaluate ?amount source_filename entry_point syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in - let%bind code = Compile.Of_typed.compile_expression_entry program entry_point in + let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry_point in let%bind input = let fake_input = Ast_simplified.e_unit () in Compile.Of_simplified.compile_expression fake_input diff --git a/src/main/run/of_typed.ml b/src/main/run/of_typed.ml index a7bbcb88c..a645250cc 100644 --- a/src/main/run/of_typed.ml +++ b/src/main/run/of_typed.ml @@ -21,14 +21,10 @@ let run_entry let evaluate ?options (e : annotated_expression) : annotated_expression result = let%bind code = Compile.Of_typed.compile_expression_as_function e in - let fake_input = e_a_unit Environment.full_empty in - let%bind input = Compile.Of_typed.compile_expression fake_input in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in Compile.Of_typed.uncompile_value ex_ty_value e.type_annotation let evaluate_entry ?options program entry = - let%bind code = Compile.Of_typed.compile_expression_entry program entry in - let fake_input = e_a_unit Environment.full_empty in - let%bind input = Compile.Of_typed.compile_expression fake_input in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in Compile.Of_typed.uncompile_entry_expression_result program entry ex_ty_value diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index ef8d562c4..df99e3b4b 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -313,7 +313,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind f' = match f.expression with | E_lambda l -> ( let%bind body' = transpile_annotated_expression l.body in - let%bind (input , _) = get_t_function f.type_annotation in + let%bind (input , _) = AST.get_t_function f.type_annotation in let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) @@ -326,7 +326,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re match f.expression with | E_lambda l -> ( let%bind body' = transpile_annotated_expression l.body in - let%bind (input , _) = get_t_function f.type_annotation in + let%bind (input , _) = AST.get_t_function f.type_annotation in let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) @@ -357,7 +357,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind env = trace_strong (corner_case ~loc:__LOC__ "environment") @@ transpile_environment ae.environment in - let%bind io = get_t_function ae.type_annotation in + let%bind io = AST.get_t_function ae.type_annotation in transpile_lambda env l io | E_list lst -> ( let%bind t = @@ -513,8 +513,8 @@ and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.ex let%bind (f_expr' , input_tv , output_tv) = let%bind raw_input = transpile_type input_type in let%bind output = transpile_type output_type in - let%bind result = transpile_annotated_expression body in - let expr' = E_closure { binder ; result } in + let%bind body = transpile_annotated_expression body in + let expr' = E_closure { binder ; body } in ok (expr' , raw_input , output) in let tv = Mini_c.t_deep_closure c_env input_tv output_tv in ok @@ Expression.make_tpl (f_expr' , tv) @@ -529,7 +529,7 @@ and transpile_lambda env l (input_type , output_type) = let%bind input = transpile_type input_type in let%bind output = transpile_type output_type in let tv = Combinators.t_function input output in - let content = D_function { binder ; result = result'} in + let content = D_function { binder ; body = result'} in ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( @@ -545,7 +545,7 @@ let transpile_declaration env (d:AST.declaration) : toplevel_statement result = let env' = Environment.add (name, tv) env in ok @@ ((name, expression), environment_wrap env env') -let transpile_program (lst:AST.program) : program result = +let transpile_program (lst : AST.program) : program result = let aux (prev:(toplevel_statement list * Environment.t) result) cur = let%bind (tl, env) = prev in let%bind ((_, env') as cur') = transpile_declaration env cur in diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index a06fc2a6e..1e7ff7d51 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -361,10 +361,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result ] ) -and translate_function_body ({result ; binder} : anon_function) lst input : michelson result = +and translate_function_body ({body ; binder} : anon_function) lst input : michelson result = let pre_env = Environment.of_list lst in let env = Environment.(add (binder , input) pre_env) in - let%bind expr_code = translate_expression result env in + let%bind expr_code = translate_expression body env in let%bind unpack_closure_code = Compiler_environment.unpack_closure pre_env in let code = seq [ i_comment "unpack closure env" ; diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 6b2358c28..f0ae6f648 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -60,6 +60,11 @@ let get_lambda e : _ result = match e with | E_lambda l -> ok l | _ -> simple_fail "not a lambda" +let get_lambda_with_type e = + match (e.expression , e.type_annotation.type_value') with + | E_lambda l , T_function io -> ok (l , io) + | _ -> simple_fail "not a lambda with functional type" + let get_t_bool (t:type_value) : unit result = match t.type_value' with | T_constant ("bool", []) -> ok () | _ -> simple_fail "not a bool" diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index a71ff3fae..c13200c9a 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -125,6 +125,23 @@ module Errors = struct ("missing_key" , fun () -> Format.asprintf "%s" k) ] in error ~data title message () + + let missing_entry_point name = + let title () = "missing entry point" in + let content () = "no entry point with the given name" in + let data = [ + ("name" , fun () -> name) ; + ] in + error ~data title content + + let not_functional_main location = + let title () = "not functional main" in + let content () = "main should be a function" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title content + end module Free_variables = struct @@ -473,3 +490,13 @@ let merge_annotation (a:type_value option) (b:type_value option) err : type_valu match a.simplified, b.simplified with | _, None -> ok a | _, Some _ -> ok b + +let get_entry (lst : program) (name : string) : annotated_expression result = + trace_option (Errors.missing_entry_point name) @@ + let aux x = + let (Declaration_constant (an , _)) = Location.unwrap x in + if (an.name = name) + then Some an.annotated_expression + else None + in + List.find_map aux lst diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 6fe7f921e..f7ef1595f 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -148,23 +148,3 @@ and 'a matching = | Match_variant of (((constructor_name * name) * 'a) list * type_value) and matching_expr = ae matching - -open Trace - -let get_entry (p:program) (entry : string) : annotated_expression result = - let aux (d:declaration) = - match d with - | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression - | Declaration_constant _ -> None - in - let%bind result = - trace_option (simple_error "no entry point with given name") @@ - List.find_map aux (List.map Location.unwrap p) in - ok result - -let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result = - let%bind entry = get_entry p entry in - match entry.expression with - | E_lambda l -> ok (l , entry.type_annotation) - | _ -> simple_fail "given entry point is not functional" - diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 13fb005fc..f2527d27b 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -100,10 +100,10 @@ and expression_with_type : _ -> expression -> _ = fun ppf e -> expression' e.content type_ e.type_value -and function_ ppf ({binder ; result}:anon_function) = +and function_ ppf ({binder ; body}:anon_function) = fprintf ppf "fun %s -> (%a)" binder - expression result + expression body and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index 9e8467207..e9090a9d8 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -7,18 +7,15 @@ module Expression = struct let get_content : t -> t' = fun e -> e.content let get_type : t -> type_value = fun e -> e.type_value - let is_toplevel : t -> bool = fun e -> e.is_toplevel - let make = fun ?(itl = false) e' t -> { + let make = fun e' t -> { content = e' ; type_value = t ; - is_toplevel = itl ; } - let make_tpl = fun ?(itl = false) (e' , t) -> { + let make_tpl = fun (e' , t) -> { content = e' ; type_value = t ; - is_toplevel = itl ; } let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ]) @@ -70,6 +67,20 @@ let get_set (v:value) = match v with | D_set lst -> ok lst | _ -> simple_fail "not a set" +let get_function_with_ty (e : expression) = + match (e.content , e.type_value) with + | E_literal (D_function f) , T_function ty -> ok (f , ty) + | _ -> simple_fail "not a function with functional type" + +let get_function (e : expression) = + match (e.content) with + | E_literal (D_function f) -> ok (D_function f) + | _ -> simple_fail "not a function" + +let get_t_function tv = match tv with + | T_function ty -> ok ty + | _ -> simple_fail "not a function" + let get_t_option (v:type_value) = match v with | T_option t -> ok t | _ -> simple_fail "not an option" @@ -146,10 +157,10 @@ let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z ) let t_pair x y : type_value = T_pair ( x , y ) let t_union x y : type_value = T_or ( x , y ) -let quote binder result : anon_function = +let quote binder body : anon_function = { binder ; - result ; + body ; } @@ -157,7 +168,7 @@ let e_int expr : expression = Expression.make_tpl (expr, t_int) let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit) let e_skip : expression = Expression.make_tpl (E_skip, t_unit) let e_var_int name : expression = e_int (E_variable name) -let e_let_int v tv expr body : expression = Expression.(make_tpl ( +let e_let_in v tv expr body : expression = Expression.(make_tpl ( E_let_in ((v , tv) , expr , body) , get_type body )) @@ -166,11 +177,12 @@ let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl let d_unit : value = D_unit -let basic_quote expr : anon_function result = - ok @@ quote "input" expr +let basic_quote expr in_ty out_ty : expression result = + let expr' = E_literal (D_function (quote "input" expr)) in + ok @@ Expression.make_tpl (expr' , t_function in_ty out_ty) -let basic_int_quote expr : anon_function result = - basic_quote expr +let basic_int_quote expr : expression result = + basic_quote expr t_int t_int let environment_wrap pre_environment post_environment = { pre_environment ; post_environment } diff --git a/src/stages/mini_c/mini_c.ml b/src/stages/mini_c/mini_c.ml index 5f4e9f5a2..891f746d7 100644 --- a/src/stages/mini_c/mini_c.ml +++ b/src/stages/mini_c/mini_c.ml @@ -8,3 +8,4 @@ module Combinators = struct end include Combinators module Environment = Environment +include Misc diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml new file mode 100644 index 000000000..7fa6a9779 --- /dev/null +++ b/src/stages/mini_c/misc.ml @@ -0,0 +1,93 @@ +open Types +open Combinators +open Trace + +module Errors = struct + + let missing_entry_point name = + let title () = "missing entry point" in + let content () = "no entry point with the given name" in + let data = [ + ("name" , fun () -> name) ; + ] in + error ~data title content + + let not_functional_main name = + let title () = "not functional main" in + let content () = "main should be a function" in + let data = [ + ("name" , fun () -> Format.asprintf "%s" name) ; + ] in + error ~data title content + +end + +(* + Converts `expr` in `fun () -> expr`. +*) +let functionalize (body : expression) : expression = + let content = E_literal (D_function { binder = "_" ; body }) in + let type_value = t_function t_unit body.type_value in + { content ; type_value } + +let get_entry (lst : program) (name : string) : (expression * int) result = + let%bind entry_expression = + trace_option (Errors.missing_entry_point name) @@ + let aux x = + let (((decl_name , decl_expr) , _)) = x in + if (decl_name = name) + then Some decl_expr + else None + in + List.find_map aux lst + in + let entry_index = + let aux x = + let (((decl_name , _) , _)) = x in + decl_name = name + in + List.find_index aux lst + in + ok (entry_expression , entry_index) + + +(* + Assume the following code: + ``` + const x = 42 + const y = 120 + const z = 423 + const f = () -> x + y + ``` + It is transformed in: + ``` + const f = () -> + let x = 42 in + let y = 120 in + let z = 423 in + x + y + ``` + + The entry-point can be an expression, which is then functionalized if + `to_functionalize` is set to true. +*) +let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) : expression result = + let%bind (entry_expression , entry_index) = get_entry lst name in + let pre_declarations = List.until entry_index lst in + let wrapper = + let aux prec cur = + let (((name , expr) , _)) = cur in + e_let_in name expr.type_value expr prec + in + fun expr -> List.fold_right' aux expr pre_declarations + in + match (entry_expression.content , to_functionalize) with + | (E_literal (D_function l) , false) -> ( + let l' = { l with body = wrapper l.body } in + let e' = { entry_expression with content = E_literal (D_function l') } in + ok e' + ) + | (_ , true) -> ( + ok @@ functionalize @@ wrapper entry_expression + ) + | _ -> fail @@ Errors.not_functional_main name diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index fd0ddd021..d3b6bcf36 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -78,7 +78,6 @@ and expression' = and expression = { content : expression' ; type_value : type_value ; - is_toplevel : bool ; } and assignment = var_name * expression @@ -87,7 +86,7 @@ and toplevel_statement = assignment * environment_wrap and anon_function = { binder : string ; - result : expression ; + body : expression ; } and program = toplevel_statement list diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index b77c595f5..dd18c53f2 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -3,9 +3,9 @@ open Mini_c open Combinators open Test_helpers -let run_entry_int (e:anon_function) (n:int) : int result = +let run_entry_int e (n:int) : int result = let param : value = D_int n in - let%bind result = Run.Of_mini_c.run_entry e (t_int , t_int) param in + let%bind result = Run.Of_mini_c.run_function e param t_int in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" @@ -18,10 +18,10 @@ let identity () : unit result = let multiple_vars () : unit result = let expr = - e_let_int "a" t_int (e_var_int "input") @@ - e_let_int "b" t_int (e_var_int "input") @@ - e_let_int "c" t_int (e_var_int "a") @@ - e_let_int "output" t_int (e_var_int "c") @@ + e_let_in "a" t_int (e_var_int "input") @@ + e_let_in "b" t_int (e_var_int "input") @@ + e_let_in "c" t_int (e_var_int "a") @@ + e_let_in "output" t_int (e_var_int "c") @@ e_var_int "output" in let%bind f = basic_int_quote expr in let%bind result = run_entry_int f 42 in diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 6bb8e6203..88684549e 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -15,7 +15,6 @@ let annotate annot = function let seq s : michelson = Seq (0, s) -let i_comment s : michelson = seq [ prim ~annot:["\"" ^ s ^ "\""] I_UNIT ; prim I_DROP ] let contract parameter storage code = seq [ @@ -45,6 +44,9 @@ let i_piar = seq [ i_swap ; i_pair ] let i_push ty code = prim ~children:[ty;code] I_PUSH let i_push_unit = i_push t_unit d_unit let i_push_string str = i_push t_string (string str) + +let i_comment s : michelson = seq [ i_push_string s ; prim I_DROP ] + let i_none ty = prim ~children:[ty] I_NONE let i_nil ty = prim ~children:[ty] I_NIL let i_empty_set ty = prim ~children:[ty] I_EMPTY_SET From 6fe48ff6ad8b4f571340e22d75ef800daf832866 Mon Sep 17 00:00:00 2001 From: galfour Date: Thu, 19 Sep 2019 08:29:31 +0200 Subject: [PATCH 09/53] more working --- src/main/run/of_michelson.ml | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 4eb9d9c9a..307aa2274 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -6,15 +6,10 @@ open Memory_proto_alpha.X type options = Memory_proto_alpha.options -let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = +let run ?options ?(is_input_value = false) (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = let Compiler.Program.{input;output;body} : compiled_program = program in let (Ex_ty input_ty) = input in let (Ex_ty output_ty) = output in - let%bind input = - Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ - Memory_proto_alpha.parse_michelson_data input_michelson input_ty in - let body = Michelson.(strip_nops @@ strip_annots body) in - let%bind input_ty_mich = Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ Memory_proto_alpha.unparse_michelson_ty input_ty in @@ -22,8 +17,26 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ Memory_proto_alpha.unparse_michelson_ty output_ty in Format.printf "code: %a\n" Michelson.pp program.body ; - Format.printf "input: %a\n" Michelson.pp input_ty_mich ; - Format.printf "output: %a\n" Michelson.pp output_ty_mich ; + Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ; + Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ; + Format.printf "input: %a\n" Michelson.pp input_michelson ; + let%bind input = + if is_input_value then ( + Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ + Memory_proto_alpha.parse_michelson_data input_michelson input_ty + ) else ( + let input_michelson = Michelson.(seq [ input_michelson ; dip i_drop ]) in + let body = Michelson.(strip_nops @@ strip_annots input_michelson) in + let%bind descr = + Trace.trace_tzresult_lwt (simple_error "error parsing input code") @@ + Memory_proto_alpha.parse_michelson body + (Item_t (Memory_proto_alpha.Protocol.Script_typed_ir.Unit_t None, Empty_t, None)) (Item_t (input_ty, Empty_t, None)) in + let%bind (Item(output, Empty)) = + Trace.trace_tzresult_lwt (simple_error "input error of execution") @@ + Memory_proto_alpha.interpret ?options descr (Item((), Empty)) in + ok output + ) in + let body = Michelson.(strip_nops @@ strip_annots body) in let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Memory_proto_alpha.parse_michelson body @@ -34,4 +47,4 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let evaluate ?options program = run ?options program Michelson.d_unit +let evaluate ?options program = run ?options ~is_input_value:true program Michelson.d_unit From e3179bd7c7eeacf461a9c3fc365581a45c5a0035 Mon Sep 17 00:00:00 2001 From: galfour Date: Thu, 19 Sep 2019 12:59:07 +0200 Subject: [PATCH 10/53] tests pass again --- src/main/compile/dune | 1 + src/main/compile/helpers.ml | 8 ++++++-- src/main/run/of_mini_c.ml | 6 ++++++ src/passes/3-self_ast_simplified/helpers.ml | 11 +++++++++++ .../self_ast_simplified.ml | 3 ++- src/passes/6-transpiler/transpiler.ml | 4 ++-- src/stages/mini_c/PP.ml | 2 +- src/stages/mini_c/combinators.ml | 4 ++++ src/stages/mini_c/misc.ml | 17 ++++++++++++++++- src/stages/mini_c/types.ml | 2 +- src/test/compiler_tests.ml | 2 +- src/test/contracts/annotation.ligo | 4 +--- src/test/integration_tests.ml | 10 +++++++--- 13 files changed, 59 insertions(+), 15 deletions(-) diff --git a/src/main/compile/dune b/src/main/compile/dune index bd1ac2d33..e8520e473 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -7,6 +7,7 @@ parser simplify ast_simplified + self_ast_simplified typer ast_typed transpiler diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 5e47665a4..054c9e00d 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -62,11 +62,15 @@ let parsify = fun (syntax : v_syntax) source_filename -> | Pascaligo -> ok parsify_pascaligo | Cameligo -> ok parsify_ligodity in - parsify source_filename + let%bind parsified = parsify source_filename in + let%bind applied = Self_ast_simplified.convert_annotation_program parsified in + ok applied let parsify_expression = fun syntax source -> let%bind parsify = match syntax with | Pascaligo -> ok parsify_expression_pascaligo | Cameligo -> ok parsify_expression_ligodity in - parsify source + let%bind parsified = parsify source in + let%bind applied = Self_ast_simplified.convert_annotation_expression parsified in + ok applied diff --git a/src/main/run/of_mini_c.ml b/src/main/run/of_mini_c.ml index 0fecd02bb..dbe02bf08 100644 --- a/src/main/run/of_mini_c.ml +++ b/src/main/run/of_mini_c.ml @@ -35,6 +35,12 @@ let run_function ?options expression input ty = let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_mini_c.uncompile_value ex_ty_value +let run_function_value ?options expression input ty = + let%bind code = Compile.Of_mini_c.compile_function expression in + let%bind input = Compile.Of_mini_c.compile_value input ty in + let%bind ex_ty_value = Of_michelson.run ~is_input_value:true ?options code input in + Compile.Of_mini_c.uncompile_value ex_ty_value + let run_function_entry ?options program entry input = let%bind code = Compile.Of_mini_c.compile_function_entry program entry in let%bind input_michelson = diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index 8b41248eb..61aa8fcb2 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -125,3 +125,14 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> let%bind lst' = bind_map_list aux lst in ok @@ Match_variant lst' ) + +and map_program : mapper -> program -> program result = fun m p -> + let aux = fun (x : declaration) -> + match x with + | Declaration_constant (t , o , e) -> ( + let%bind e' = map_expression m e in + ok (Declaration_constant (t , o , e')) + ) + | Declaration_type _ -> ok x + in + bind_map_list (bind_map_location aux) p diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index 48ec6fc50..6aafa38a4 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -1 +1,2 @@ -let convert_annotation = Helpers.map_expression Tezos_type_annotation.peephole_expression +let convert_annotation_expression = Helpers.map_expression Tezos_type_annotation.peephole_expression +let convert_annotation_program = Helpers.map_program Tezos_type_annotation.peephole_expression diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index df99e3b4b..8e65cfdb7 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -547,9 +547,9 @@ let transpile_declaration env (d:AST.declaration) : toplevel_statement result = let transpile_program (lst : AST.program) : program result = let aux (prev:(toplevel_statement list * Environment.t) result) cur = - let%bind (tl, env) = prev in + let%bind (hds, env) = prev in let%bind ((_, env') as cur') = transpile_declaration env cur in - ok (cur' :: tl, env'.post_environment) + ok (hds @ [ cur' ], env'.post_environment) in let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index f2527d27b..3bb230627 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -69,7 +69,7 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) -> and expression' ppf (e:expression') = match e with | E_skip -> fprintf ppf "skip" - | E_closure x -> function_ ppf x + | E_closure x -> fprintf ppf "C(%a)" function_ x | E_variable v -> fprintf ppf "V(%s)" v | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index e9090a9d8..f19536e8f 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -81,6 +81,10 @@ let get_t_function tv = match tv with | T_function ty -> ok ty | _ -> simple_fail "not a function" +let get_t_closure tv = match tv with + | T_deep_closure ty -> ok ty + | _ -> simple_fail "not a function" + let get_t_option (v:type_value) = match v with | T_option t -> ok t | _ -> simple_fail "not an option" diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml index 7fa6a9779..21e049e38 100644 --- a/src/stages/mini_c/misc.ml +++ b/src/stages/mini_c/misc.ml @@ -87,7 +87,22 @@ let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) : let e' = { entry_expression with content = E_literal (D_function l') } in ok e' ) + | (E_closure l , false) -> ( + let l' = { l with body = wrapper l.body } in + let%bind t' = + let%bind (_ , input_ty , output_ty) = get_t_closure entry_expression.type_value in + ok (t_function input_ty output_ty) + in + let e' = { + content = E_literal (D_function l') ; + type_value = t' ; + } in + ok e' + ) | (_ , true) -> ( ok @@ functionalize @@ wrapper entry_expression ) - | _ -> fail @@ Errors.not_functional_main name + | _ -> ( + Format.printf "Not functional: %a\n" PP.expression entry_expression ; + fail @@ Errors.not_functional_main name + ) diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index d3b6bcf36..26801d227 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -12,7 +12,7 @@ type type_value = | T_pair of (type_value * type_value) | T_or of type_value * type_value | T_function of (type_value * type_value) - | T_deep_closure of environment * type_value * type_value + | T_deep_closure of (environment * type_value * type_value) | T_base of type_base | T_map of (type_value * type_value) | T_list of type_value diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index dd18c53f2..a93fb2ee7 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -5,7 +5,7 @@ open Test_helpers let run_entry_int e (n:int) : int result = let param : value = D_int n in - let%bind result = Run.Of_mini_c.run_function e param t_int in + let%bind result = Run.Of_mini_c.run_function_value e param t_int in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" diff --git a/src/test/contracts/annotation.ligo b/src/test/contracts/annotation.ligo index 1cae3ffe9..1eaef7b0c 100644 --- a/src/test/contracts/annotation.ligo +++ b/src/test/contracts/annotation.ligo @@ -1,5 +1,3 @@ const lst : list(int) = list [] ; -const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ; - -const address_2 : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; +const address : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index f2dcd21c1..e5b097981 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -28,9 +28,6 @@ let annotation () : unit result = let%bind () = expect_eq_evaluate program "address" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") in - let%bind () = - expect_eq_evaluate program "address_2" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") - in ok () let complex_function () : unit result = @@ -99,14 +96,21 @@ let higher_order () : unit result = let shared_function () : unit result = let%bind program = type_file "./contracts/function-shared.ligo" in + Format.printf "inc\n" ; let%bind () = let make_expect = fun n -> (n + 1) in expect_eq_n_int program "inc" make_expect in + Format.printf "double inc?\n" ; + let%bind () = + expect_eq program "double_inc" (e_int 0) (e_int 2) + in + Format.printf "double incd!\n" ; let%bind () = let make_expect = fun n -> (n + 2) in expect_eq_n_int program "double_inc" make_expect in + Format.printf "foo\n" ; let%bind () = let make_expect = fun n -> (2 * n + 3) in expect_eq program "foo" (e_int 0) (e_int @@ make_expect 0) From 2a90be292c245d83b166844b7c7a727d448f7ac9 Mon Sep 17 00:00:00 2001 From: galfour Date: Fri, 20 Sep 2019 11:59:44 +0200 Subject: [PATCH 11/53] more formats --- src/bin/cli.ml | 62 ++++++++++++++++++++++-------------------- src/bin/cli_helpers.ml | 17 +++++++----- src/main/display.ml | 55 +++++++++++++++++++++++++++++++++---- 3 files changed, 91 insertions(+), 43 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 8d051dd83..4e7897720 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -45,89 +45,91 @@ let amount = info ~docv ~doc ["amount"] in value @@ opt string "0" info +let display_format = + let open Arg in + let info = + let docv = "DISPLAY_FORMAT" in + let doc = "$(docv) is the format that will be used by the CLI. Available formats are 'dev', 'json', and 'human-readable' (default). When human-readable lacks details (we are still tweaking it), please contact us and use another format in the meanwhile." in + info ~docv ~doc ["format" ; "display-format"] in + value @@ opt string "human-readable" info + let compile_file = - let f source entry_point syntax = - toplevel @@ + let f source entry_point syntax display_format = + toplevel ~display_format @@ let%bind contract = trace (simple_info "compiling contract to michelson") @@ Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp contract.body ; - ok () + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp contract.body in let term = - Term.(const f $ source 0 $ entry_point 1 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ syntax $ display_format) in let cmdname = "compile-contract" in let docs = "Subcommand: compile a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let compile_parameter = - let f source entry_point expression syntax = - toplevel @@ + let f source entry_point expression syntax display_format = + toplevel ~display_format @@ let%bind value = trace (simple_error "compile-input") @@ Ligo.Compile.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp value; - ok () + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ display_format) in let cmdname = "compile-parameter" in let docs = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let compile_storage = - let f source entry_point expression syntax = - toplevel @@ + let f source entry_point expression syntax display_format = + toplevel ~display_format @@ let%bind value = trace (simple_error "compile-storage") @@ Ligo.Compile.Of_source.compile_file_contract_storage source entry_point expression (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp value; - ok () + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ display_format) in let cmdname = "compile-storage" in let docs = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let dry_run = - let f source entry_point storage input amount syntax = - toplevel @@ + let f source entry_point storage input amount syntax display_format = + toplevel ~display_format @@ let%bind output = Ligo.Run.Of_source.run_contract ~amount source entry_point storage input (Syntax_name syntax) in - Format.printf "%a\n" Ast_simplified.PP.expression output ; - ok () + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax $ display_format) in let cmdname = "dry-run" in let docs = "Subcommand: run a smart-contract with the given storage and input." in (term , Term.info ~docs cmdname) let run_function = - let f source entry_point parameter amount syntax = - toplevel @@ + let f source entry_point parameter amount syntax display_format = + toplevel ~display_format @@ let%bind output = Ligo.Run.Of_source.run_function ~amount source entry_point parameter (Syntax_name syntax) in - Format.printf "%a\n" Ast_simplified.PP.expression output ; - ok () + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax $ display_format) in let cmdname = "run-function" in let docs = "Subcommand: run a function with the given parameter." in (term , Term.info ~docs cmdname) let evaluate_value = - let f source entry_point amount syntax = - toplevel @@ + let f source entry_point amount syntax display_format = + toplevel ~display_format @@ let%bind output = Ligo.Run.Of_source.evaluate ~amount source entry_point (Syntax_name syntax) in - Format.printf "%a\n" Ast_simplified.PP.expression output ; - ok () + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = - Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in let cmdname = "evaluate-value" in let docs = "Subcommand: evaluate a given definition." in (term , Term.info ~docs cmdname) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index ac0354368..dacac127e 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -1,9 +1,12 @@ open Trace +open Main.Display -let toplevel x = - match x with - | Trace.Ok ((), annotations) -> ignore annotations; () - | Error ss -> ( - Format.printf "%a%!" Main.Display.error_pp (ss ()) - ) - +let toplevel ~(display_format : string) (x : string result) = + let display_format = + try display_format_of_string display_format + with _ -> ( + Format.printf "bad display format %s, try looking at DISPLAY_FORMAT in the man (--help)." display_format ; + failwith "Display format" + ) + in + Format.printf "%a" (formatted_string_result_pp display_format) x diff --git a/src/main/display.ml b/src/main/display.ml index ab35528cb..753da77ec 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -1,8 +1,6 @@ -open Trace +open! Trace -let dev = false - -let rec error_pp out (e : error) = +let rec error_pp ?(dev = false) out (e : error) = let open JSON_string_utils in let message = let opt = e |> member "message" |> string in @@ -50,7 +48,52 @@ let rec error_pp out (e : error) = print "%s%s%s%s%s" location title error_code message data ) else ( print "%s%s%s.\n%s%s\n%a\n%a\n" title error_code message data location - (Format.pp_print_list error_pp) infos - (Format.pp_print_list error_pp) children + (Format.pp_print_list (error_pp ~dev)) infos + (Format.pp_print_list (error_pp ~dev)) children ) +let result_pp_hr f out (r : _ result) = + match r with + | Ok (s , _) -> Format.fprintf out "%a" f s + | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ()) + +let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s" s) + +let result_pp_dev f out (r : _ result) = + match r with + | Ok (s , _) -> Format.fprintf out "%a" f s + | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ()) + +let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s" s) + +let string_result_pp_json out (r : string result) = + let status_json status content : J.t = `Assoc ([ + ("status" , `String status) ; + ("content" , content) ; + ]) in + match r with + | Ok (x , _) -> ( + Format.fprintf out "%a" J.pp (status_json "ok" (`String x)) + ) + | Error e -> ( + Format.fprintf out "%a" J.pp (status_json "error" (e ())) + ) + +type display_format = [ + | `Human_readable + | `Json + | `Dev +] + +let display_format_of_string = fun s : display_format -> + match s with + | "dev" -> `Dev + | "json" -> `Json + | "human-readable" -> `Human_readable + | _ -> failwith "bad display_format" + +let formatted_string_result_pp (display_format : display_format) = + match display_format with + | `Human_readable -> string_result_pp_hr + | `Dev -> string_result_pp_dev + | `Json -> string_result_pp_json From cd645520f72b84a4156b1eea5034a28db5f1f2f0 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Fri, 20 Sep 2019 06:27:20 -0700 Subject: [PATCH 12/53] Fix outdated git repo link on versions page --- gitlab-pages/website/pages/en/versions.js | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/gitlab-pages/website/pages/en/versions.js b/gitlab-pages/website/pages/en/versions.js index 4cc1bd3b5..6abeaa02e 100644 --- a/gitlab-pages/website/pages/en/versions.js +++ b/gitlab-pages/website/pages/en/versions.js @@ -18,15 +18,13 @@ const versions = require(`${CWD}/versions.json`); function Versions(props) { const {config: siteConfig} = props; const latestVersion = versions[0]; - const repoUrl = `https://github.com/${siteConfig.organizationName}/${ - siteConfig.projectName - }`; + const repoUrl = `${siteConfig.repoUrl}`; return (
-

{siteConfig.title} Versions

+

{siteConfig.title} Versions

Current version

From 66efff631dc4c4354dc8133f9a9a877e786f621c Mon Sep 17 00:00:00 2001 From: galfour Date: Fri, 20 Sep 2019 18:56:55 +0200 Subject: [PATCH 13/53] add micheline --- src/bin/cli.ml | 15 ++++- src/main/compile/of_mini_c.ml | 13 ++++ src/main/compile/of_simplified.ml | 4 ++ src/main/compile/of_source.ml | 3 +- src/main/compile/of_typed.ml | 4 ++ src/main/display.ml | 15 +++++ src/test/test_helpers.ml | 4 +- super-counter.pp.ligo | 65 +++++++++++++++++++ vendors/ligo-utils/tezos-utils/x_michelson.ml | 12 ++++ 9 files changed, 129 insertions(+), 6 deletions(-) create mode 100644 super-counter.pp.ligo diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 4e7897720..4cac0fe45 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -53,16 +53,25 @@ let display_format = info ~docv ~doc ["format" ; "display-format"] in value @@ opt string "human-readable" info +let michelson_code_format = + let open Arg in + let info = + let docv = "MICHELSON_FORMAT" in + let doc = "$(docv) is the format that will be used by compile-contract for the resulting Michelson. Available formats are 'micheline', and 'michelson' (default). Micheline is the format used by [XXX]." in + info ~docv ~doc ["michelson-format"] in + value @@ opt string "michelson" info + let compile_file = - let f source entry_point syntax display_format = + let f source entry_point syntax display_format michelson_format = toplevel ~display_format @@ + let%bind michelson_format = Main.Display.michelson_format_of_string michelson_format in let%bind contract = trace (simple_info "compiling contract to michelson") @@ Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in - ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp contract.body + ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract in let term = - Term.(const f $ source 0 $ entry_point 1 $ syntax $ display_format) in + Term.(const f $ source 0 $ entry_point 1 $ syntax $ display_format $ michelson_code_format) in let cmdname = "compile-contract" in let docs = "Subcommand: compile a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index b8d685975..5a1ff886e 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -35,5 +35,18 @@ let compile_function_entry = fun program name -> let%bind aggregated = aggregate_entry program name false in compile_function aggregated +let compile_contract_entry = fun program name -> + let%bind aggregated = aggregate_entry program name false in + let%bind compiled = compile_function aggregated in + let%bind (param_ty , storage_ty) = + let%bind fun_ty = get_t_function aggregated.type_value in + Mini_c.get_t_pair (fst fun_ty) + in + let%bind param_michelson = Compiler.Type.type_ param_ty in + let%bind storage_michelson = Compiler.Type.type_ storage_ty in + let contract = Michelson.contract param_michelson storage_michelson compiled.body in + ok contract + + let uncompile_value : Proto_alpha_utils.Memory_proto_alpha.X.ex_typed_value -> value result = fun x -> Compiler.Uncompiler.translate_value x diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 1e2a11ca9..fa27f3d6e 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -2,6 +2,10 @@ open Ast_simplified open Trace open Tezos_utils +let compile_contract_entry (program : program) entry_point = + let%bind prog_typed = Typer.type_program program in + Of_typed.compile_contract_entry prog_typed entry_point + let compile_function_entry (program : program) entry_point : _ result = let%bind prog_typed = Typer.type_program program in Of_typed.compile_function_entry prog_typed entry_point diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index fd0b93dc7..169dba0da 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -15,7 +15,8 @@ let compile_file_entry : string -> string -> s_syntax -> _ result = let compile_file_contract_entry : string -> string -> s_syntax -> _ result = fun source_filename entry_point syntax -> let%bind simplified = parse_file_program source_filename syntax in - Of_simplified.compile_function_entry simplified entry_point + let%bind compiled_contract = Of_simplified.compile_contract_entry simplified entry_point in + ok compiled_contract let compile_file_contract_parameter : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index a8855e904..e6a33abd7 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -28,6 +28,10 @@ let compile_function_entry : program -> string -> _ = fun p entry -> let%bind prog_mini_c = Transpiler.transpile_program p in Of_mini_c.compile_function_entry prog_mini_c entry +let compile_contract_entry : program -> string -> _ = fun p entry -> + let%bind prog_mini_c = Transpiler.transpile_program p in + Of_mini_c.compile_contract_entry prog_mini_c entry + let compile_expression_as_function_entry : program -> string -> _ = fun p entry -> let%bind prog_mini_c = Transpiler.transpile_program p in Of_mini_c.compile_expression_as_function_entry prog_mini_c entry diff --git a/src/main/display.ml b/src/main/display.ml index 753da77ec..2d24e8008 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -97,3 +97,18 @@ let formatted_string_result_pp (display_format : display_format) = | `Human_readable -> string_result_pp_hr | `Dev -> string_result_pp_dev | `Json -> string_result_pp_json + +type michelson_format = [ + | `Michelson + | `Micheline +] + +let michelson_format_of_string = fun s : michelson_format result -> + match s with + | "michelson" -> ok `Michelson + | "micheline" -> ok `Micheline + | _ -> simple_fail "bad michelson format" + +let michelson_pp (mf : michelson_format) = match mf with + | `Michelson -> Michelson.pp + | `Micheline -> Michelson.pp_json diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 8b1bab00b..96b5522cb 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -12,14 +12,14 @@ let wrap_test name f = match result with | Ok ((), annotations) -> ignore annotations; () | Error err -> - Format.printf "%a\n%!" Ligo.Display.error_pp (err ()) ; + Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ()) ; raise Alcotest.Test_error let wrap_test_raw f = match f () with | Trace.Ok ((), annotations) -> ignore annotations; () | Error err -> - Format.printf "%a\n%!" Ligo.Display.error_pp (err ()) + Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ()) let test name f = Test ( diff --git a/super-counter.pp.ligo b/super-counter.pp.ligo new file mode 100644 index 000000000..0097fbc63 --- /dev/null +++ b/super-counter.pp.ligo @@ -0,0 +1,65 @@ +# 1 "./src/test/contracts/super-counter.ligo" +# 1 "" +# 1 "" +# 31 "" +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +# 32 "" 2 +# 1 "./src/test/contracts/super-counter.ligo" +type action is +| Increment of int +| Decrement of int + +function main (const p : action ; const s : int) : (list(operation) * int) is + block {skip} with ((nil : list(operation)), + case p of + | Increment (n) -> s + n + | Decrement (n) -> s - n + end) diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 88684549e..f55e1a493 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -86,6 +86,18 @@ let pp ppf (michelson:michelson) = let node = printable string_of_prim canonical in print_expr ppf node +let pp_json ppf (michelson : michelson) = + let open Micheline_printer in + let canonical = strip_locations michelson in + let node = printable string_of_prim canonical in + let json = Tezos_data_encoding.( + Json.construct + (Micheline.erased_encoding ~variant:"???" {comment = None} Data_encoding.string) + node + ) + in + Format.fprintf ppf "%a" Tezos_data_encoding.Json.pp json + let pp_stripped ppf (michelson:michelson) = let open Micheline_printer in let michelson' = strip_nops @@ strip_annots michelson in From dc9294bbccaa68529a1e61fd5469b058a777f883 Mon Sep 17 00:00:00 2001 From: galfour Date: Fri, 20 Sep 2019 20:38:04 +0200 Subject: [PATCH 14/53] add options in cameligo --- src/passes/2-simplify/ligodity.ml | 70 +++++++++++++++---- .../3-self_ast_simplified/none_variant.ml | 9 +++ .../self_ast_simplified.ml | 1 + src/test/contracts/option.mligo | 4 ++ src/test/integration_tests.ml | 13 ++++ 5 files changed, 84 insertions(+), 13 deletions(-) create mode 100644 src/passes/3-self_ast_simplified/none_variant.ml create mode 100644 src/test/contracts/option.mligo diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 10a9b346a..3a1fe5132 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -404,6 +404,9 @@ let rec simpl_expression : | "Some" -> ( return @@ e_some ~loc arg ) + | "None" -> ( + return @@ e_none ~loc () + ) | _ -> ( return @@ e_constructor ~loc c_name arg ) @@ -699,6 +702,24 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = ) | _ -> fail @@ only_constructors t in + let rec get_constr_opt (t:Raw.pattern) = + match t with + | PPar p -> get_constr_opt p.value.inside + | PConstr v -> ( + let (const , pat_opt) = v.value in + let%bind var_opt = + match pat_opt with + | None -> ok None + | Some pat -> ( + let%bind single_pat = get_single pat in + let%bind var = get_var single_pat in + ok (Some var) + ) + in + ok (const.value , var_opt) + ) + | _ -> fail @@ only_constructors t + in let%bind patterns = let aux (x , y) = let xs = get_tuple x in @@ -727,21 +748,44 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil} ) | lst -> ( - trace (simple_info "currently, only booleans, lists and constructors \ - are supported in patterns") @@ - let%bind constrs = + let error x = + let title () = "Pattern" in + let content () = + Format.asprintf "Pattern : %a" (PP_helpers.printer Raw.print_pattern) x in + error title content + in + let as_variant () = + trace (simple_info "currently, only booleans, lists, options, and constructors \ + are supported in patterns") @@ + let%bind constrs = + let aux (x , y) = + let%bind x' = + trace (error x) @@ + get_constr x + in + ok (x' , y) + in + bind_map_list aux lst + in + ok @@ Match_variant constrs + in + let as_option () = let aux (x , y) = - let error = - let title () = "Pattern" in - let content () = - Format.asprintf "Pattern : %a" (PP_helpers.printer Raw.print_pattern) x in - error title content in let%bind x' = - trace error @@ - get_constr x in - ok (x' , y) in - bind_map_list aux lst in - ok @@ Match_variant constrs + trace (error x) @@ + get_constr_opt x + in + ok (x' , y) + in + let%bind constrs = bind_map_list aux lst in + match constrs with + | [ (("Some" , Some some_var) , some_expr) ; (("None" , None) , none_expr) ] + | [ (("None" , None) , none_expr) ; (("Some" , Some some_var) , some_expr) ] -> ( + ok @@ Match_option { match_some = (some_var , some_expr) ; match_none = none_expr } + ) + | _ -> simple_fail "bad option pattern" + in + bind_or (as_option () , as_variant ()) ) let simpl_program : Raw.ast -> program result = fun t -> diff --git a/src/passes/3-self_ast_simplified/none_variant.ml b/src/passes/3-self_ast_simplified/none_variant.ml new file mode 100644 index 000000000..d64350a81 --- /dev/null +++ b/src/passes/3-self_ast_simplified/none_variant.ml @@ -0,0 +1,9 @@ +open Ast_simplified +open Trace + +let peephole_expression : expression -> expression result = fun e -> + let return expression = ok { e with expression } in + match e.expression with + | E_constructor ("Some" , e) -> return @@ E_constant ("SOME" , [ e ]) + | E_constructor ("None" , _) -> return @@ E_constant ("NONE" , [ ]) + | e -> return e diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index 6aafa38a4..b3ebb08db 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -1,2 +1,3 @@ let convert_annotation_expression = Helpers.map_expression Tezos_type_annotation.peephole_expression let convert_annotation_program = Helpers.map_program Tezos_type_annotation.peephole_expression +let convert_none_variant_to_const = Helpers.map_program None_variant.peephole_expression diff --git a/src/test/contracts/option.mligo b/src/test/contracts/option.mligo new file mode 100644 index 000000000..034871499 --- /dev/null +++ b/src/test/contracts/option.mligo @@ -0,0 +1,4 @@ +type foobar = int option + +let s : foobar = Some 42 +let n : foobar = None diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 5efcc9fc1..df2b2cb86 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -340,6 +340,18 @@ let option () : unit result = in ok () +let moption () : unit result = + let%bind program = mtype_file "./contracts/option.mligo" in + let%bind () = + let expected = e_some (e_int 42) in + expect_eq_evaluate program "s" expected + in + let%bind () = + let expected = e_typed_none t_int in + expect_eq_evaluate program "n" expected + in + ok () + let map () : unit result = let%bind program = type_file "./contracts/map.ligo" in let ez lst = @@ -692,6 +704,7 @@ let main = test_suite "Integration (End to End)" [ test "unit" unit_expression ; test "string" string_expression ; test "option" option ; + test "option (mligo)" moption ; test "map" map ; test "list" list ; test "loop" loop ; From 4fec6f16243522e3c4b1368e0dbb5fcc2618a80c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 29 Aug 2019 13:12:06 +0200 Subject: [PATCH 15/53] naively connects big_map to the transpiler --- src/contracts/big_map.ligo | 5 +++++ src/transpiler/transpiler.ml | 3 +++ 2 files changed, 8 insertions(+) create mode 100644 src/contracts/big_map.ligo diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo new file mode 100644 index 000000000..2b6f97581 --- /dev/null +++ b/src/contracts/big_map.ligo @@ -0,0 +1,5 @@ +type storage_ is big_map(int, int) * unit + +function main(const p : unit; const s : storage_) : list(operation) * storage_ is + block { skip } + with ((nil : list(operation)), s) \ No newline at end of file diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 7d4db9321..3c8ad1ae3 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -113,6 +113,9 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("map", [key;value]) -> let%bind kv' = bind_map_pair translate_type (key, value) in ok (T_map kv') + | T_constant ("big_map", [key;value] ) -> + let%bind kv' = bind_map_pair translate_type (key, value) in + ok (T_map kv') | T_constant ("list", [t]) -> let%bind t' = translate_type t in ok (T_list t') From 25e3ab8e5d8d49012c914089f9b6492d32e7dfba Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 3 Sep 2019 18:33:30 +0200 Subject: [PATCH 16/53] big map can be looked up --- src/compiler/compiler_type.ml | 8 ++++++++ src/contracts/big_map.ligo | 19 ++++++++++++++++--- src/mini_c/PP.ml | 1 + src/mini_c/types.ml | 1 + src/transpiler/transpiler.ml | 2 +- src/typer/typer.ml | 2 +- vendors/ligo-utils/simple-utils/trace.ml | 2 ++ 7 files changed, 30 insertions(+), 5 deletions(-) diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 4596bd74d..b22a0d2ef 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -70,6 +70,7 @@ module Ty = struct | T_or _ -> fail (not_comparable "or") | T_pair _ -> fail (not_comparable "pair") | T_map _ -> fail (not_comparable "map") + | T_big_map _ -> fail (not_comparable "big_map") | T_list _ -> fail (not_comparable "list") | T_set _ -> fail (not_comparable "set") | T_option _ -> fail (not_comparable "option") @@ -116,6 +117,10 @@ module Ty = struct let%bind (Ex_comparable_ty k') = comparable_type k in let%bind (Ex_ty v') = type_ v in ok @@ Ex_ty (map k' v') + | T_big_map (k, v) -> + let%bind (Ex_comparable_ty k') = comparable_type k in + let%bind (Ex_ty v') = type_ v in + ok @@ Ex_ty (big_map k' v') | T_list t -> let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty (list t') @@ -184,6 +189,9 @@ let rec type_ : type_value -> O.michelson result = | T_map kv -> let%bind (k', v') = bind_map_pair type_ kv in ok @@ O.prim ~children:[k';v'] O.T_map + | T_big_map kv -> + let%bind (k', v') = bind_map_pair type_ kv in + ok @@ O.prim ~children:[k';v'] O.T_big_map | T_list t -> let%bind t' = type_ t in ok @@ O.prim ~children:[t'] O.T_list diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index 2b6f97581..2eb21153e 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -1,5 +1,18 @@ -type storage_ is big_map(int, int) * unit +// type storage_ is big_map(int, int) * unit +type storage_ is big_map(int, int) + +// function main(const p : unit; const s : storage_) : list(operation) * storage_ is +// block { skip } +// with ((nil : list(operation)), s) function main(const p : unit; const s : storage_) : list(operation) * storage_ is - block { skip } - with ((nil : list(operation)), s) \ No newline at end of file + // var r : big_map(int, int) := s.0 ; + var r : big_map(int,int) := s ; + var toto : option (int) := Some(0); + block { + // r[23] := 2; + toto := r[23]; + s := r; + // skip + } + with ((nil: list(operation)), s) \ No newline at end of file diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 13fb005fc..c7eab992d 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -27,6 +27,7 @@ let rec type_ ppf : type_value -> _ = function | T_base b -> type_base ppf b | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v + | T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_ k type_ v | T_list(t) -> fprintf ppf "list(%a)" type_ t | T_set(t) -> fprintf ppf "set(%a)" type_ t | T_option(o) -> fprintf ppf "option(%a)" type_ o diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index fd0ddd021..8be621954 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -15,6 +15,7 @@ type type_value = | T_deep_closure of environment * type_value * type_value | T_base of type_base | T_map of (type_value * type_value) + | T_big_map of (type_value * type_value) | T_list of type_value | T_set of type_value | T_contract of type_value diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 3c8ad1ae3..a2119fe19 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -115,7 +115,7 @@ let rec translate_type (t:AST.type_value) : type_value result = ok (T_map kv') | T_constant ("big_map", [key;value] ) -> let%bind kv' = bind_map_pair translate_type (key, value) in - ok (T_map kv') + ok (T_big_map kv') | T_constant ("list", [t]) -> let%bind t' = translate_type t in ok (T_list t') diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 5c962cc10..6262f3971 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -614,7 +614,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_application (f' , arg)) tv | E_look_up dsi -> let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = get_t_map ds.type_annotation in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 52637021e..329203a46 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -639,6 +639,8 @@ let bind_or (a, b) = match a with | Ok _ as o -> o | _ -> b +let bind_map_or (fa , fb) c = + bind_or (fa c , fb c) let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result = match (a, b) with From e930dc00c4ec57e560d99622647ecd70af64627c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 4 Sep 2019 19:05:45 +0200 Subject: [PATCH 17/53] some check on starage for big_map --- src/contracts/big_map.ligo | 15 ++++----------- src/operators/operators.ml | 6 +++++- src/transpiler/transpiler.ml | 37 +++++++++++++++++++++++++++++++++++- 3 files changed, 45 insertions(+), 13 deletions(-) diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index 2eb21153e..e05d23899 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -1,18 +1,11 @@ -// type storage_ is big_map(int, int) * unit -type storage_ is big_map(int, int) - -// function main(const p : unit; const s : storage_) : list(operation) * storage_ is -// block { skip } -// with ((nil : list(operation)), s) +// type storage_ is big_map(int, int) +type storage_ is big_map(int, int) * unit function main(const p : unit; const s : storage_) : list(operation) * storage_ is - // var r : big_map(int, int) := s.0 ; - var r : big_map(int,int) := s ; + var r : big_map(int, int) := s.0 ; var toto : option (int) := Some(0); block { - // r[23] := 2; toto := r[23]; - s := r; - // skip + s.0 := r; } with ((nil: list(operation)), s) \ No newline at end of file diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 61495e0e9..d08a535eb 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -592,7 +592,11 @@ module Typer = struct map_map ; map_fold ; map_iter ; - map_map ; + big_map_remove ; + big_map_add ; + big_map_update ; + big_map_mem ; + big_map_find ; set_empty ; set_mem ; set_add ; diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index a2119fe19..7f63fc378 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -58,6 +58,15 @@ them. please report this to the developers." in ] in error ~data title content + let bad_big_map location = + let title () = "bad arguments for main" in + let content () = "only one big_map per program which must appear + on the left hand side of a pair in the contract's storage" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title content + let missing_entry_point name = let title () = "missing entry point" in let content () = "no entry point with the given name" in @@ -601,10 +610,36 @@ let translate_program (lst:AST.program) : program result = let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements +(* check whether the storage contains a big_map, if yes, check that + it appears on the left hand side of a pair *) +let check_storage f ty loc : (anon_function * _) result = + let rec aux (t:type_value) on_big_map = + match t with + | T_big_map _ -> on_big_map + | T_pair (a , b) -> (aux a true) && (aux b false) + | T_or (a,b) -> (aux a false) && (aux b false) + | T_function (a,b) -> (aux a false) && (aux b false) + | T_deep_closure (_,a,b) -> (aux a false) && (aux b false) + | T_map (a,b) -> (aux a false) && (aux b false) + | T_list a -> (aux a false) + | T_set a -> (aux a false) + | T_contract a -> (aux a false) + | T_option a -> (aux a false) + | _ -> true + in + match f.result.type_value with + | T_pair (_, storage) -> + if aux storage false then ok (f, ty) else fail @@ bad_big_map loc + | _ -> ok (f, ty) + +(* let translate_main (l:AST.lambda) loc : anon_function result = + let%bind expr = translate_lambda Environment.empty l in + match Combinators.Expression.get_content expr with + | E_literal (D_function f) -> check_storage f loc *) let translate_main (l:AST.lambda) loc : (anon_function * _) result = let%bind expr = translate_lambda Environment.empty l in match expr.content , expr.type_value with - | E_literal (D_function f) , T_function ty -> ok (f , ty) + | E_literal (D_function f) , T_function ty -> check_storage f ty loc | _ -> fail @@ not_functional_main loc (* From an expression [expr], build the expression [fun () -> expr] *) From 1c281ac079e1a4f44cbad8e27d33743e6d46f6a7 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 5 Sep 2019 13:06:48 +0200 Subject: [PATCH 18/53] merge operations syntax for map with big_map --- src/ast_typed/combinators.ml | 14 ++++++------ src/mini_c/combinators.ml | 1 + src/operators/operators.ml | 42 ++++-------------------------------- src/typer/typer.ml | 2 +- 4 files changed, 13 insertions(+), 46 deletions(-) diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index ec745fabc..f402d253b 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -139,12 +139,13 @@ let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' let get_t_map (t:type_value) : (type_value * type_value) result = match t.type_value' with | T_constant ("map", [k;v]) -> ok (k, v) - | _ -> simple_fail "get: not a map" - -let get_t_big_map (t:type_value) : (type_value * type_value) result = - match t.type_value' with | T_constant ("big_map", [k;v]) -> ok (k, v) - | _ -> simple_fail "get: not a big_map" + | _ -> simple_fail "get: not a map or a big_map" + +let get_t_map_not_big_map (t:type_value) : (type_value * type_value) result = + match t.type_value' with + | T_constant ("map", [k;v]) -> ok (k, v) + | _ -> simple_fail "get: not a map" let get_t_map_key : type_value -> type_value result = fun t -> let%bind (key , _) = get_t_map t in @@ -158,8 +159,7 @@ let assert_t_map = fun t -> let%bind _ = get_t_map t in ok () -let is_t_map = Function.compose to_bool get_t_map -let is_t_big_map = Function.compose to_bool get_t_big_map +let is_t_map_not_big_map = Function.compose to_bool get_t_map_not_big_map let assert_t_tez : type_value -> unit result = get_t_tez let assert_t_key = get_t_key diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index f7342987e..5cc9d2ae4 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -88,6 +88,7 @@ let get_t_or (t:type_value) = match t with let get_t_map (t:type_value) = match t with | T_map kv -> ok kv + | T_big_map kv -> ok kv | _ -> simple_fail "not a type map" let get_t_list (t:type_value) = match t with diff --git a/src/operators/operators.ml b/src/operators/operators.ml index d08a535eb..3db1919f1 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -268,20 +268,20 @@ module Typer = struct ok @@ t_option dst () let map_iter : typer = typer_2 "MAP_ITER" @@ fun m f -> - let%bind (k, v) = get_t_map m in + let%bind (k, v) = get_t_map_not_big_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in let%bind () = assert_eq_1 res (t_unit ()) in ok @@ t_unit () let map_map : typer = typer_2 "MAP_MAP" @@ fun m f -> - let%bind (k, v) = get_t_map m in + let%bind (k, v) = get_t_map_not_big_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> - let%bind (k, v) = get_t_map m in + let%bind (k, v) = get_t_map_not_big_map m in let%bind (arg_1 , res) = get_t_function f in let%bind (arg_2 , res') = get_t_function res in let%bind (arg_3 , res'') = get_t_function res' in @@ -290,39 +290,10 @@ module Typer = struct let%bind () = assert_eq_1 arg_3 res'' in ok @@ res' - let big_map_remove : typer = typer_2 "BIG_MAP_REMOVE" @@ fun k m -> - let%bind (src , _) = get_t_big_map m in - let%bind () = assert_type_value_eq (src , k) in - ok m - - let big_map_add : typer = typer_3 "BIG_MAP_ADD" @@ fun k v m -> - let%bind (src, dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - let%bind () = assert_type_value_eq (dst, v) in - ok m - - let big_map_update : typer = typer_3 "BIG_MAP_UPDATE" @@ fun k v m -> - let%bind (src, dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - let%bind v' = get_t_option v in - let%bind () = assert_type_value_eq (dst, v') in - ok m - - let big_map_mem : typer = typer_2 "BIG_MAP_MEM" @@ fun k m -> - let%bind (src, _dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - ok @@ t_bool () - - let big_map_find : typer = typer_2 "BIG_MAP_FIND" @@ fun k m -> - let%bind (src, dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - ok @@ dst - - let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ - (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t || is_t_big_map t) in + (is_t_map_not_big_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t) in ok @@ t_nat () let slice = typer_3 "SLICE" @@ fun i j s -> @@ -592,11 +563,6 @@ module Typer = struct map_map ; map_fold ; map_iter ; - big_map_remove ; - big_map_add ; - big_map_update ; - big_map_mem ; - big_map_find ; set_empty ; set_mem ; set_add ; diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 6262f3971..5c962cc10 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -614,7 +614,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_application (f' , arg)) tv | E_look_up dsi -> let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in + let%bind (src, dst) = get_t_map ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) From a9f7bb39e4dd3bc4444b6cc2d4bbb23e4338e4df Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 5 Sep 2019 17:23:51 +0200 Subject: [PATCH 19/53] add tests for big_map --- src/contracts/big_map.ligo | 54 ++++++++++++++++++++++++++++++++- src/test/integration_tests.ml | 56 +++++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+), 1 deletion(-) diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index e05d23899..3e9bf7ef9 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -8,4 +8,56 @@ function main(const p : unit; const s : storage_) : list(operation) * storage_ i toto := r[23]; s.0 := r; } - with ((nil: list(operation)), s) \ No newline at end of file + with ((nil: list(operation)), s) + + + +// type foobar is map(int, int) + +// const fb : foobar = map +// 23 -> 0 ; +// 42 -> 0 ; +// end + +function set_ (var n : int ; var m : storage_) : storage_ is block { + var tmp : big_map(int,int) := m.0 ; + tmp[23] := n ; + m.0 := tmp ; +} with m + +function rm (var m : storage_) : storage_ is block { + var tmp : big_map(int,int) := m.0 ; + remove 42 from map tmp; + m.0 := tmp; +} with m + +// not supported +// function size_ (const m : storage_) : nat is +// block {skip} with (size(m.0)) + +function gf (const m : storage_) : int is begin skip end with get_force(23, m.0) + +function get (const m : storage_) : option(int) is + begin + skip + end with m.0[42] + +// const bm : storage_ = map +// 144 -> 23 ; +// 51 -> 23 ; +// 42 -> 23 ; +// 120 -> 23 ; +// 421 -> 23 ; +// end + +// not supported +// function iter_op (const m : storage_) : int is +// var r : int := 0 ; +// function aggregate (const i : int ; const j : int) : unit is block { r := r + i + j } with unit ; +// block { +// map_iter(m.0 , aggregate) ; +// } with r ; + +// function map_op (const m : storage_) : storage_ is +// function increment (const i : int ; const j : int) : int is block { skip } with j + 1 ; +// block { skip } with map_map(m.0 , increment) ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index baea8d256..dccd6470a 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -392,6 +392,61 @@ let map () : unit result = in ok () +let big_map () : unit result = + let%bind program = type_file "./contracts/big_map.ligo" in + let ez lst = + let open Ast_simplified.Combinators in + let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in + e_pair (e_typed_map lst' t_int t_int) (e_unit ()) + in + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = e_int in + expect_eq_n program "gf" make_input make_expected + in + (* let%bind () = + let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in + let make_expected = e_nat in + expect_eq_n_strict_pos_small program "size_" make_input make_expected + in + let%bind () = + let expected = ez [(23, 0) ; (42, 0)] in + expect_eq_evaluate program "fb" expected + in + let%bind () = + let make_input = fun n -> + let m = ez [(23 , 0) ; (42 , 0)] in + e_tuple [(e_int n) ; m] + in + let make_expected = fun n -> ez [(23 , n) ; (42 , 0)] in + expect_eq_n_pos_small program "set_" make_input make_expected + in + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = fun _ -> e_some @@ e_int 4 in + expect_eq_n program "get" make_input make_expected + in + let%bind () = + let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in + expect_eq_evaluate program "bm" expected + in + let%bind () = + let input = ez [(23, 23) ; (42, 42)] in + let expected = ez [23, 23] in + expect_eq program "rm" input expected + in *) + (* let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = e_int 66 in + expect_eq program "iter_op" input expected + in + let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in + expect_eq program "map_op" input expected + in *) + ok () + let list () : unit result = let%bind program = type_file "./contracts/list.ligo" in let ez lst = @@ -690,6 +745,7 @@ let main = test_suite "Integration (End to End)" [ test "string" string_expression ; test "option" option ; test "map" map ; + test "big_map" big_map ; test "list" list ; test "loop" loop ; test "matching" matching ; From e5b4d37af8d1974d362b903741419d7911016631 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 6 Sep 2019 15:43:11 +0200 Subject: [PATCH 20/53] add E_big_map case in Ast --- src/ast_simplified/PP.ml | 1 + src/ast_simplified/combinators.ml | 3 +++ src/ast_simplified/misc.ml | 4 ++-- src/ast_simplified/types.ml | 1 + src/ast_typed/PP.ml | 1 + src/ast_typed/combinators.ml | 1 + src/ast_typed/misc.ml | 6 +++--- src/ast_typed/misc_smart.ml | 2 +- src/ast_typed/types.ml | 1 + src/test/integration_tests.ml | 2 +- src/transpiler/transpiler.ml | 14 ++++++++++++- src/typer/typer.ml | 33 +++++++++++++++++++++++++++++++ 12 files changed, 61 insertions(+), 8 deletions(-) diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index 07277c664..4ab2bdde8 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -41,6 +41,7 @@ let rec expression ppf (e:expression) = match Location.unwrap e with | E_accessor (ae, p) -> fprintf ppf "%a.%a" expression ae access_path p | E_record m -> fprintf ppf "record[%a]" (smap_sep_d expression) m | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m + | E_big_map m -> fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m | E_list lst -> fprintf ppf "list[%a]" (list_sep_d expression) lst | E_set lst -> fprintf ppf "set[%a]" (list_sep_d expression) lst | E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" expression ds expression ind diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index 622e1039c..4680056e5 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -43,6 +43,7 @@ let ez_t_sum (lst:(string * type_expression) list) : type_expression = let t_function param result : type_expression = T_function (param, result) let t_map key value = (T_constant ("map", [key ; value])) +let t_big_map key value = (T_constant ("big_map", [key ; value])) let t_set key = (T_constant ("set", [key])) let make_name (s : string) : name = s @@ -66,6 +67,7 @@ let e_some ?loc s : expression = Location.wrap ?loc @@ E_constant ("SOME", [s]) let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", []) let e_map_add ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old]) let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst +let e_big_map ?loc lst : expression = Location.wrap ?loc @@ E_big_map lst let e_set ?loc lst : expression = Location.wrap ?loc @@ E_set lst let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b] @@ -106,6 +108,7 @@ let e_typed_list ?loc lst t = e_annotation ?loc (e_list lst) (t_list t) let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) +let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v) let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) diff --git a/src/ast_simplified/misc.ml b/src/ast_simplified/misc.ml index e1582b073..5dd52417b 100644 --- a/src/ast_simplified/misc.ml +++ b/src/ast_simplified/misc.ml @@ -120,7 +120,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | E_record _, _ -> simple_fail "comparing record with other stuff" - | E_map lsta, E_map lstb -> ( + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (simple_error "maps of different lengths") (fun () -> let lsta' = List.sort compare lsta in @@ -133,7 +133,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = let%bind _all = bind_map_list aux lst in ok () ) - | E_map _, _ -> + | (E_map _ | E_big_map _), _ -> simple_fail "comparing map with other stuff" | E_list lsta, E_list lstb -> ( diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index 88b93beda..1e8104a79 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -59,6 +59,7 @@ and expression' = | E_accessor of (expr * access_path) (* Data Structures *) | E_map of (expr * expr) list + | E_big_map of (expr * expr) list | E_list of expr list | E_set of expr list | E_look_up of (expr * expr) diff --git a/src/ast_typed/PP.ml b/src/ast_typed/PP.ml index 3e8edf30c..141cc768a 100644 --- a/src/ast_typed/PP.ml +++ b/src/ast_typed/PP.ml @@ -42,6 +42,7 @@ and expression ppf (e:expression) : unit = | E_tuple lst -> fprintf ppf "tuple[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m | E_map m -> fprintf ppf "map[@; @[%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m + | E_big_map m -> fprintf ppf "big_map[@; @[%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m | E_list m -> fprintf ppf "list[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m | E_set m -> fprintf ppf "set[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index f402d253b..78aa8a4a6 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -41,6 +41,7 @@ let ez_t_record lst ?s () : type_value = t_record m ?s () let t_map key value ?s () = make_t (T_constant ("map", [key ; value])) s +let t_big_map key value ?s () = make_t (T_constant ("big_map", [key ; value])) s let t_sum m ?s () : type_value = make_t (T_sum m) s let make_t_ez_sum (lst:(string * type_value) list) : type_value = diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index 091531789..8ea8c1bba 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -156,7 +156,7 @@ module Free_variables = struct | E_tuple_accessor (a, _) -> self a | E_list lst -> unions @@ List.map self lst | E_set lst -> unions @@ List.map self lst - | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m + | (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] | E_matching (a , cs) -> union (self a) (matching_expression b cs) | E_failwith a -> self a @@ -422,7 +422,7 @@ let rec assert_value_eq (a, b: (value*value)) : unit result = | E_record _, _ -> fail @@ (different_values_because_different_types "record vs. non-record" a b) - | E_map lsta, E_map lstb -> ( + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (different_size_values "maps of different lengths" a b) (fun () -> let lsta' = List.sort compare lsta in @@ -435,7 +435,7 @@ let rec assert_value_eq (a, b: (value*value)) : unit result = let%bind _all = bind_map_list aux lst in ok () ) - | E_map _, _ -> + | (E_map _ | E_big_map _), _ -> fail @@ different_values_because_different_types "map vs. non-map" a b | E_list lsta, E_list lstb -> ( diff --git a/src/ast_typed/misc_smart.ml b/src/ast_typed/misc_smart.ml index 0d0e8cd02..8ff87c9f6 100644 --- a/src/ast_typed/misc_smart.ml +++ b/src/ast_typed/misc_smart.ml @@ -80,7 +80,7 @@ module Captured_variables = struct | E_set lst -> let%bind lst' = bind_map_list self lst in ok @@ unions lst' - | E_map m -> + | (E_map m | E_big_map m) -> let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in ok @@ unions lst' | E_look_up (a , b) -> diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index cf8c40fec..a56843eca 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -99,6 +99,7 @@ and expression = | E_record_accessor of (ae * string) (* Data Structures *) | E_map of (ae * ae) list + | E_big_map of (ae * ae) list | E_list of ae list | E_set of ae list | E_look_up of (ae * ae) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index dccd6470a..c08a18d55 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -397,7 +397,7 @@ let big_map () : unit result = let ez lst = let open Ast_simplified.Combinators in let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in - e_pair (e_typed_map lst' t_int t_int) (e_unit ()) + e_pair (e_typed_big_map lst' t_int t_int) (e_unit ()) in let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 7f63fc378..ff80c19c8 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -434,7 +434,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind (init : expression) = return @@ E_make_empty_set t in bind_fold_list aux init lst' ) - | E_map m -> ( + | (E_map m | E_big_map m) -> ( let%bind (src, dst) = trace_strong (corner_case ~loc:__LOC__ "not a map") @@ Mini_c.Combinators.get_t_map tv in @@ -802,6 +802,18 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_map lst') ) + | T_constant ("big_map", [k_ty;v_ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "map" v) @@ + get_map v in + let%bind lst' = + let aux = fun (k, v) -> + let%bind k' = untranspile k k_ty in + let%bind v' = untranspile v v_ty in + ok (k', v') in + bind_map_list aux lst in + return (E_big_map lst') + ) | T_constant ("list", [ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "list" v) @@ diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 5c962cc10..c95ec44fb 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -556,6 +556,36 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ok (t_map key_type value_type ()) in return (E_map lst') tv + | E_big_map lst -> + let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_big_map key_type value_type ()) + in + return (E_big_map lst') tv | E_lambda { binder ; input_type ; @@ -826,6 +856,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | E_map m -> let%bind m' = bind_map_list (bind_map_pair untype_expression) m in return (e_map m') + | E_big_map m -> + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_big_map m') | E_list lst -> let%bind lst' = bind_map_list untype_expression lst in return (e_list lst') From c7cfce2bf774bba22f397ff0412869ff86c0e477 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 9 Sep 2019 22:23:29 +0200 Subject: [PATCH 21/53] Remove merge comments --- src/transpiler/transpiler.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index ff80c19c8..56da73d5e 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -632,10 +632,6 @@ let check_storage f ty loc : (anon_function * _) result = if aux storage false then ok (f, ty) else fail @@ bad_big_map loc | _ -> ok (f, ty) -(* let translate_main (l:AST.lambda) loc : anon_function result = - let%bind expr = translate_lambda Environment.empty l in - match Combinators.Expression.get_content expr with - | E_literal (D_function f) -> check_storage f loc *) let translate_main (l:AST.lambda) loc : (anon_function * _) result = let%bind expr = translate_lambda Environment.empty l in match expr.content , expr.type_value with From 304184bcd3ae5366327e857cd5401662c1a2fc15 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 11 Sep 2019 16:02:06 +0200 Subject: [PATCH 22/53] Bla --- src/ast_typed/combinators.ml | 22 +++++++++++++++------- src/compiler/compiler_program.ml | 11 ++++++++++- src/mini_c/PP.ml | 1 + src/mini_c/combinators.ml | 9 ++++++++- src/mini_c/types.ml | 1 + src/operators/operators.ml | 26 +++++++++++++------------- src/transpiler/transpiler.ml | 20 +++++++++++++++++--- src/typer/typer.ml | 8 ++++---- 8 files changed, 69 insertions(+), 29 deletions(-) diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index 78aa8a4a6..32e25f2ec 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -138,16 +138,15 @@ let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' | _ -> simple_fail "not a record type" let get_t_map (t:type_value) : (type_value * type_value) result = - match t.type_value' with - | T_constant ("map", [k;v]) -> ok (k, v) - | T_constant ("big_map", [k;v]) -> ok (k, v) - | _ -> simple_fail "get: not a map or a big_map" - -let get_t_map_not_big_map (t:type_value) : (type_value * type_value) result = match t.type_value' with | T_constant ("map", [k;v]) -> ok (k, v) | _ -> simple_fail "get: not a map" +let get_t_big_map (t:type_value) : (type_value * type_value) result = + match t.type_value' with + | T_constant ("big_map", [k;v]) -> ok (k, v) + | _ -> simple_fail "get: not a big_map" + let get_t_map_key : type_value -> type_value result = fun t -> let%bind (key , _) = get_t_map t in ok key @@ -156,11 +155,20 @@ let get_t_map_value : type_value -> type_value result = fun t -> let%bind (_ , value) = get_t_map t in ok value +let get_t_big_map_key : type_value -> type_value result = fun t -> + let%bind (key , _) = get_t_big_map t in + ok key + +let get_t_big_map_value : type_value -> type_value result = fun t -> + let%bind (_ , value) = get_t_big_map t in + ok value + let assert_t_map = fun t -> let%bind _ = get_t_map t in ok () -let is_t_map_not_big_map = Function.compose to_bool get_t_map_not_big_map +let is_t_map = Function.compose to_bool get_t_map +let is_t_big_map = Function.compose to_bool get_t_big_map let assert_t_tez : type_value -> unit result = get_t_tez let assert_t_key = get_t_key diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 789000391..83d80e1b9 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -35,7 +35,7 @@ let get_predicate : string -> type_value -> expression list -> predicate result | "MAP_REMOVE" -> let%bind v = match lst with | [ _ ; expr ] -> - let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in + let%bind (_, v) = Mini_c.Combinators.(bind_map_or (get_t_map , get_t_big_map) (Expression.get_type expr)) in ok v | _ -> simple_fail "mini_c . MAP_REMOVE" in let%bind v_ty = Compiler_type.type_ v in @@ -107,6 +107,15 @@ let rec translate_value (v:value) ty : michelson result = match v with let aux (a, b) = prim ~children:[a;b] D_Elt in ok @@ seq @@ List.map aux sorted ) + | D_big_map lst -> ( + let%bind (k_ty , v_ty) = get_t_big_map ty in + let%bind lst' = + let aux (k , v) = bind_pair (translate_value k k_ty , translate_value v v_ty) in + bind_map_list aux lst in + let sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in + let aux (a, b) = prim ~children:[a;b] D_Elt in + ok @@ seq @@ List.map aux sorted + ) | D_list lst -> ( let%bind e_ty = get_t_list ty in let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index c7eab992d..46f39f766 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -62,6 +62,7 @@ let rec value ppf : value -> unit = function | D_none -> fprintf ppf "None" | D_some s -> fprintf ppf "Some (%a)" value s | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m + | D_big_map m -> fprintf ppf "Big_map[%a]" (list_sep_d value_assoc) m | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst | D_set lst -> fprintf ppf "Set[%a]" (list_sep_d value) lst diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index 5cc9d2ae4..f2639ebf6 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -62,6 +62,10 @@ let get_map (v:value) = match v with | D_map lst -> ok lst | _ -> simple_fail "not a map" +let get_big_map (v:value) = match v with + | D_big_map lst -> ok lst + | _ -> simple_fail "not a big_map" + let get_list (v:value) = match v with | D_list lst -> ok lst | _ -> simple_fail "not a list" @@ -88,9 +92,12 @@ let get_t_or (t:type_value) = match t with let get_t_map (t:type_value) = match t with | T_map kv -> ok kv - | T_big_map kv -> ok kv | _ -> simple_fail "not a type map" +let get_t_big_map (t:type_value) = match t with + | T_big_map kv -> ok kv + | _ -> simple_fail "not a type big_map" + let get_t_list (t:type_value) = match t with | T_list t -> ok t | _ -> simple_fail "not a type list" diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 8be621954..dba508062 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -48,6 +48,7 @@ type value = | D_some of value | D_none | D_map of (value * value) list + | D_big_map of (value * value) list | D_list of value list | D_set of value list (* | `Macro of anon_macro ... The future. *) diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 3db1919f1..5989fed0f 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -235,53 +235,53 @@ module Typer = struct ok tl let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m -> - let%bind (src , _) = get_t_map m in + let%bind (src , _) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src , k) in ok m let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in let%bind () = assert_type_value_eq (dst, v) in ok m let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in let%bind v' = get_t_option v in let%bind () = assert_type_value_eq (dst, v') in ok m let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m -> - let%bind (src, _dst) = get_t_map m in + let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ t_bool () let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ dst let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ t_option dst () let map_iter : typer = typer_2 "MAP_ITER" @@ fun m f -> - let%bind (k, v) = get_t_map_not_big_map m in + let%bind (k, v) = get_t_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in let%bind () = assert_eq_1 res (t_unit ()) in ok @@ t_unit () let map_map : typer = typer_2 "MAP_MAP" @@ fun m f -> - let%bind (k, v) = get_t_map_not_big_map m in + let%bind (k, v) = get_t_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> - let%bind (k, v) = get_t_map_not_big_map m in + let%bind (k, v) = get_t_map m in let%bind (arg_1 , res) = get_t_function f in let%bind (arg_2 , res') = get_t_function res in let%bind (arg_3 , res'') = get_t_function res' in @@ -293,7 +293,7 @@ module Typer = struct let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ - (is_t_map_not_big_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t) in + (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in ok @@ t_nat () let slice = typer_3 "SLICE" @@ fun i j s -> @@ -312,7 +312,7 @@ module Typer = struct ok @@ t_unit () let get_force = typer_2 "MAP_GET_FORCE" @@ fun i m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind _ = assert_type_value_eq (src, i) in ok dst @@ -641,6 +641,8 @@ module Compiler = struct ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ; ("MAP_GET" , simple_binary @@ prim I_GET) ; + ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; + ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; @@ -655,8 +657,6 @@ module Compiler = struct ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ; ("SOURCE" , simple_constant @@ prim I_SOURCE) ; ("SENDER" , simple_constant @@ prim I_SENDER) ; - ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; - ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SET_MEM" , simple_binary @@ prim I_MEM) ; ("SET_ADD" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) ; ("SET_REMOVE" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) ; diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 56da73d5e..ebd71877e 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -434,7 +434,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind (init : expression) = return @@ E_make_empty_set t in bind_fold_list aux init lst' ) - | (E_map m | E_big_map m) -> ( + | E_map m -> ( let%bind (src, dst) = trace_strong (corner_case ~loc:__LOC__ "not a map") @@ Mini_c.Combinators.get_t_map tv in @@ -448,6 +448,20 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let init = return @@ E_make_empty_map (src, dst) in List.fold_left aux init m ) + | E_big_map m -> ( + let%bind (src, dst) = + trace_strong (corner_case ~loc:__LOC__ "not a map") @@ + Mini_c.Combinators.get_t_big_map tv in + let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) -> + let%bind prev' = prev in + let%bind (k', v') = + let v' = e_a_some v ae.environment in + bind_map_pair (translate_annotated_expression) (k , v') in + return @@ E_constant ("UPDATE", [k' ; v' ; prev']) + in + let init = return @@ E_make_empty_map (src, dst) in + List.fold_left aux init m + ) | E_look_up dsi -> ( let%bind (ds', i') = bind_map_pair f dsi in return @@ E_constant ("MAP_GET", [i' ; ds']) @@ -800,8 +814,8 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression ) | T_constant ("big_map", [k_ty;v_ty]) -> ( let%bind lst = - trace_strong (wrong_mini_c_value "map" v) @@ - get_map v in + trace_strong (wrong_mini_c_value "big_map" v) @@ + get_big_map v in let%bind lst' = let aux = fun (k, v) -> let%bind k' = untranspile k k_ty in diff --git a/src/typer/typer.ml b/src/typer/typer.ml index c95ec44fb..5122e86aa 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -451,7 +451,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ) | Access_map ae' -> ( let%bind ae'' = type_expression e ae' in - let%bind (k , v) = get_t_map prev.type_annotation in + let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in let%bind () = Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in return (E_look_up (prev , ae'')) v @@ -570,7 +570,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a bind_fold_list aux None @@ List.map get_type_annotation @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_map_key tv_opt in + let%bind annot = bind_map_option get_t_big_map_key tv_opt in trace (simple_info "empty map expression without a type annotation") @@ O.merge_annotation annot sub (needs_annotation ae "this map literal") in @@ -579,7 +579,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a bind_fold_list aux None @@ List.map get_type_annotation @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_map_value tv_opt in + let%bind annot = bind_map_option get_t_big_map_value tv_opt in trace (simple_info "empty map expression without a type annotation") @@ O.merge_annotation annot sub (needs_annotation ae "this map literal") in @@ -644,7 +644,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_application (f' , arg)) tv | E_look_up dsi -> let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = get_t_map ds.type_annotation in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) From b653996aae53b36e272ecb89d41f2753532a0b8b Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 13 Sep 2019 20:30:09 +0200 Subject: [PATCH 23/53] Big_map support Add big_map case in the uncompiler which takes the original big_map and apply the returned diff Add input_to_value option which compiles input expressions to mini_c.values --- src/compiler/uncompiler.ml | 32 ++++++++++--- src/contracts/big_map.ligo | 28 +++++------- src/main/run_mini_c.ml | 4 +- src/main/run_simplified.ml | 4 +- src/main/run_typed.ml | 84 +++++++++++++++++++++++++++++++++-- src/test/integration_tests.ml | 31 ++----------- src/test/test_helpers.ml | 24 +++++----- 7 files changed, 140 insertions(+), 67 deletions(-) diff --git a/src/compiler/uncompiler.ml b/src/compiler/uncompiler.ml index c0f8aa16b..c114d901d 100644 --- a/src/compiler/uncompiler.ml +++ b/src/compiler/uncompiler.ml @@ -6,19 +6,19 @@ open Protocol open Script_typed_ir open Script_ir_translator -let rec translate_value (Ex_typed_value (ty, value)) : value result = +let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = match (ty, value) with | Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> ( - let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in - let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in + let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in ok @@ D_pair(a, b) ) | Union_t ((a_ty, _), _, _), L a -> ( - let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in + let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in ok @@ D_left a ) | Union_t (_, (b_ty, _), _), R b -> ( - let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in ok @@ D_right b ) | (Int_t _), n -> @@ -71,6 +71,28 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = bind_map_list aux lst in ok @@ D_map lst' + | (Big_map_t (k_cty, v_ty, _)), m -> + let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in + let lst = + let aux k v acc = (k, v) :: acc in + let lst = Script_ir_translator.map_fold aux m.diff [] in + List.rev lst in + let%bind original_big_map = + match bm_opt with + | Some (D_big_map l) -> ok @@ l + | _ -> fail @@ simple_error "Do not have access to the original big_map" in + let%bind lst' = + let aux orig (k, v) = + let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in + let orig_rem = List.remove_assoc k' orig in + match v with + | Some vadd -> + let%bind v' = translate_value (Ex_typed_value (v_ty, vadd)) in + if (List.mem_assoc k' orig) then ok @@ (k', v')::orig_rem + else ok @@ (k', v')::orig + | None -> ok orig_rem in + bind_fold_list aux original_big_map lst in + ok @@ D_big_map lst' | (List_t (ty, _)), lst -> let%bind lst' = let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index 3e9bf7ef9..b5f6d44c5 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -1,4 +1,3 @@ -// type storage_ is big_map(int, int) type storage_ is big_map(int, int) * unit function main(const p : unit; const s : storage_) : list(operation) * storage_ is @@ -10,15 +9,6 @@ function main(const p : unit; const s : storage_) : list(operation) * storage_ i } with ((nil: list(operation)), s) - - -// type foobar is map(int, int) - -// const fb : foobar = map -// 23 -> 0 ; -// 42 -> 0 ; -// end - function set_ (var n : int ; var m : storage_) : storage_ is block { var tmp : big_map(int,int) := m.0 ; tmp[23] := n ; @@ -31,10 +21,6 @@ function rm (var m : storage_) : storage_ is block { m.0 := tmp; } with m -// not supported -// function size_ (const m : storage_) : nat is -// block {skip} with (size(m.0)) - function gf (const m : storage_) : int is begin skip end with get_force(23, m.0) function get (const m : storage_) : option(int) is @@ -42,7 +28,9 @@ function get (const m : storage_) : option(int) is skip end with m.0[42] -// const bm : storage_ = map +// the following is not supported (negative test cases): + +// const bm : storage_ = big_map // 144 -> 23 ; // 51 -> 23 ; // 42 -> 23 ; @@ -50,7 +38,15 @@ function get (const m : storage_) : option(int) is // 421 -> 23 ; // end -// not supported +// type foobar is big_map(int, int) +// const fb : foobar = big_map +// 23 -> 0 ; +// 42 -> 0 ; +// end + +// function size_ (const m : storage_) : nat is +// block {skip} with (size(m.0)) + // function iter_op (const m : storage_) : int is // var r : int := 0 ; // function aggregate (const i : int ; const j : int) : unit is block { r := r + i + j } with unit ; diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index d13b4cc54..6b2443c09 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -23,7 +23,7 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let run_entry ?(debug_michelson = false) ?options (entry:anon_function) ty (input:value) : value result = +let run_entry ?(debug_michelson = false) ?options ?bm_opt (entry:anon_function) ty (input:value) : value result = let%bind compiled = let error = let title () = "compile entry" in @@ -51,5 +51,5 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) ty (inpu Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; ok () ) ; - let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in + let%bind (result : value) = Compiler.Uncompiler.translate_value ?bm_opt ex_ty_value in ok result diff --git a/src/main/run_simplified.ml b/src/main/run_simplified.ml index 4faf34aaf..eadc0846e 100644 --- a/src/main/run_simplified.ml +++ b/src/main/run_simplified.ml @@ -1,7 +1,7 @@ open Trace let run_simplityped - ?options + ?input_to_value ?options ?(debug_mini_c = false) ?(debug_michelson = false) (program : Ast_typed.program) (entry : string) (input : Ast_simplified.expression) : Ast_simplified.expression result = @@ -13,7 +13,7 @@ let run_simplityped in Typer.type_expression env input in let%bind typed_result = - Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in + Run_typed.run_typed ?input_to_value ?options ~debug_mini_c ~debug_michelson entry program typed_input in let%bind annotated_result = Typer.untype_expression typed_result in ok annotated_result diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index fc136c63c..9c5157c27 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -30,8 +30,84 @@ let evaluate_typed Transpiler.untranspile result typed_main.type_annotation in ok typed_result +(* returns a big_map if any *) +let rec fetch_big_map (v: Mini_c.value) : Mini_c.value option = + match v with + | D_pair (l , r) -> + begin + match (fetch_big_map l) with + | Some _ as s -> s + | None -> fetch_big_map r + end + | D_big_map _ as bm -> Some bm + | _ -> let () = Printf.printf "lal\n" in None + +(* try to convert expression to a literal *) +let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = + let open! Mini_c in + match exp.content with + | E_literal v -> ok @@ v + | E_constant ("map" , lst) -> + let aux el = + let%bind l = exp_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_map lstl + | E_constant ("big_map" , lst) -> + let aux el = + let%bind l = exp_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_big_map lstl + | E_constant ("PAIR" , fst::snd::[]) -> + let%bind fstl = exp_to_value fst in + let%bind sndl = exp_to_value snd in + ok @@ D_pair (fstl , sndl) + | E_constant ("UPDATE", _) -> + let rec handle_prev upd = + match upd.content with + | E_constant ("UPDATE" , [k;v;prev]) -> + begin + match v.content with + | E_constant ("SOME" , [i]) -> + let%bind kl = exp_to_value k in + let%bind il = exp_to_value i in + let%bind prevl = handle_prev prev in + ok @@ (kl,il)::prevl + | E_constant ("NONE" , []) -> + let%bind prevl = handle_prev prev in + ok @@ prevl + | _ -> failwith "UPDATE second parameter is not an option" + end + | E_make_empty_map _ -> + ok @@ [] + | _ -> failwith "impossible" + in + begin + match exp.type_value with + | T_big_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_big_map kvl + | T_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_map kvl + | _ -> failwith "UPDATE with a non-map type_value" + end + | _ -> + fail @@ simple_error "Can not convert expression to literal" + +let convert_to_literals (e:Ast_typed.annotated_expression) : Mini_c.value result = + let open Transpiler in + let%bind exp = translate_annotated_expression e in (*Mini_c.expression*) + let%bind value = exp_to_value exp in + ok @@ value + let run_typed - ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) + ?(input_to_value = false) ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) (program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = let%bind () = let open Ast_typed in @@ -49,7 +125,9 @@ let run_typed Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) ) ; - let%bind mini_c_value = transpile_value input in + let%bind mini_c_value = if input_to_value then + convert_to_literals input else transpile_value input in + let bm_opt = if input_to_value then fetch_big_map mini_c_value else None in let%bind mini_c_result = let error = @@ -59,7 +137,7 @@ let run_typed in error title content in trace error @@ - Run_mini_c.run_entry ~debug_michelson ?options mini_c_main ty mini_c_value in + Run_mini_c.run_entry ~debug_michelson ?options ?bm_opt mini_c_main ty mini_c_value in let%bind typed_result = let%bind main_result_type = let%bind typed_main = Ast_typed.get_functional_entry program entry in diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index c08a18d55..b6122fa1b 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -402,16 +402,7 @@ let big_map () : unit result = let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_expected = e_int in - expect_eq_n program "gf" make_input make_expected - in - (* let%bind () = - let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in - let make_expected = e_nat in - expect_eq_n_strict_pos_small program "size_" make_input make_expected - in - let%bind () = - let expected = ez [(23, 0) ; (42, 0)] in - expect_eq_evaluate program "fb" expected + expect_eq_n ?input_to_value:(Some true) program "gf" make_input make_expected in let%bind () = let make_input = fun n -> @@ -419,32 +410,18 @@ let big_map () : unit result = e_tuple [(e_int n) ; m] in let make_expected = fun n -> ez [(23 , n) ; (42 , 0)] in - expect_eq_n_pos_small program "set_" make_input make_expected + expect_eq_n_pos_small ?input_to_value:(Some true) program "set_" make_input make_expected in let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_expected = fun _ -> e_some @@ e_int 4 in - expect_eq_n program "get" make_input make_expected - in - let%bind () = - let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in - expect_eq_evaluate program "bm" expected + expect_eq_n ?input_to_value:(Some true) program "get" make_input make_expected in let%bind () = let input = ez [(23, 23) ; (42, 42)] in let expected = ez [23, 23] in - expect_eq program "rm" input expected - in *) - (* let%bind () = - let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in - let expected = e_int 66 in - expect_eq program "iter_op" input expected + expect_eq ?input_to_value:(Some true) program "rm" input expected in - let%bind () = - let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in - let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in - expect_eq program "map_op" input expected - in *) ok () let list () : unit result = diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index f1a51a794..90b412c2e 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -31,14 +31,14 @@ let test_suite name lst = Test_suite (name , lst) open Ast_simplified.Combinators -let expect ?options program entry_point input expecter = +let expect ?input_to_value ?options program entry_point input expecter = let%bind result = let run_error = let title () = "expect run" in let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in + Ligo.Run.run_simplityped ?input_to_value ~debug_michelson:true ?options program entry_point input in expecter result let expect_fail ?options program entry_point input = @@ -52,7 +52,7 @@ let expect_fail ?options program entry_point input = @@ Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input -let expect_eq ?options program entry_point input expected = +let expect_eq ?input_to_value ?options program entry_point input expected = let expecter = fun result -> let expect_error = let title () = "expect result" in @@ -62,7 +62,7 @@ let expect_eq ?options program entry_point input expected = error title content in trace expect_error @@ Ast_simplified.Misc.assert_value_eq (expected , result) in - expect ?options program entry_point input expecter + expect ?input_to_value ?options program entry_point input expecter let expect_evaluate program entry_point expecter = let error = @@ -89,23 +89,23 @@ let expect_n_aux ?options lst program entry_point make_input make_expecter = let%bind _ = bind_map_list aux lst in ok () -let expect_eq_n_aux ?options lst program entry_point make_input make_expected = +let expect_eq_n_aux ?input_to_value ?options lst program entry_point make_input make_expected = let aux n = let input = make_input n in let expected = make_expected n in trace (simple_error ("expect_eq_n " ^ (string_of_int n))) @@ - let result = expect_eq ?options program entry_point input expected in + let result = expect_eq ?input_to_value ?options program entry_point input expected in result in let%bind _ = bind_map_list_seq aux lst in ok () -let expect_eq_n ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 42 ; 163 ; -1] -let expect_eq_n_pos ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 42 ; 163] -let expect_eq_n_strict_pos ?options = expect_eq_n_aux ?options [2 ; 42 ; 163] -let expect_eq_n_pos_small ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 10] -let expect_eq_n_strict_pos_small ?options = expect_eq_n_aux ?options [1 ; 2 ; 10] -let expect_eq_n_pos_mid = expect_eq_n_aux [0 ; 1 ; 2 ; 10 ; 33] +let expect_eq_n ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [0 ; 1 ; 2 ; 42 ; 163 ; -1] +let expect_eq_n_pos ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [0 ; 1 ; 2 ; 42 ; 163] +let expect_eq_n_strict_pos ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [2 ; 42 ; 163] +let expect_eq_n_pos_small ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [0 ; 1 ; 2 ; 10] +let expect_eq_n_strict_pos_small ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [1 ; 2 ; 10] +let expect_eq_n_pos_mid ?input_to_value = expect_eq_n_aux ?input_to_value [0 ; 1 ; 2 ; 10 ; 33] let expect_n_pos_small ?options = expect_n_aux ?options [0 ; 2 ; 10] let expect_n_strict_pos_small ?options = expect_n_aux ?options [2 ; 10] From ea6f51bd55c34a19f829daa5671e2962fdc29bf7 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 17 Sep 2019 18:17:12 +0200 Subject: [PATCH 24/53] CLI checked, compile-storage and dry-run Add a '--bigmap' option to the CLI. This way all the maps in the AST are transformed to bigmaps --- src/bin/cli.ml | 20 ++++++++++++++------ src/contracts/big_map.ligo | 1 + src/main/run_source.ml | 33 +++++++++++++++++++++++++++++---- src/main/run_typed.ml | 5 +++-- 4 files changed, 47 insertions(+), 12 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 11777b504..fd3fa05be 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -37,6 +37,14 @@ let syntax = info ~docv ~doc ["syntax" ; "s"] in value @@ opt string "auto" info +let bigmap = + let open Arg in + let info = + let docv = "BIGMAP" in + let doc = "$(docv) is necessary when your storage embeds a big_map." in + info ~docv ~doc ["bigmap"] in + value @@ flag info + let amount = let open Arg in let info = @@ -76,30 +84,30 @@ let compile_parameter = (term , Term.info ~docs cmdname) let compile_storage = - let f source entry_point expression syntax = + let f source entry_point expression syntax bigmap = toplevel @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Run.compile_contract_storage source entry_point expression (Syntax_name syntax) in + Ligo.Run.compile_contract_storage ?bigmap:(Some bigmap) source entry_point expression (Syntax_name syntax) in Format.printf "%s\n" value; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ bigmap) in let cmdname = "compile-storage" in let docs = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let dry_run = - let f source entry_point storage input amount syntax = + let f source entry_point storage input bigmap amount syntax = toplevel @@ let%bind output = - Ligo.Run.run_contract ~amount source entry_point storage input (Syntax_name syntax) in + Ligo.Run.run_contract ~bigmap ~amount source entry_point storage input (Syntax_name syntax) in Format.printf "%a\n" Ast_simplified.PP.expression output ; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ bigmap $ amount $ syntax) in let cmdname = "dry-run" in let docs = "Subcommand: run a smart-contract with the given storage and input." in (term , Term.info ~docs cmdname) diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index b5f6d44c5..461c2c206 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -5,6 +5,7 @@ function main(const p : unit; const s : storage_) : list(operation) * storage_ i var toto : option (int) := Some(0); block { toto := r[23]; + r[2] := 444; s.0 := r; } with ((nil: list(operation)), s) diff --git a/src/main/run_source.ml b/src/main/run_source.ml index 10904914a..71f7d3b55 100644 --- a/src/main/run_source.ml +++ b/src/main/run_source.ml @@ -46,6 +46,17 @@ include struct ok () end +let transpile_value_literals + (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result = + let%bind (_ , ty) = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f e.location in + ok main + in + let%bind lit = Run_typed.convert_to_literals e in + ok (lit , snd ty) + let transpile_value (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result = let%bind (f , ty) = @@ -196,8 +207,20 @@ let compile_contract_parameter : string -> string -> string -> s_syntax -> strin in ok expr +(* Replace occurrences of E_map with E_big_map in the AST *) +let rec transform_map_to_big_map (e: Ast_simplified.expression) : Ast_simplified.expression result = + let open Ast_simplified in + match e.wrap_content with + | E_tuple [fst;snd] -> + let%bind tr_fst = transform_map_to_big_map fst in + let new_tuple = Location.wrap (E_tuple [tr_fst;snd]) in + ok @@ new_tuple + | E_map lst -> + let tr_map = Location.wrap (E_big_map lst) in + ok @@ tr_map + | _ -> fail @@ simple_error "can not replace map with big_map" -let compile_contract_storage : string -> string -> string -> s_syntax -> string result = fun source_filename entry_point expression syntax -> +let compile_contract_storage ?(bigmap = false) source_filename entry_point expression syntax : string result = let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind (program , storage_tv) = let%bind simplified = parsify syntax source_filename in @@ -212,6 +235,7 @@ let compile_contract_storage : string -> string -> string -> s_syntax -> string in let%bind expr = let%bind simplified = parsify_expression syntax expression in + let%bind simplified = if bigmap then transform_map_to_big_map simplified else ok @@ simplified in let%bind typed = let env = let last_declaration = Location.unwrap List.(hd @@ rev program) in @@ -225,7 +249,7 @@ let compile_contract_storage : string -> string -> string -> s_syntax -> string Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in let%bind (mini_c , mini_c_ty) = trace (simple_error "transpiling expression") @@ - transpile_value typed in + (if bigmap then transpile_value_literals typed else transpile_value typed) in let%bind michelson = trace (simple_error "compiling expression") @@ Compiler.translate_value mini_c mini_c_ty in @@ -249,7 +273,7 @@ let type_file ?(debug_simplify = false) ?(debug_typed = false) )) ; ok typed -let run_contract ?amount source_filename entry_point storage input syntax = +let run_contract ?(bigmap = false) ?amount source_filename entry_point storage input syntax = let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind typed = type_file syntax source_filename in @@ -257,11 +281,12 @@ let run_contract ?amount source_filename entry_point storage input syntax = parsify_expression syntax storage in let%bind input_simpl = parsify_expression syntax input in + let%bind input_simpl = if bigmap then transform_map_to_big_map input_simpl else ok @@ input_simpl in let options = let open Proto_alpha_utils.Memory_proto_alpha in let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in (make_options ?amount ()) in - Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) + Run_simplified.run_simplityped ?input_to_value:(Some bigmap) ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) let run_function ?amount source_filename entry_point parameter syntax = let%bind syntax = syntax_to_variant syntax (Some source_filename) in diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index 9c5157c27..aef51cd56 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -30,7 +30,7 @@ let evaluate_typed Transpiler.untranspile result typed_main.type_annotation in ok typed_result -(* returns a big_map if any *) +(* returns a big_map if any. used to reconstruct the map from the diff when uncompiling *) let rec fetch_big_map (v: Mini_c.value) : Mini_c.value option = match v with | D_pair (l , r) -> @@ -40,7 +40,7 @@ let rec fetch_big_map (v: Mini_c.value) : Mini_c.value option = | None -> fetch_big_map r end | D_big_map _ as bm -> Some bm - | _ -> let () = Printf.printf "lal\n" in None + | _ -> None (* try to convert expression to a literal *) let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = @@ -67,6 +67,7 @@ let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = let%bind fstl = exp_to_value fst in let%bind sndl = exp_to_value snd in ok @@ D_pair (fstl , sndl) + | E_constant ("UNIT", _) -> ok @@ D_unit | E_constant ("UPDATE", _) -> let rec handle_prev upd = match upd.content with From 8978c5c4d79bd86347a3cd56b65e436318445c39 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 20 Sep 2019 21:26:34 +0200 Subject: [PATCH 25/53] Print expresion in error message to ease further debugging --- src/main/run_typed.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index aef51cd56..15478a9d9 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -86,7 +86,7 @@ let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = end | E_make_empty_map _ -> ok @@ [] - | _ -> failwith "impossible" + | _ -> failwith "Ill-constructed map" in begin match exp.type_value with @@ -98,8 +98,9 @@ let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = ok @@ D_map kvl | _ -> failwith "UPDATE with a non-map type_value" end - | _ -> - fail @@ simple_error "Can not convert expression to literal" + | _ as nl -> + let expp = Format.asprintf "'%a'" Mini_c.PP.expression' nl in + fail @@ simple_error ("Can not convert expression "^expp^" to literal") let convert_to_literals (e:Ast_typed.annotated_expression) : Mini_c.value result = let open Transpiler in From ad79188c4f1cdbe24d933d5116516bb7093d94c4 Mon Sep 17 00:00:00 2001 From: galfour Date: Sat, 21 Sep 2019 09:12:00 +0200 Subject: [PATCH 26/53] add list pattern matching --- src/passes/4-typer/typer.ml | 8 ++++---- src/passes/6-transpiler/transpiler.ml | 17 +++++++++++++++-- src/passes/8-compiler/compiler_program.ml | 18 ++++++++++++++++++ src/stages/ast_typed/PP.ml | 4 ++-- src/stages/ast_typed/misc.ml | 2 +- src/stages/ast_typed/misc_smart.ml | 2 +- src/stages/ast_typed/types.ml | 2 +- src/stages/mini_c/PP.ml | 1 + src/stages/mini_c/types.ml | 1 + src/test/integration_tests.ml | 2 +- vendors/ligo-utils/tezos-utils/x_michelson.ml | 1 + 11 files changed, 46 insertions(+), 12 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index edc9d05b8..cd27b1cf4 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -274,7 +274,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t let e' = Environment.add_ez_binder hd t_list e in let e' = Environment.add_ez_binder tl t e' in let%bind b' = f e' b in - ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) + ok (O.Match_list {match_nil ; match_cons = (((hd , t_list), (tl , t)), b')}) | Match_tuple (lst, b) -> let%bind t_tuple = trace_strong (match_error ~expected:i ~actual:t loc) @@ -646,7 +646,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let aux (cur:O.value O.matching) = match cur with | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] - | Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ] + | Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] | Match_tuple (_ , match_tuple) -> [ match_tuple ] | Match_variant (lst , _) -> List.map snd lst in @@ -862,10 +862,10 @@ and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matchin let%bind some = f some in let match_some = fst v, some in ok @@ Match_option {match_none ; match_some} - | Match_list {match_nil ; match_cons = (hd, tl, cons)} -> + | Match_list {match_nil ; match_cons = (((hd_name , _) , (tl_name , _)), cons)} -> let%bind match_nil = f match_nil in let%bind cons = f cons in - let match_cons = hd, tl, cons in + let match_cons = hd_name , tl_name , cons in ok @@ Match_list {match_nil ; match_cons} | Match_variant (lst , _) -> let aux ((a,b),c) = diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 8e65cfdb7..76ca3a770 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -448,8 +448,22 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind (tv' , s') = let%bind tv' = transpile_type tv in let%bind s' = transpile_annotated_expression s in - ok (tv' , s') in + ok (tv' , s') + in return @@ E_if_none (expr' , n , ((name , tv') , s')) + | Match_list { + match_nil ; + match_cons = (((hd_name , hd_ty) , (tl_name , tl_ty)) , match_cons) ; + } -> ( + let%bind nil = transpile_annotated_expression match_nil in + let%bind cons = + let%bind hd_ty' = transpile_type hd_ty in + let%bind tl_ty' = transpile_type tl_ty in + let%bind match_cons' = transpile_annotated_expression match_cons in + ok (((hd_name , hd_ty') , (tl_name , tl_ty')) , match_cons') + in + return @@ E_if_cons (expr' , nil , cons) + ) | Match_variant (lst , variant) -> ( let%bind tree = trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@ @@ -498,7 +512,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re trace_strong (corner_case ~loc:__LOC__ "building constructor") @@ aux expr' tree'' ) - | AST.Match_list _ -> fail @@ unsupported_pattern_matching "list" ae.location | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location ) diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 1e7ff7d51..bf0193fe3 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -256,6 +256,24 @@ and translate_expression (expr:expression) (env:environment) : michelson result ]) in return code ) + | E_if_cons (cond , nil , ((hd , tl) , cons)) -> ( + let%bind cond' = translate_expression cond env in + let%bind nil' = translate_expression nil env in + let s_env = + Environment.add hd + @@ Environment.add tl env + in + let%bind s' = translate_expression cons s_env in + let%bind code = ok (seq [ + cond' ; + i_if_cons (seq [ + s' ; + dip (seq [ i_drop ; i_drop ]) ; + ]) nil' + ; + ]) in + return code + ) | E_if_left (c, (l_ntv , l), (r_ntv , r)) -> ( let%bind c' = translate_expression c env in let l_env = Environment.add l_ntv env in diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 514a091df..36298bbf6 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -89,8 +89,8 @@ and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fu fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst | Match_bool {match_true ; match_false} -> fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false - | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> - fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons + | Match_list {match_nil ; match_cons = (((hd_name , _), (tl_name , _)), match_cons)} -> + fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd_name tl_name f match_cons | Match_option {match_none ; match_some = (some, match_some)} -> fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f match_some diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index c13200c9a..3f99790fd 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -199,7 +199,7 @@ module Free_variables = struct and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m -> match m with | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) - | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c) + | Match_list { match_nil = n ; match_cons = (((hd, _), (tl, _)), c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c) | Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s) | Match_tuple (lst , a) -> f (union (of_list lst) b) a | Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index 9e9520e3d..dc74d35b2 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -107,7 +107,7 @@ module Captured_variables = struct let%bind t' = f b t in let%bind fa' = f b fa in ok @@ union t' fa' - | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> + | Match_list { match_nil = n ; match_cons = (((hd, _), (tl, _)), c) } -> let%bind n' = f b n in let%bind c' = f (union (of_list [hd ; tl]) b) c in ok @@ union n' c' diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index f7ef1595f..06a63e975 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -138,7 +138,7 @@ and 'a matching = } | Match_list of { match_nil : 'a ; - match_cons : name * name * 'a ; + match_cons : ((name * type_value) * (name * type_value)) * 'a ; } | Match_option of { match_none : 'a ; diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 3bb230627..52d87a887 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -80,6 +80,7 @@ and expression' ppf (e:expression') = match e with | E_make_none _ -> fprintf ppf "none" | E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s + | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%s :: %s) -> %a" expression c expression n hd_name tl_name expression cons | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index 26801d227..bbffddbc6 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -69,6 +69,7 @@ and expression' = | E_iterator of (string * ((var_name * type_value) * expression) * expression) | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) + | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) | E_let_in of ((var_name * type_value) * expression * expression) | E_sequence of (expression * expression) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index df2b2cb86..e7030bc1f 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -722,7 +722,7 @@ let main = test_suite "Integration (End to End)" [ test "let-in (mligo)" let_in_mligo ; test "match variant (mligo)" match_variant ; test "match variant 2 (mligo)" match_matej ; - (* test "list matching (mligo)" mligo_list ; *) + test "list matching (mligo)" mligo_list ; (* test "guess the hash mligo" guess_the_hash_mligo ; WIP? *) (* test "failwith mligo" failwith_mligo ; *) (* test "guess string mligo" guess_string_mligo ; WIP? *) diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index f55e1a493..5ac8d1282 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -60,6 +60,7 @@ let i_exec = prim I_EXEC let i_if a b = prim ~children:[seq [a] ; seq[b]] I_IF let i_if_none a b = prim ~children:[seq [a] ; seq[b]] I_IF_NONE +let i_if_cons a b = prim ~children:[seq [a] ; seq[b]] I_IF_CONS let i_if_left a b = prim ~children:[seq [a] ; seq[b]] I_IF_LEFT let i_failwith = prim I_FAILWITH let i_assert_some = i_if_none (seq [i_push_string "ASSERT_SOME" ; i_failwith]) (seq []) From 9fb65e71e803fc6599cb060c572303d9b10f1f65 Mon Sep 17 00:00:00 2001 From: galfour Date: Sat, 21 Sep 2019 11:30:41 +0200 Subject: [PATCH 27/53] more lists --- src/passes/2-simplify/pascaligo.ml | 20 ++++++++++++++------ src/test/contracts/list.mligo | 4 ++++ src/test/contracts/match.ligo | 7 +++++++ src/test/integration_tests.ml | 28 +++++++++++++++++++++------- 4 files changed, 46 insertions(+), 13 deletions(-) diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 92250a149..0a6fe63d3 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -247,7 +247,9 @@ module Errors = struct let pattern_loc = Raw.pattern_to_region p in let data = [ ("pattern_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) + fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ; + ("pattern", + fun () -> Format.asprintf "%a" (Simple_utils.PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) p) ; ] in error ~data title message @@ -914,7 +916,6 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - | p -> fail @@ unsupported_non_var_pattern p in let get_tuple (t: Raw.pattern) = match t with - | PCons v -> npseq_to_list v.value | PTuple v -> npseq_to_list v.value.inside | x -> [ x ] in let get_single (t: Raw.pattern) = @@ -923,6 +924,15 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - trace_strong (unsupported_tuple_pattern t) @@ Assert.assert_list_size t' 1 in ok (List.hd t') in + let get_toplevel (t : Raw.pattern) = + match t with + | PCons x -> ( + let (x' , lst) = x.value in + match lst with + | [] -> ok x' + | _ -> ok t + ) + | _ -> fail @@ corner_case ~loc:__LOC__ "unexpected pattern" in let get_constr (t: Raw.pattern) = match t with | PConstr v -> ( @@ -943,10 +953,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - | _ -> fail @@ only_constructors t in let%bind patterns = let aux (x , y) = - let xs = get_tuple x in - trace_strong (unsupported_tuple_pattern x) @@ - Assert.assert_list_size xs 1 >>? fun () -> - ok (List.hd xs , y) + let%bind x' = get_toplevel x in + ok (x' , y) in bind_map_list aux t in match patterns with | [(PFalse _ , f) ; (PTrue _ , t)] diff --git a/src/test/contracts/list.mligo b/src/test/contracts/list.mligo index 31e2f7d50..34450fde8 100644 --- a/src/test/contracts/list.mligo +++ b/src/test/contracts/list.mligo @@ -2,6 +2,10 @@ type storage = int * int list type param = int list +let x : int list = [] +let y : int list = [ 3 ; 4 ; 5 ] +let z : int list = 2 :: y + let%entry main (p : param) storage = let storage = match p with diff --git a/src/test/contracts/match.ligo b/src/test/contracts/match.ligo index ff5e3a0a4..cddde26c0 100644 --- a/src/test/contracts/match.ligo +++ b/src/test/contracts/match.ligo @@ -29,3 +29,10 @@ function match_expr_option (const o : option(int)) : int is | None -> 42 | Some (s) -> s end + +function match_expr_list (const l : list(int)) : int is + begin skip end with + case l of + | nil -> -1 + | hd # tl -> hd + end diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index e7030bc1f..9215b5a5c 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -517,6 +517,13 @@ let matching () : unit result = bind_iter_list aux [Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None] in + let%bind () = + let aux lst = e_annotation (e_list @@ List.map e_int lst) (t_list t_int) in + let%bind () = expect_eq program "match_expr_list" (aux [ 14 ; 2 ; 3 ]) (e_int 14) in + let%bind () = expect_eq program "match_expr_list" (aux [ 13 ; 2 ; 3 ]) (e_int 13) in + let%bind () = expect_eq program "match_expr_list" (aux []) (e_int (-1)) in + ok () + in ok () let declarations () : unit result = @@ -635,13 +642,20 @@ let match_matej () : unit result = let mligo_list () : unit result = let%bind program = mtype_file "./contracts/list.mligo" in - let make_input n = - e_pair (e_list [e_int n; e_int (2*n)]) - (e_pair (e_int 3) (e_list [e_int 8])) in - let make_expected n = - e_pair (e_typed_list [] t_operation) - (e_pair (e_int (n+3)) (e_list [e_int (2*n)])) - in expect_eq_n program "main" make_input make_expected + let%bind () = + let make_input n = + e_pair (e_list [e_int n; e_int (2*n)]) + (e_pair (e_int 3) (e_list [e_int 8])) in + let make_expected n = + e_pair (e_typed_list [] t_operation) + (e_pair (e_int (n+3)) (e_list [e_int (2*n)])) + in + expect_eq_n program "main" make_input make_expected + in + let%bind () = expect_eq_evaluate program "x" (e_list []) in + let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in + let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in + ok () let lambda_mligo () : unit result = let%bind program = mtype_file "./contracts/lambda.mligo" in From 2773a2e4cd719e1813ec715e5d1f5ef00203b562 Mon Sep 17 00:00:00 2001 From: Matej Sima Date: Sat, 21 Sep 2019 14:28:33 +0200 Subject: [PATCH 28/53] Bring back local-repo-job for testing --- .gitlab-ci.yml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fd988aca4..6f6889714 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -76,14 +76,14 @@ local-dune-job: # TODO: uncomment this -# TODO -# local-repo-job: -# <<: *before_script -# stage: test -# script: -# - scripts/install_vendors_deps.sh -# # TODO: also try from time to time with --build-test -# - opam install -y ligo +local-repo-job: + <<: *before_script + stage: test + script: + - scripts/install_vendors_deps.sh + # TODO: also try from time to time with --build-test + - opam install -y ligo + - ligo remote-repo-job: <<: *before_script From 2909530b22132fa02adbdff36d53c523771c6a10 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Sat, 21 Sep 2019 13:35:08 -0700 Subject: [PATCH 29/53] Ignore pp.ligos in root --- .gitignore | 1 + super-counter.pp.ligo | 65 ------------------------------------------- 2 files changed, 1 insertion(+), 65 deletions(-) delete mode 100644 super-counter.pp.ligo diff --git a/.gitignore b/.gitignore index bf25b5759..793d181d1 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ dune-project cache/* Version.ml /_opam/ +/*.pp.ligo diff --git a/super-counter.pp.ligo b/super-counter.pp.ligo deleted file mode 100644 index 0097fbc63..000000000 --- a/super-counter.pp.ligo +++ /dev/null @@ -1,65 +0,0 @@ -# 1 "./src/test/contracts/super-counter.ligo" -# 1 "" -# 1 "" -# 31 "" -# 1 "/usr/include/stdc-predef.h" 1 3 4 - -# 17 "/usr/include/stdc-predef.h" 3 4 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -# 32 "" 2 -# 1 "./src/test/contracts/super-counter.ligo" -type action is -| Increment of int -| Decrement of int - -function main (const p : action ; const s : int) : (list(operation) * int) is - block {skip} with ((nil : list(operation)), - case p of - | Increment (n) -> s + n - | Decrement (n) -> s - n - end) From 33dbd11482fb5ed2802071cacd4ffbe14a990bfe Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Sat, 21 Sep 2019 13:50:01 -0700 Subject: [PATCH 30/53] Delete broken local-repo-job --- .gitlab-ci.yml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6f6889714..223f33240 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -74,17 +74,6 @@ local-dune-job: - scripts/build_ligo_local.sh - dune build @ligo-test -# TODO: uncomment this - -local-repo-job: - <<: *before_script - stage: test - script: - - scripts/install_vendors_deps.sh - # TODO: also try from time to time with --build-test - - opam install -y ligo - - ligo - remote-repo-job: <<: *before_script stage: test From 0cfb40f54df922166dca0c50efb5d4132c430ad3 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Sat, 21 Sep 2019 14:59:48 -0700 Subject: [PATCH 31/53] Add purpose comments to some test contracts Add comments explaining what a contract is/does/tests to the top of several PascaLIGO test contracts, as part of evaluating what parts of the syntax are and aren't currently tested. --- src/contracts/annotation.ligo | 2 ++ src/contracts/arithmetic.ligo | 2 ++ src/contracts/bitwise_arithmetic.ligo | 2 ++ src/contracts/boolean_operators.ligo | 2 ++ src/contracts/closure-3.ligo | 4 ++++ src/contracts/condition-simple.ligo | 2 ++ src/contracts/condition.ligo | 2 ++ src/contracts/declaration-local.ligo | 2 ++ src/contracts/declarations.ligo | 2 ++ src/contracts/error_type.ligo | 4 +++- src/contracts/function-complex.ligo | 2 ++ src/contracts/function-shared.ligo | 2 ++ src/contracts/function.ligo | 2 ++ src/contracts/heap.ligo | 3 +++ src/contracts/high-order.ligo | 2 ++ src/contracts/included.ligo | 2 ++ src/contracts/includer.ligo | 2 ++ src/contracts/list.ligo | 2 ++ src/contracts/loop.ligo | 2 ++ src/contracts/map.ligo | 2 ++ src/contracts/match.ligo | 2 ++ src/contracts/multiple-parameters.ligo | 2 ++ src/contracts/option.ligo | 2 ++ src/contracts/record.ligo | 2 ++ src/contracts/set_arithmetic-1.ligo | 2 ++ src/contracts/set_arithmetic.ligo | 2 ++ 26 files changed, 56 insertions(+), 1 deletion(-) diff --git a/src/contracts/annotation.ligo b/src/contracts/annotation.ligo index 1cae3ffe9..2029e3aa6 100644 --- a/src/contracts/annotation.ligo +++ b/src/contracts/annotation.ligo @@ -1,3 +1,5 @@ +// Test that type annotations work in PascaLIGO + const lst : list(int) = list [] ; const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ; diff --git a/src/contracts/arithmetic.ligo b/src/contracts/arithmetic.ligo index efaa0e62b..1040aeebf 100644 --- a/src/contracts/arithmetic.ligo +++ b/src/contracts/arithmetic.ligo @@ -1,3 +1,5 @@ +// Test PascaLIGO arithmetic operators + function mod_op (const n : int) : nat is begin skip end with n mod 42 diff --git a/src/contracts/bitwise_arithmetic.ligo b/src/contracts/bitwise_arithmetic.ligo index 0711b5854..282b82be9 100644 --- a/src/contracts/bitwise_arithmetic.ligo +++ b/src/contracts/bitwise_arithmetic.ligo @@ -1,3 +1,5 @@ +// Test PascaLIGO bitwise operators + function or_op (const n : nat) : nat is begin skip end with bitwise_or(n , 4n) diff --git a/src/contracts/boolean_operators.ligo b/src/contracts/boolean_operators.ligo index 38b94ba02..4b53ff2d5 100644 --- a/src/contracts/boolean_operators.ligo +++ b/src/contracts/boolean_operators.ligo @@ -1,3 +1,5 @@ +// Test PascaLIGO boolean operators + function or_true (const b : bool) : bool is begin skip end with b or True diff --git a/src/contracts/closure-3.ligo b/src/contracts/closure-3.ligo index 71fb67269..98ad10cb0 100644 --- a/src/contracts/closure-3.ligo +++ b/src/contracts/closure-3.ligo @@ -1,3 +1,7 @@ +// This might seem like it's covered by induction with closure-2.ligo +// But it exists to prevent a regression on the bug patched by: +// https://gitlab.com/ligolang/ligo/commit/faf3bbc06106de98189f1c1673bd57e78351dc7e + function foobar(const i : int) : int is const j : int = 3 ; const k : int = 4 ; diff --git a/src/contracts/condition-simple.ligo b/src/contracts/condition-simple.ligo index 708d4c6b5..9df22cbe3 100644 --- a/src/contracts/condition-simple.ligo +++ b/src/contracts/condition-simple.ligo @@ -1,3 +1,5 @@ +// Test if conditional with trivial conditions in PascaLIGO + function main (const i : int) : int is begin if 1 = 1 then diff --git a/src/contracts/condition.ligo b/src/contracts/condition.ligo index 68c949640..98672b1c9 100644 --- a/src/contracts/condition.ligo +++ b/src/contracts/condition.ligo @@ -1,3 +1,5 @@ +// Test if conditional in PascaLIGO + function main (const i : int) : int is var result : int := 23 ; begin diff --git a/src/contracts/declaration-local.ligo b/src/contracts/declaration-local.ligo index 94d443b32..97f380112 100644 --- a/src/contracts/declaration-local.ligo +++ b/src/contracts/declaration-local.ligo @@ -1,3 +1,5 @@ +// Test PasaLIGO variable declarations inside of a block + function main (const i : int) : int is block { const j : int = 42 ; } with j diff --git a/src/contracts/declarations.ligo b/src/contracts/declarations.ligo index c153b0c57..4001fbdbf 100644 --- a/src/contracts/declarations.ligo +++ b/src/contracts/declarations.ligo @@ -1,3 +1,5 @@ +// Test PascaLIGO top level declarations + const foo : int = 42 function main (const i : int) : int is diff --git a/src/contracts/error_type.ligo b/src/contracts/error_type.ligo index 79e114388..6f828b9bf 100644 --- a/src/contracts/error_type.ligo +++ b/src/contracts/error_type.ligo @@ -1 +1,3 @@ -const foo : nat = 42 + "bar" \ No newline at end of file +// Test that PascaLIGO will reject a type declaration with improper value expression + +const foo : nat = 42 + "bar" diff --git a/src/contracts/function-complex.ligo b/src/contracts/function-complex.ligo index ec34cab7e..f1f33c74c 100644 --- a/src/contracts/function-complex.ligo +++ b/src/contracts/function-complex.ligo @@ -1,3 +1,5 @@ +// Test a PascaLIGO function with more complex logic than function.ligo + function main (const i : int) : int is var j : int := 0 ; var k : int := 1 ; diff --git a/src/contracts/function-shared.ligo b/src/contracts/function-shared.ligo index c84fec402..0155b5cb1 100644 --- a/src/contracts/function-shared.ligo +++ b/src/contracts/function-shared.ligo @@ -1,3 +1,5 @@ +// Test a PascaLIGO function which uses other functions as subroutines + function inc ( const i : int ) : int is block { skip } with i + 1 diff --git a/src/contracts/function.ligo b/src/contracts/function.ligo index 8149b2e15..27f4437ef 100644 --- a/src/contracts/function.ligo +++ b/src/contracts/function.ligo @@ -1,3 +1,5 @@ +// Test a trivial PascaLIGO function + function main (const i : int) : int is begin skip diff --git a/src/contracts/heap.ligo b/src/contracts/heap.ligo index 23d7425b7..48130f96b 100644 --- a/src/contracts/heap.ligo +++ b/src/contracts/heap.ligo @@ -1,3 +1,6 @@ +// Implementation of the heap data structure in PascaLIGO +// See: https://en.wikipedia.org/wiki/Heap_%28data_structure%29 + type heap is map(nat, heap_element) ; function is_empty (const h : heap) : bool is diff --git a/src/contracts/high-order.ligo b/src/contracts/high-order.ligo index 8dc7f3e4b..7c897d4ee 100644 --- a/src/contracts/high-order.ligo +++ b/src/contracts/high-order.ligo @@ -1,3 +1,5 @@ +// Test a PascaLIGO function which takes another PascaLIGO function as an argument + function foobar (const i : int) : int is function foo (const i : int) : int is block { skip } with i ; diff --git a/src/contracts/included.ligo b/src/contracts/included.ligo index 3f0a2d1ca..1ab1451af 100644 --- a/src/contracts/included.ligo +++ b/src/contracts/included.ligo @@ -1 +1,3 @@ +// Test PascaLIGO inclusion statements, see includer.ligo + const foo : int = 144 diff --git a/src/contracts/includer.ligo b/src/contracts/includer.ligo index e68975796..3afbfaa79 100644 --- a/src/contracts/includer.ligo +++ b/src/contracts/includer.ligo @@ -1,3 +1,5 @@ +// Test PascaLIGO inclusion statements, see included.ligo + #include "included.ligo" const bar : int = foo diff --git a/src/contracts/list.ligo b/src/contracts/list.ligo index a533d12e2..0a1d0c05d 100644 --- a/src/contracts/list.ligo +++ b/src/contracts/list.ligo @@ -1,3 +1,5 @@ +// Test list type and related built-in functions in PascaLIGO + type foobar is list(int) const fb : foobar = list diff --git a/src/contracts/loop.ligo b/src/contracts/loop.ligo index 0408f85ef..fcba9fda7 100644 --- a/src/contracts/loop.ligo +++ b/src/contracts/loop.ligo @@ -1,3 +1,5 @@ +// Test while loops in PascaLIGO + function counter (var n : nat) : nat is block { var i : nat := 0n ; while (i < n) block { diff --git a/src/contracts/map.ligo b/src/contracts/map.ligo index f0576bf54..af3697768 100644 --- a/src/contracts/map.ligo +++ b/src/contracts/map.ligo @@ -1,3 +1,5 @@ +// Test map type and related built-in functions in PascaLIGO + type foobar is map(int, int) const fb : foobar = map diff --git a/src/contracts/match.ligo b/src/contracts/match.ligo index ff5e3a0a4..fa204e5e1 100644 --- a/src/contracts/match.ligo +++ b/src/contracts/match.ligo @@ -1,3 +1,5 @@ +// Test the pattern matching functionality of PascaLIGO + function match_bool (const i : int) : int is var result : int := 23 ; begin diff --git a/src/contracts/multiple-parameters.ligo b/src/contracts/multiple-parameters.ligo index fe2373076..26f5daa0d 100644 --- a/src/contracts/multiple-parameters.ligo +++ b/src/contracts/multiple-parameters.ligo @@ -1,3 +1,5 @@ +// Test functions with several parameters in PascaLIGO + function ab(const a : int; const b : int) : int is begin skip end with (a + b) diff --git a/src/contracts/option.ligo b/src/contracts/option.ligo index 85e3396e0..c2d36439d 100644 --- a/src/contracts/option.ligo +++ b/src/contracts/option.ligo @@ -1,3 +1,5 @@ +// Test the option type in PascaLIGO + type foobar is option(int) const s : foobar = Some(42) diff --git a/src/contracts/record.ligo b/src/contracts/record.ligo index e0fbb5d04..cb578abb0 100644 --- a/src/contracts/record.ligo +++ b/src/contracts/record.ligo @@ -1,3 +1,5 @@ +// Test record type in PascaLIGO + type foobar is record foo : int ; bar : int ; diff --git a/src/contracts/set_arithmetic-1.ligo b/src/contracts/set_arithmetic-1.ligo index 2397f72b5..0cfab61d2 100644 --- a/src/contracts/set_arithmetic-1.ligo +++ b/src/contracts/set_arithmetic-1.ligo @@ -1,3 +1,5 @@ +// Test set iteration in PascaLIGO + function iter_op (const s : set(int)) : int is var r : int := 0 ; function aggregate (const i : int) : unit is diff --git a/src/contracts/set_arithmetic.ligo b/src/contracts/set_arithmetic.ligo index f85e42394..cd7c1175c 100644 --- a/src/contracts/set_arithmetic.ligo +++ b/src/contracts/set_arithmetic.ligo @@ -1,3 +1,5 @@ +// Test set type and basic operations in PascaLIGO + const s_e : set(string) = (set_empty : set(string)) const s_fb : set(string) = set [ From 5fcb426239b7fc2b9eacbcf787589127f436d1ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matej=20=C5=A0ima?= Date: Sun, 22 Sep 2019 13:06:52 +0000 Subject: [PATCH 32/53] Refactor/add cli tests --- .gitlab-ci.yml | 3 ++ scripts/ligo_ci.sh | 1 + scripts/test_cli.sh | 117 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 121 insertions(+) create mode 100755 scripts/ligo_ci.sh create mode 100755 scripts/test_cli.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 223f33240..594efb1b5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -97,6 +97,8 @@ build-current-docker-image: stage: build_docker <<: *docker <<: *docker_build + after_script: + - scripts/test_cli.sh except: - master - dev @@ -109,6 +111,7 @@ build-and-publish-latest-docker-image: <<: *docker_build after_script: - docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD + - scripts/test_cli.sh - docker push $LIGO_REGISTRY_IMAGE:next only: - dev diff --git a/scripts/ligo_ci.sh b/scripts/ligo_ci.sh new file mode 100755 index 000000000..a39da5873 --- /dev/null +++ b/scripts/ligo_ci.sh @@ -0,0 +1 @@ +docker run -i -v "$PWD":"$PWD" -w "$PWD" ligolang/ligo:next "$@" \ No newline at end of file diff --git a/scripts/test_cli.sh b/scripts/test_cli.sh new file mode 100755 index 000000000..04581fe72 --- /dev/null +++ b/scripts/test_cli.sh @@ -0,0 +1,117 @@ +#!/bin/sh +set -e +compiled_contract=$(./scripts/ligo_ci.sh compile-contract src/test/contracts/website2.ligo main); +compiled_storage=$(./scripts/ligo_ci.sh compile-storage src/test/contracts/website2.ligo main 1); +compiled_parameter=$(./scripts/ligo_ci.sh compile-parameter src/test/contracts/website2.ligo main "Increment(1)"); +dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo main "Increment(1)" 1); + +expected_compiled_contract="{ parameter (or int int) ; + storage int ; + code { {} ; + {} ; + {} ; + { PUSH (lambda (pair int int) int) + { {} ; + {} ; + {} ; + { { { DUP ; DIP { {} } } ; CAR } ; + { { { { DIP { DUP } ; SWAP } ; DIP { {} } } ; CDR } ; + { PUSH unit Unit ; + DROP ; + { { { DIP { DUP } ; SWAP } ; DIP { { DUP ; DIP { {} } } } } ; + ADD } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } ; + {} } ; + { PUSH (lambda (pair int int) int) + { {} ; + {} ; + {} ; + { { { DUP ; DIP { {} } } ; CAR } ; + { { { { DIP { DUP } ; SWAP } ; DIP { {} } } ; CDR } ; + { PUSH unit Unit ; + DROP ; + { { { DIP { DUP } ; SWAP } ; DIP { { DUP ; DIP { {} } } } } ; + SUB } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } ; + {} } ; + { { { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } ; DIP { {} } } ; + CAR } ; + { { { { DIP { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } } ; SWAP } ; + DIP { {} } } ; + CDR } ; + { PUSH unit Unit ; + DROP ; + { { NIL operation ; + DIP { { { { DIP { DUP } ; SWAP } ; + IF_LEFT + { { { DUP ; + { { { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } ; + DIP { { DUP ; DIP { {} } } } } ; + PAIR } ; + DIP { { DIP { { DIP { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } } ; SWAP } } ; + SWAP } } ; + EXEC } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } } + { { { DUP ; + { { { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } ; + DIP { { DUP ; DIP { {} } } } } ; + PAIR } ; + DIP { { DIP { { DIP { { DIP { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } } ; SWAP } } ; + SWAP } } ; + SWAP } } ; + EXEC } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } } } ; + DIP { {} } } } } ; + PAIR } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } } ; + {} ; + DIP { DROP } ; + {} } }"; +expected_compiled_parameter="(Right 1)"; +expected_compiled_storage=1; +expected_dry_run_output="tuple[ list[] + 2 +]"; + +if [ "$compiled_contract" != "$expected_compiled_contract" ]; then + echo "Expected $expected_compiled_contract as compile-storage output, got $compiled_contract instead"; + exit 1; +fi + +if [ "$compiled_storage" != "$expected_compiled_storage" ]; then + echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead"; + exit 1; +fi + +if [ "$compiled_parameter" != "$expected_compiled_parameter" ]; then + echo "Expected $expected_compiled_parameter as compile-parameter output, got $compiled_parameter instead"; + exit 1; +fi + +if [ "$dry_run_output" != "$expected_dry_run_output" ]; then + echo "Expected $expected_dry_run_output as dry-run output, got $dry_run_output instead"; + exit 1; +fi \ No newline at end of file From 37836f9512ebc630cd869c66f9ae8a8388a233e4 Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 22 Sep 2019 22:44:50 +0200 Subject: [PATCH 33/53] adding option --- src/main/compile/of_simplified.ml | 4 ++-- src/main/compile/of_typed.ml | 3 ++- src/main/run/of_simplified.ml | 4 ++-- src/{ => test}/contracts/big_map.ligo | 0 4 files changed, 6 insertions(+), 5 deletions(-) rename src/{ => test}/contracts/big_map.ligo (100%) diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index fa27f3d6e..215c908a5 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -14,9 +14,9 @@ let compile_expression_as_function_entry (program : program) entry_point : _ res let%bind typed_program = Typer.type_program program in Of_typed.compile_expression_as_function_entry typed_program entry_point -let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = +let compile_expression ?(env = Ast_typed.Environment.full_empty) ?value ae : Michelson.t result = let%bind typed = Typer.type_expression env ae in - Of_typed.compile_expression typed + Of_typed.compile_expression ?value typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let%bind output_type = diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index e6a33abd7..ea75960b9 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -3,7 +3,8 @@ open Ast_typed open Tezos_utils -let compile_expression : annotated_expression -> Michelson.t result = fun e -> +let compile_expression ?(value = false) : annotated_expression -> Michelson.t result = fun e -> + let _ = value in let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in let%bind expr = Of_mini_c.compile_expression mini_c_expression in ok expr diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 4332ca9e5..e0e3e1a17 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -7,13 +7,13 @@ let get_final_environment program = post_env let run_typed_program - ?options + ?options ?input_to_value (program : Ast_typed.program) (entry : string) (input : expression) : expression result = let%bind code = Compile.Of_typed.compile_function_entry program entry in let%bind input = let env = get_final_environment program in - Compile.Of_simplified.compile_expression ~env input + Compile.Of_simplified.compile_expression ~env ?value:input_to_value input in let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value diff --git a/src/contracts/big_map.ligo b/src/test/contracts/big_map.ligo similarity index 100% rename from src/contracts/big_map.ligo rename to src/test/contracts/big_map.ligo From 96fd0b4660125659d5e13954bd76409d5293c4a7 Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 22 Sep 2019 23:39:15 +0200 Subject: [PATCH 34/53] yay --- src/bin/cli.ml | 4 +- src/main/compile/of_mini_c.ml | 12 +++++- src/main/compile/of_source.ml | 8 ++-- src/main/compile/of_typed.ml | 3 +- src/main/run/of_simplified.ml | 2 +- src/main/run/of_source.ml | 4 +- src/passes/8-compiler/uncompiler.ml | 6 ++- src/stages/mini_c/misc.ml | 58 +++++++++++++++++++++++++++++ src/test/integration_tests.ml | 2 +- 9 files changed, 83 insertions(+), 16 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 47aac3cd9..3ca3d2bf3 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -103,7 +103,7 @@ let compile_storage = toplevel ~display_format @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Compile.Of_source.compile_file_contract_storage ~bigmap source entry_point expression (Syntax_name syntax) in + Ligo.Compile.Of_source.compile_file_contract_storage ~value:bigmap source entry_point expression (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = @@ -116,7 +116,7 @@ let dry_run = let f source entry_point storage input amount syntax display_format bigmap = toplevel ~display_format @@ let%bind output = - Ligo.Run.Of_source.run_contract ~amount ~bigmap source entry_point storage input (Syntax_name syntax) in + Ligo.Run.Of_source.run_contract ~amount ~storage_value:bigmap source entry_point storage input (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 5a1ff886e..34d8cd753 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -5,8 +5,16 @@ open Tezos_utils let compile_value : value -> type_value -> Michelson.t result = Compiler.Program.translate_value -let compile_expression : expression -> _ result = fun e -> - Compiler.Program.translate_expression e Compiler.Environment.empty +let compile_expression ?(value = false) : expression -> _ result = fun e -> + if value then ( + let%bind value = expression_to_value e in + Format.printf "Compile to value\n" ; + let%bind result = compile_value value e.type_value in + Format.printf "Compiled to value\n" ; + ok result + ) else ( + Compiler.Program.translate_expression e Compiler.Environment.empty + ) let compile_expression_as_function : expression -> _ result = fun e -> let (input , output) = t_unit , e.type_value in diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 169dba0da..42c6adf91 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -30,19 +30,19 @@ let compile_file_expression : string -> string -> string -> s_syntax -> Michelso let%bind simplified = parsify_expression syntax expression in Of_simplified.compile_expression simplified -let compile_file_contract_storage : string -> string -> string -> s_syntax -> Michelson.t result = +let compile_file_contract_storage ~value : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind simplified = parsify_expression syntax expression in - Of_simplified.compile_expression simplified + Of_simplified.compile_expression ~value simplified let compile_file_contract_args = - fun source_filename _entry_point storage parameter syntax -> + fun ?value source_filename _entry_point storage parameter syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind storage_simplified = parsify_expression syntax storage in let%bind parameter_simplified = parsify_expression syntax parameter in let args = Ast_simplified.e_pair storage_simplified parameter_simplified in - Of_simplified.compile_expression args + Of_simplified.compile_expression ?value args let type_file ?(debug_simplify = false) ?(debug_typed = false) syntax (source_filename:string) : Ast_typed.program result = diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index ea75960b9..e8ac1e8e7 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -4,9 +4,8 @@ open Tezos_utils let compile_expression ?(value = false) : annotated_expression -> Michelson.t result = fun e -> - let _ = value in let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in - let%bind expr = Of_mini_c.compile_expression mini_c_expression in + let%bind expr = Of_mini_c.compile_expression ~value mini_c_expression in ok expr let compile_expression_as_function : annotated_expression -> _ result = fun e -> diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index e0e3e1a17..9c5d830cc 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -15,7 +15,7 @@ let run_typed_program let env = get_final_environment program in Compile.Of_simplified.compile_expression ~env ?value:input_to_value input in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind ex_ty_value = Of_michelson.run ?is_input_value:input_to_value ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value let evaluate_typed_program_entry diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index 5bc8b421c..3014cbbb7 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -46,10 +46,10 @@ include struct ok () end -let run_contract ?amount source_filename entry_point storage parameter syntax = +let run_contract ?amount ?storage_value source_filename entry_point storage parameter syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in let%bind code = Compile.Of_typed.compile_function_entry program entry_point in - let%bind args = Compile.Of_source.compile_file_contract_args source_filename entry_point storage parameter syntax in + let%bind args = Compile.Of_source.compile_file_contract_args ?value:storage_value source_filename entry_point storage parameter syntax in let%bind ex_value_ty = let options = let open Proto_alpha_utils.Memory_proto_alpha in diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml index c114d901d..2838298d3 100644 --- a/src/passes/8-compiler/uncompiler.ml +++ b/src/passes/8-compiler/uncompiler.ml @@ -77,10 +77,12 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = let aux k v acc = (k, v) :: acc in let lst = Script_ir_translator.map_fold aux m.diff [] in List.rev lst in - let%bind original_big_map = + let%bind original_big_map = match bm_opt with | Some (D_big_map l) -> ok @@ l - | _ -> fail @@ simple_error "Do not have access to the original big_map" in + | _ -> ok [] + (* | _ -> fail @@ simple_error "Do not have access to the original big_map" . When does this matter? *) + in let%bind lst' = let aux orig (k, v) = let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml index 21e049e38..60810643c 100644 --- a/src/stages/mini_c/misc.ml +++ b/src/stages/mini_c/misc.ml @@ -106,3 +106,61 @@ let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) : Format.printf "Not functional: %a\n" PP.expression entry_expression ; fail @@ Errors.not_functional_main name ) + +let rec expression_to_value (exp: expression) : value result = + match exp.content with + | E_literal v -> ok @@ v + | E_constant ("map" , lst) -> + let aux el = + let%bind l = expression_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_map lstl + | E_constant ("big_map" , lst) -> + let aux el = + let%bind l = expression_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_big_map lstl + | E_constant ("PAIR" , fst::snd::[]) -> + let%bind fstl = expression_to_value fst in + let%bind sndl = expression_to_value snd in + ok @@ D_pair (fstl , sndl) + | E_constant ("UNIT", _) -> ok @@ D_unit + | E_constant ("UPDATE", _) -> + let rec handle_prev upd = + match upd.content with + | E_constant ("UPDATE" , [k;v;prev]) -> + begin + match v.content with + | E_constant ("SOME" , [i]) -> + let%bind kl = expression_to_value k in + let%bind il = expression_to_value i in + let%bind prevl = handle_prev prev in + ok @@ (kl,il)::prevl + | E_constant ("NONE" , []) -> + let%bind prevl = handle_prev prev in + ok @@ prevl + | _ -> failwith "UPDATE second parameter is not an option" + end + | E_make_empty_map _ -> + ok @@ [] + | _ -> failwith "Ill-constructed map" + in + begin + match exp.type_value with + | T_big_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_big_map kvl + | T_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_map kvl + | _ -> failwith "UPDATE with a non-map type_value" + end + | _ as nl -> + let expp = Format.asprintf "'%a'" PP.expression' nl in + fail @@ simple_error ("Can not convert expression "^expp^" to literal") diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index f3f49af85..639310afc 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -417,7 +417,7 @@ let big_map () : unit result = let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_expected = e_int in - expect_eq_n ?input_to_value:(Some true) program "gf" make_input make_expected + expect_eq_n ~input_to_value:true program "gf" make_input make_expected in let%bind () = let make_input = fun n -> From c07f0633cd38ec1d90b6c46624764f6447b77d9a Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 4 Sep 2019 09:41:14 -0700 Subject: [PATCH 35/53] Print errors to stderr, exit 1 --- src/bin/cli_helpers.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index dacac127e..ee757ffba 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -9,4 +9,8 @@ let toplevel ~(display_format : string) (x : string result) = failwith "Display format" ) in - Format.printf "%a" (formatted_string_result_pp display_format) x + match x with + | Ok _ -> Format.printf "%a" (formatted_string_result_pp display_format) x + | Error _ -> + Format.eprintf "%a" (formatted_string_result_pp display_format) x ; + exit 1 From b41b676eb8152792344536fb03dd2b27a4366597 Mon Sep 17 00:00:00 2001 From: galfour Date: Mon, 23 Sep 2019 23:33:25 +0200 Subject: [PATCH 36/53] add list fold --- src/passes/6-transpiler/transpiler.ml | 73 ++++++++++++----------- src/passes/8-compiler/compiler_program.ml | 14 +++++ src/passes/operators/helpers.ml | 2 +- src/passes/operators/operators.ml | 24 +++++++- src/stages/mini_c/PP.ml | 2 + src/stages/mini_c/types.ml | 1 + src/test/contracts/list.mligo | 4 ++ src/test/integration_tests.ml | 28 +++++---- 8 files changed, 98 insertions(+), 50 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 9fbf55374..f1c61f7ba 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -361,47 +361,52 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let expr = List.fold_left aux record' path in ok expr | E_constant (name , lst) -> ( - let (iter , map) = - let iterator name = fun (lst : AST.annotated_expression list) -> match lst with - | [i ; f] -> ( - let%bind f' = match f.expression with - | E_lambda l -> ( - let%bind body' = transpile_annotated_expression l.body in - let%bind (input , _) = AST.get_t_function f.type_annotation in - let%bind input' = transpile_type input in - ok ((l.binder , input') , body') - ) - | E_variable v -> ( - let%bind elt = - trace_option (corner_case ~loc:__LOC__ "missing var") @@ - AST.Environment.get_opt v f.environment in - match elt.definition with - | ED_declaration (f , _) -> ( - match f.expression with - | E_lambda l -> ( - let%bind body' = transpile_annotated_expression l.body in - let%bind (input , _) = AST.get_t_function f.type_annotation in - let%bind input' = transpile_type input in - ok ((l.binder , input') , body') - ) - | _ -> fail @@ unsupported_iterator f.location - ) - | _ -> fail @@ unsupported_iterator f.location - ) - | _ -> fail @@ unsupported_iterator f.location - in - let%bind i' = transpile_annotated_expression i in - return @@ E_iterator (name , f' , i') - ) - | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity" + let iterator_generator iterator_name = + let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) = + let%bind body' = transpile_annotated_expression l.body in + let%bind (input , _) = AST.get_t_function f.type_annotation in + let%bind input' = transpile_type input in + ok ((l.binder , input') , body') in - iterator "ITER" , iterator "MAP" in + let expression_to_iterator_body (f : AST.annotated_expression) = + match f.expression with + | E_lambda l -> lambda_to_iterator_body f l + | E_variable v -> ( + let%bind elt = + trace_option (corner_case ~loc:__LOC__ "missing var") @@ + AST.Environment.get_opt v f.environment in + match elt.definition with + | ED_declaration (f , _) -> ( + match f.expression with + | E_lambda l -> lambda_to_iterator_body f l + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + in + fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with + | [i ; f] , "ITER" | [i ; f] , "MAP" -> ( + let%bind f' = expression_to_iterator_body f in + let%bind i' = transpile_annotated_expression i in + return @@ E_iterator (iterator_name , f' , i') + ) + | [ collection ; initial ; f ] , "FOLD" -> ( + let%bind f' = expression_to_iterator_body f in + let%bind initial' = transpile_annotated_expression initial in + let%bind collection' = transpile_annotated_expression collection in + return @@ E_fold (f' , collection' , initial') + ) + | _ -> fail @@ corner_case ~loc:__LOC__ ("bad iterator arity:" ^ iterator_name) + in + let (iter , map , fold) = iterator_generator "ITER" , iterator_generator "MAP" , iterator_generator "FOLD" in match (name , lst) with | ("SET_ITER" , lst) -> iter lst | ("LIST_ITER" , lst) -> iter lst | ("MAP_ITER" , lst) -> iter lst | ("LIST_MAP" , lst) -> map lst | ("MAP_MAP" , lst) -> map lst + | ("LIST_FOLD" , lst) -> fold lst | _ -> ( let%bind lst' = bind_map_list (transpile_annotated_expression) lst in return @@ E_constant (name , lst') diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 8d42c1d3d..783b1d6ad 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -339,6 +339,20 @@ and translate_expression (expr:expression) (env:environment) : michelson result fail error ) ) + | E_fold ((v , body) , collection , initial) -> ( + let%bind collection' = translate_expression collection env in + let%bind initial' = translate_expression initial env in + let%bind body' = translate_expression body (Environment.add v env) in + let code = seq [ + collection' ; + dip initial' ; + i_iter (seq [ + i_swap ; + i_pair ; body' ; dip i_drop ; + ]) ; + ] in + ok code + ) | E_assignment (name , lrs , expr) -> ( let%bind expr' = translate_expression expr env in let%bind get_code = Compiler_environment.get env name in diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index 8fd18a16f..b588605f2 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -104,7 +104,7 @@ module Typer = struct let eq_1 a cst = type_value_eq (a , cst) let eq_2 (a , b) cst = type_value_eq (a , cst) && type_value_eq (b , cst) - let assert_eq_1 a b = Assert.assert_true (eq_1 a b) + let assert_eq_1 ?msg a b = Assert.assert_true ?msg (eq_1 a b) let comparator : string -> typer = fun s -> typer_2 s @@ fun a b -> let%bind () = diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 71a135f7c..927d16c6c 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -82,6 +82,7 @@ module Simplify = struct ("set_remove" , "SET_REMOVE") ; ("set_iter" , "SET_ITER") ; ("list_iter" , "LIST_ITER") ; + ("list_fold" , "LIST_FOLD") ; ("list_map" , "LIST_MAP") ; ("map_iter" , "MAP_ITER") ; ("map_map" , "MAP_MAP") ; @@ -152,6 +153,8 @@ module Simplify = struct ("Map.update" , "MAP_UPDATE") ; ("Map.add" , "MAP_ADD") ; ("Map.remove" , "MAP_REMOVE") ; + ("Map.iter" , "MAP_ITER") ; + ("Map.map" , "MAP_MAP") ; ("String.length", "SIZE") ; ("String.size", "SIZE") ; @@ -161,7 +164,9 @@ module Simplify = struct ("List.length", "SIZE") ; ("List.size", "SIZE") ; - ("List.iter", "ITER") ; + ("List.iter", "LIST_ITER") ; + ("List.map" , "LIST_MAP") ; + ("List.fold" , "LIST_FOLD") ; ("Operation.transaction" , "CALL") ; ("Operation.get_contract" , "CONTRACT") ; @@ -483,7 +488,21 @@ module Typer = struct let%bind key = get_t_list lst in if eq_1 key arg then ok (t_list res ()) - else simple_fail "bad list iter" + else simple_fail "bad list map" + + let list_fold = typer_3 "LIST_FOLD" @@ fun lst init body -> + let%bind (arg , res) = get_t_function body in + let%bind (prec , cur) = get_t_pair arg in + let%bind key = get_t_list lst in + let msg = Format.asprintf "%a vs %a" + Ast_typed.PP.type_value key + Ast_typed.PP.type_value arg + in + trace (simple_error ("bad list fold:" ^ msg)) @@ + let%bind () = assert_eq_1 ~msg:"key cur" key cur in + let%bind () = assert_eq_1 ~msg:"prec res" prec res in + let%bind () = assert_eq_1 ~msg:"res init" res init in + ok res let not_ = typer_1 "NOT" @@ fun elt -> if eq_1 elt (t_bool ()) @@ -570,6 +589,7 @@ module Typer = struct set_iter ; list_iter ; list_map ; + list_fold ; int ; size ; failwith_ ; diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index f3863dca6..d35d38b64 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -90,6 +90,8 @@ and expression' ppf (e:expression') = match e with fprintf ppf "let %s = %a in ( %a )" name expression expr expression body | E_iterator (s , ((name , _) , body) , expr) -> fprintf ppf "for_%s %s of %a do ( %a )" s name expression expr expression body + | E_fold (((name , _) , body) , collection , initial) -> + fprintf ppf "fold %a on %a with %s do ( %a )" expression collection expression initial name expression body | E_assignment (r , path , e) -> fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e | E_while (e , b) -> diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index f7fdb0d05..b2c7a2499 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -69,6 +69,7 @@ and expression' = | E_make_empty_set of type_value | E_make_none of type_value | E_iterator of (string * ((var_name * type_value) * expression) * expression) + | E_fold of (((var_name * type_value) * expression) * expression * expression) | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) diff --git a/src/test/contracts/list.mligo b/src/test/contracts/list.mligo index 34450fde8..10d9dcf91 100644 --- a/src/test/contracts/list.mligo +++ b/src/test/contracts/list.mligo @@ -12,3 +12,7 @@ let%entry main (p : param) storage = [] -> storage | hd::tl -> storage.(0) + hd, tl in (([] : operation list), storage) + +let fold_op (s : int list) : int = + let aggregate = fun (prec : int) (cur : int) -> prec + cur in + List.fold s 10 aggregate diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 639310afc..4e280647e 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -674,19 +674,21 @@ let match_matej () : unit result = let mligo_list () : unit result = let%bind program = mtype_file "./contracts/list.mligo" in - let%bind () = - let make_input n = - e_pair (e_list [e_int n; e_int (2*n)]) - (e_pair (e_int 3) (e_list [e_int 8])) in - let make_expected n = - e_pair (e_typed_list [] t_operation) - (e_pair (e_int (n+3)) (e_list [e_int (2*n)])) - in - expect_eq_n program "main" make_input make_expected - in - let%bind () = expect_eq_evaluate program "x" (e_list []) in - let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in - let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in + let aux lst = e_list @@ List.map e_int lst in + let%bind () = expect_eq program "fold_op" (aux [ 1 ; 2 ; 3 ]) (e_int 16) in + (* let%bind () = + * let make_input n = + * e_pair (e_list [e_int n; e_int (2*n)]) + * (e_pair (e_int 3) (e_list [e_int 8])) in + * let make_expected n = + * e_pair (e_typed_list [] t_operation) + * (e_pair (e_int (n+3)) (e_list [e_int (2*n)])) + * in + * expect_eq_n program "main" make_input make_expected + * in + * let%bind () = expect_eq_evaluate program "x" (e_list []) in + * let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in + * let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in *) ok () let lambda_mligo () : unit result = From c4752c59353bc3c5e0c7471b2fa39b452bd4c93b Mon Sep 17 00:00:00 2001 From: galfour Date: Mon, 23 Sep 2019 23:46:47 +0200 Subject: [PATCH 37/53] add map fold --- src/passes/6-transpiler/transpiler.ml | 1 + src/passes/operators/operators.ml | 26 +++++++++++++--------- src/test/contracts/map.ligo | 4 ++++ src/test/integration_tests.ml | 31 ++++++++++++++++----------- 4 files changed, 39 insertions(+), 23 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index f1c61f7ba..11ff10988 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -407,6 +407,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | ("LIST_MAP" , lst) -> map lst | ("MAP_MAP" , lst) -> map lst | ("LIST_FOLD" , lst) -> fold lst + | ("MAP_FOLD" , lst) -> fold lst | _ -> ( let%bind lst' = bind_map_list (transpile_annotated_expression) lst in return @@ E_constant (name , lst') diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 927d16c6c..9ead3b7bd 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -86,6 +86,7 @@ module Simplify = struct ("list_map" , "LIST_MAP") ; ("map_iter" , "MAP_ITER") ; ("map_map" , "MAP_MAP") ; + ("map_fold" , "MAP_FOLD") ; ("sha_256" , "SHA256") ; ("sha_512" , "SHA512") ; ("blake2b" , "BLAKE2b") ; @@ -155,6 +156,7 @@ module Simplify = struct ("Map.remove" , "MAP_REMOVE") ; ("Map.iter" , "MAP_ITER") ; ("Map.map" , "MAP_MAP") ; + ("Map.fold" , "LIST_FOLD") ; ("String.length", "SIZE") ; ("String.size", "SIZE") ; @@ -285,16 +287,6 @@ module Typer = struct let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () - let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> - let%bind (k, v) = get_t_map m in - let%bind (arg_1 , res) = get_t_function f in - let%bind (arg_2 , res') = get_t_function res in - let%bind (arg_3 , res'') = get_t_function res' in - let%bind () = assert_eq_1 arg_1 k in - let%bind () = assert_eq_1 arg_2 v in - let%bind () = assert_eq_1 arg_3 res'' in - ok @@ res' - let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ @@ -504,6 +496,20 @@ module Typer = struct let%bind () = assert_eq_1 ~msg:"res init" res init in ok res + let map_fold = typer_3 "MAP_FOLD" @@ fun map init body -> + let%bind (arg , res) = get_t_function body in + let%bind (prec , cur) = get_t_pair arg in + let%bind (key , value) = get_t_map map in + let msg = Format.asprintf "%a vs %a" + Ast_typed.PP.type_value key + Ast_typed.PP.type_value arg + in + trace (simple_error ("bad list fold:" ^ msg)) @@ + let%bind () = assert_eq_1 ~msg:"key cur" (t_pair key value ()) cur in + let%bind () = assert_eq_1 ~msg:"prec res" prec res in + let%bind () = assert_eq_1 ~msg:"res init" res init in + ok res + let not_ = typer_1 "NOT" @@ fun elt -> if eq_1 elt (t_bool ()) then ok @@ t_bool () diff --git a/src/test/contracts/map.ligo b/src/test/contracts/map.ligo index af3697768..722412603 100644 --- a/src/test/contracts/map.ligo +++ b/src/test/contracts/map.ligo @@ -44,3 +44,7 @@ function iter_op (const m : foobar) : int is function map_op (const m : foobar) : foobar is function increment (const i : int ; const j : int) : int is block { skip } with j + 1 ; block { skip } with map_map(m , increment) ; + +function fold_op (const m : foobar) : int is + function aggregate (const i : int ; const j : (int * int)) : int is block { skip } with i + j.0 + j.1 ; + block { skip } with map_fold(m , 10 , aggregate) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 4e280647e..eab8395da 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -400,6 +400,11 @@ let map () : unit result = let expected = e_int 66 in expect_eq program "iter_op" input expected in + let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = e_int 76 in + expect_eq program "fold_op" input expected + in let%bind () = let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in @@ -676,19 +681,19 @@ let mligo_list () : unit result = let%bind program = mtype_file "./contracts/list.mligo" in let aux lst = e_list @@ List.map e_int lst in let%bind () = expect_eq program "fold_op" (aux [ 1 ; 2 ; 3 ]) (e_int 16) in - (* let%bind () = - * let make_input n = - * e_pair (e_list [e_int n; e_int (2*n)]) - * (e_pair (e_int 3) (e_list [e_int 8])) in - * let make_expected n = - * e_pair (e_typed_list [] t_operation) - * (e_pair (e_int (n+3)) (e_list [e_int (2*n)])) - * in - * expect_eq_n program "main" make_input make_expected - * in - * let%bind () = expect_eq_evaluate program "x" (e_list []) in - * let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in - * let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in *) + let%bind () = + let make_input n = + e_pair (e_list [e_int n; e_int (2*n)]) + (e_pair (e_int 3) (e_list [e_int 8])) in + let make_expected n = + e_pair (e_typed_list [] t_operation) + (e_pair (e_int (n+3)) (e_list [e_int (2*n)])) + in + expect_eq_n program "main" make_input make_expected + in + let%bind () = expect_eq_evaluate program "x" (e_list []) in + let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in + let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in ok () let lambda_mligo () : unit result = From 9c3c40c9ef9e6e323d5133934e8fffb6a04edfc4 Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 24 Sep 2019 00:26:39 +0200 Subject: [PATCH 38/53] add set fold --- src/passes/6-transpiler/transpiler.ml | 1 + src/passes/operators/operators.ml | 19 ++++++++++++++++++- src/test/contracts/set_arithmetic-1.ligo | 5 +++++ src/test/integration_tests.ml | 5 +++++ 4 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 11ff10988..fc71afebb 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -407,6 +407,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | ("LIST_MAP" , lst) -> map lst | ("MAP_MAP" , lst) -> map lst | ("LIST_FOLD" , lst) -> fold lst + | ("SET_FOLD" , lst) -> fold lst | ("MAP_FOLD" , lst) -> fold lst | _ -> ( let%bind lst' = bind_map_list (transpile_annotated_expression) lst in diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 9ead3b7bd..2dc5ef7d6 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -81,6 +81,7 @@ module Simplify = struct ("set_add" , "SET_ADD") ; ("set_remove" , "SET_REMOVE") ; ("set_iter" , "SET_ITER") ; + ("set_fold" , "SET_FOLD") ; ("list_iter" , "LIST_ITER") ; ("list_fold" , "LIST_FOLD") ; ("list_map" , "LIST_MAP") ; @@ -148,6 +149,7 @@ module Simplify = struct ("Set.empty" , "SET_EMPTY") ; ("Set.add" , "SET_ADD") ; ("Set.remove" , "SET_REMOVE") ; + ("Set.fold" , "SET_FOLD") ; ("Map.find_opt" , "MAP_FIND_OPT") ; ("Map.find" , "MAP_FIND") ; @@ -156,7 +158,7 @@ module Simplify = struct ("Map.remove" , "MAP_REMOVE") ; ("Map.iter" , "MAP_ITER") ; ("Map.map" , "MAP_MAP") ; - ("Map.fold" , "LIST_FOLD") ; + ("Map.fold" , "MAP_FOLD") ; ("String.length", "SIZE") ; ("String.size", "SIZE") ; @@ -496,6 +498,20 @@ module Typer = struct let%bind () = assert_eq_1 ~msg:"res init" res init in ok res + let set_fold = typer_3 "SET_FOLD" @@ fun lst init body -> + let%bind (arg , res) = get_t_function body in + let%bind (prec , cur) = get_t_pair arg in + let%bind key = get_t_set lst in + let msg = Format.asprintf "%a vs %a" + Ast_typed.PP.type_value key + Ast_typed.PP.type_value arg + in + trace (simple_error ("bad set fold:" ^ msg)) @@ + let%bind () = assert_eq_1 ~msg:"key cur" key cur in + let%bind () = assert_eq_1 ~msg:"prec res" prec res in + let%bind () = assert_eq_1 ~msg:"res init" res init in + ok res + let map_fold = typer_3 "MAP_FOLD" @@ fun map init body -> let%bind (arg , res) = get_t_function body in let%bind (prec , cur) = get_t_pair arg in @@ -593,6 +609,7 @@ module Typer = struct set_add ; set_remove ; set_iter ; + set_fold ; list_iter ; list_map ; list_fold ; diff --git a/src/test/contracts/set_arithmetic-1.ligo b/src/test/contracts/set_arithmetic-1.ligo index 0cfab61d2..f5d332687 100644 --- a/src/test/contracts/set_arithmetic-1.ligo +++ b/src/test/contracts/set_arithmetic-1.ligo @@ -9,3 +9,8 @@ function iter_op (const s : set(int)) : int is begin set_iter(s , aggregate) ; end with r + +function fold_op (const s : set(int)) : int is + function aggregate (const i : int ; const j : int) : int is + block { skip } with i + j + block { skip } with set_fold(s , 15 , aggregate) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index eab8395da..85e02d22d 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -224,6 +224,11 @@ let set_arithmetic () : unit result = expect_eq program "mem_op" (e_set [e_string "foo" ; e_string "bar"]) (e_bool false) in + let%bind () = + expect_eq program_1 "fold_op" + (e_set [ e_int 4 ; e_int 10 ]) + (e_int 29) + in ok () let unit_expression () : unit result = From ac449d2cb3dd15b1c94cbcc30d39ed49388d554b Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 24 Sep 2019 10:54:14 +0200 Subject: [PATCH 39/53] test List.iter and List.map in cameligo --- src/test/contracts/list.mligo | 8 ++++++++ src/test/integration_tests.ml | 2 ++ 2 files changed, 10 insertions(+) diff --git a/src/test/contracts/list.mligo b/src/test/contracts/list.mligo index 10d9dcf91..77bd98fc2 100644 --- a/src/test/contracts/list.mligo +++ b/src/test/contracts/list.mligo @@ -16,3 +16,11 @@ let%entry main (p : param) storage = let fold_op (s : int list) : int = let aggregate = fun (prec : int) (cur : int) -> prec + cur in List.fold s 10 aggregate + +let map_op (s : int list) : int list = + let aggregate = fun (cur : int) -> cur + 1 in + List.map s aggregate + +let iter_op (s : int list) : unit = + let do_nothing = fun (cur : int) -> unit in + List.iter s do_nothing diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 85e02d22d..1b6f96ce7 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -699,6 +699,8 @@ let mligo_list () : unit result = let%bind () = expect_eq_evaluate program "x" (e_list []) in let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in + let%bind () = expect_eq program "map_op" (aux [2 ; 3 ; 4 ; 5]) (aux [3 ; 4 ; 5 ; 6]) in + let%bind () = expect_eq program "iter_op" (aux [2 ; 3 ; 4 ; 5]) (e_unit ()) in ok () let lambda_mligo () : unit result = From b6ee28d704b5e02bcdc8e17c1c18e5991ec4721c Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 24 Sep 2019 13:54:34 +0200 Subject: [PATCH 40/53] add map literals in cameligo --- src/main/compile/helpers.ml | 4 +-- src/passes/3-self_ast_simplified/literals.ml | 35 +++++++++++++++++++ .../self_ast_simplified.ml | 26 ++++++++++++-- src/passes/operators/operators.ml | 2 ++ src/stages/ast_simplified/combinators.ml | 5 +++ src/test/contracts/map.mligo | 5 +++ src/test/integration_tests.ml | 9 +++++ 7 files changed, 81 insertions(+), 5 deletions(-) create mode 100644 src/passes/3-self_ast_simplified/literals.ml create mode 100644 src/test/contracts/map.mligo diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 054c9e00d..663c989e7 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -63,7 +63,7 @@ let parsify = fun (syntax : v_syntax) source_filename -> | Cameligo -> ok parsify_ligodity in let%bind parsified = parsify source_filename in - let%bind applied = Self_ast_simplified.convert_annotation_program parsified in + let%bind applied = Self_ast_simplified.all_program parsified in ok applied let parsify_expression = fun syntax source -> @@ -72,5 +72,5 @@ let parsify_expression = fun syntax source -> | Cameligo -> ok parsify_expression_ligodity in let%bind parsified = parsify source in - let%bind applied = Self_ast_simplified.convert_annotation_expression parsified in + let%bind applied = Self_ast_simplified.all_expression parsified in ok applied diff --git a/src/passes/3-self_ast_simplified/literals.ml b/src/passes/3-self_ast_simplified/literals.ml new file mode 100644 index 000000000..4584f1eb5 --- /dev/null +++ b/src/passes/3-self_ast_simplified/literals.ml @@ -0,0 +1,35 @@ +open Ast_simplified +open Trace + +let peephole_expression : expression -> expression result = fun e -> + let return expression = ok { e with expression } in + match e.expression with + | E_constant ("MAP_LITERAL" , lst) -> ( + let%bind elt = + trace_option (simple_error "map literal expects a single parameter") @@ + List.to_singleton lst + in + let%bind lst = + trace (simple_error "map literal expects a list as parameter") @@ + get_e_list elt.expression + in + let aux = fun (e : expression) -> + trace (simple_error "map literal expects a list of pairs as parameter") @@ + let%bind tpl = get_e_tuple e.expression in + let%bind (a , b) = + trace_option (simple_error "of pairs") @@ + List.to_pair tpl + in + ok (a , b) + in + let%bind pairs = bind_map_list aux lst in + return @@ E_map pairs + ) + | E_constant ("MAP_EMPTY" , lst) -> ( + let%bind () = + trace_strong (simple_error "MAP_EMPTY expects no parameter") @@ + Assert.assert_list_empty lst + in + return @@ E_map [] + ) + | e -> return e diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index b3ebb08db..aa18b4a8c 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -1,3 +1,23 @@ -let convert_annotation_expression = Helpers.map_expression Tezos_type_annotation.peephole_expression -let convert_annotation_program = Helpers.map_program Tezos_type_annotation.peephole_expression -let convert_none_variant_to_const = Helpers.map_program None_variant.peephole_expression +open Trace + +let all = [ + Tezos_type_annotation.peephole_expression ; + None_variant.peephole_expression ; + Literals.peephole_expression ; +] + +let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> + match fs with + | [] -> ok x + | hd :: tl -> ( + let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in + bind aux (ok x) + ) + +let all_program = + let all_p = List.map Helpers.map_program all in + bind_chain all_p + +let all_expression = + let all_p = List.map Helpers.map_expression all in + bind_chain all_p diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 2dc5ef7d6..00d580a87 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -159,6 +159,8 @@ module Simplify = struct ("Map.iter" , "MAP_ITER") ; ("Map.map" , "MAP_MAP") ; ("Map.fold" , "MAP_FOLD") ; + ("Map.empty" , "MAP_EMPTY") ; + ("Map.literal" , "MAP_LITERAL" ) ; ("String.length", "SIZE") ; ("String.size", "SIZE") ; diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index 6260229ad..99f0f3af5 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -162,6 +162,11 @@ let get_e_list = fun t -> | E_list lst -> ok lst | _ -> simple_fail "not a list" +let get_e_tuple = fun t -> + match t with + | E_tuple lst -> ok lst + | _ -> simple_fail "not a tuple" + let get_e_failwith = fun e -> match e.expression with | E_failwith fw -> ok fw diff --git a/src/test/contracts/map.mligo b/src/test/contracts/map.mligo new file mode 100644 index 000000000..7317dc6b8 --- /dev/null +++ b/src/test/contracts/map.mligo @@ -0,0 +1,5 @@ +type foobar = (int , int) map + +let foobar : foobar = Map.empty + +let foobarz : foobar = Map.literal [ (1 , 10) ; (2 , 20) ] diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 1b6f96ce7..93aac4e01 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -357,6 +357,14 @@ let moption () : unit result = in ok () +let mmap () : unit result = + let%bind program = mtype_file "./contracts/map.mligo" in + let%bind () = expect_eq_evaluate program "foobar" + (e_annotation (e_map []) (t_map t_int t_int)) in + let%bind () = expect_eq_evaluate program "foobarz" + (e_annotation (e_map [(e_int 1 , e_int 10) ; (e_int 2 , e_int 20)]) (t_map t_int t_int)) in + ok () + let map () : unit result = let%bind program = type_file "./contracts/map.ligo" in let ez lst = @@ -766,6 +774,7 @@ let main = test_suite "Integration (End to End)" [ test "option" option ; test "option (mligo)" moption ; test "map" map ; + test "map (mligo)" mmap ; test "big_map" big_map ; test "list" list ; test "loop" loop ; From f72593ae852a5006f23b22f83df8bee84312ad09 Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 24 Sep 2019 14:00:43 +0200 Subject: [PATCH 41/53] add set literals --- src/passes/3-self_ast_simplified/literals.ml | 18 ++++++++++++++++++ src/passes/operators/operators.ml | 1 + 2 files changed, 19 insertions(+) diff --git a/src/passes/3-self_ast_simplified/literals.ml b/src/passes/3-self_ast_simplified/literals.ml index 4584f1eb5..5d7be25b6 100644 --- a/src/passes/3-self_ast_simplified/literals.ml +++ b/src/passes/3-self_ast_simplified/literals.ml @@ -32,4 +32,22 @@ let peephole_expression : expression -> expression result = fun e -> in return @@ E_map [] ) + | E_constant ("SET_LITERAL" , lst) -> ( + let%bind elt = + trace_option (simple_error "map literal expects a single parameter") @@ + List.to_singleton lst + in + let%bind lst = + trace (simple_error "map literal expects a list as parameter") @@ + get_e_list elt.expression + in + return @@ E_set lst + ) + | E_constant ("SET_EMPTY" , lst) -> ( + let%bind () = + trace_strong (simple_error "SET_EMPTY expects no parameter") @@ + Assert.assert_list_empty lst + in + return @@ E_set [] + ) | e -> return e diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 00d580a87..335cd53d0 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -147,6 +147,7 @@ module Simplify = struct ("Set.mem" , "SET_MEM") ; ("Set.empty" , "SET_EMPTY") ; + ("Set.literal" , "SET_LITERAL") ; ("Set.add" , "SET_ADD") ; ("Set.remove" , "SET_REMOVE") ; ("Set.fold" , "SET_FOLD") ; From e6ac10f0ce5229b776ac11f96b2b64b9558500d3 Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 24 Sep 2019 14:29:18 +0200 Subject: [PATCH 42/53] switch from tz to mtz --- src/passes/2-simplify/ligodity.ml | 2 +- src/passes/2-simplify/pascaligo.ml | 2 +- src/passes/4-typer/typer.ml | 6 +++--- src/passes/6-transpiler/transpiler.ml | 2 +- src/passes/6-transpiler/untranspiler.ml | 4 ++-- src/passes/8-compiler/compiler_program.ml | 2 +- src/passes/8-compiler/uncompiler.ml | 2 +- src/passes/operators/operators.ml | 18 +++++++++++++++--- src/stages/ast_simplified/PP.ml | 2 +- src/stages/ast_simplified/combinators.ml | 2 +- src/stages/ast_simplified/misc.ml | 6 +++--- src/stages/ast_simplified/types.ml | 2 +- src/stages/ast_typed/PP.ml | 2 +- src/stages/ast_typed/combinators.ml | 4 ++-- .../ast_typed/combinators_environment.ml | 2 +- src/stages/ast_typed/misc.ml | 6 +++--- src/stages/ast_typed/types.ml | 2 +- src/stages/mini_c/PP.ml | 2 +- src/stages/mini_c/combinators.ml | 4 ++++ src/stages/mini_c/types.ml | 2 +- src/test/coase_tests.ml | 2 +- src/test/contracts/map.ligo | 5 +++++ src/test/contracts/map.mligo | 2 ++ src/test/integration_tests.ml | 6 ++++++ 24 files changed, 59 insertions(+), 30 deletions(-) diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 3a1fe5132..879579e9f 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -434,7 +434,7 @@ let rec simpl_expression : | EArith (Mtz n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in - return @@ e_literal ~loc (Literal_tez n) + return @@ e_literal ~loc (Literal_mutez n) ) | EArith _ as e -> fail @@ unsupported_arith_op e diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 0a6fe63d3..5380e9f0e 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -500,7 +500,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = | EArith (Mtz n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in - return @@ e_literal ~loc (Literal_tez n) + return @@ e_literal ~loc (Literal_mutez n) ) | EArith (Neg e) -> simpl_unop "NEG" e | EString (String s) -> diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 2cacd1629..5c87cfe62 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -416,8 +416,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_literal (Literal_nat n)) (t_nat ()) | E_literal (Literal_timestamp n) -> return (E_literal (Literal_timestamp n)) (t_timestamp ()) - | E_literal (Literal_tez n) -> - return (E_literal (Literal_tez n)) (t_tez ()) + | E_literal (Literal_mutez n) -> + return (E_literal (Literal_mutez n)) (t_tez ()) | E_literal (Literal_address s) -> return (e_address s) (t_address ()) | E_literal (Literal_operation op) -> @@ -803,7 +803,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_bool b -> ok (Literal_bool b) | Literal_nat n -> ok (Literal_nat n) | Literal_timestamp n -> ok (Literal_timestamp n) - | Literal_tez n -> ok (Literal_tez n) + | Literal_mutez n -> ok (Literal_mutez n) | Literal_int n -> ok (Literal_int n) | Literal_string s -> ok (Literal_string s) | Literal_bytes b -> ok (Literal_bytes b) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index fc71afebb..ef3207d2b 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -204,7 +204,7 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_int n -> D_int n | Literal_nat n -> D_nat n | Literal_timestamp n -> D_timestamp n - | Literal_tez n -> D_tez n + | Literal_mutez n -> D_mutez n | Literal_bytes s -> D_bytes s | Literal_string s -> D_string s | Literal_address s -> D_string s diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml index 6c0309bd3..78c41cca8 100644 --- a/src/passes/6-transpiler/untranspiler.ml +++ b/src/passes/6-transpiler/untranspiler.ml @@ -86,8 +86,8 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression | T_constant ("tez", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "tez" v) @@ - get_nat v in - return (E_literal (Literal_tez n)) + get_mutez v in + return (E_literal (Literal_mutez n)) ) | T_constant ("string", []) -> ( let%bind n = diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 783b1d6ad..ef3d19395 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -66,7 +66,7 @@ let rec translate_value (v:value) ty : michelson result = match v with | D_int n -> ok @@ int (Z.of_int n) | D_nat n -> ok @@ int (Z.of_int n) | D_timestamp n -> ok @@ int (Z.of_int n) - | D_tez n -> ok @@ int (Z.of_int n) + | D_mutez n -> ok @@ int (Z.of_int n) | D_string s -> ok @@ string s | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s) | D_unit -> ok @@ prim D_Unit diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml index 2838298d3..310d3a72f 100644 --- a/src/passes/8-compiler/uncompiler.ml +++ b/src/passes/8-compiler/uncompiler.ml @@ -40,7 +40,7 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = let%bind n = generic_try (simple_error "too big to fit an int") @@ (fun () -> Int64.to_int @@ Alpha_context.Tez.to_mutez n) in - ok @@ D_nat n + ok @@ D_mutez n | (Bool_t _), b -> ok @@ D_bool b | (String_t _), s -> diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 335cd53d0..75b940e22 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -88,6 +88,9 @@ module Simplify = struct ("map_iter" , "MAP_ITER") ; ("map_map" , "MAP_MAP") ; ("map_fold" , "MAP_FOLD") ; + ("map_remove" , "MAP_REMOVE") ; + ("map_update" , "MAP_UPDATE") ; + ("map_get" , "MAP_GET") ; ("sha_256" , "SHA256") ; ("sha_512" , "SHA512") ; ("blake2b" , "BLAKE2b") ; @@ -270,7 +273,9 @@ module Typer = struct ok @@ t_bool () let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in + let%bind (src, dst) = + trace_strong (simple_error "MAP_FIND: not map or bigmap") @@ + bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ dst @@ -313,11 +318,16 @@ module Typer = struct (is_t_string t) in ok @@ t_unit () - let get_force = typer_2 "MAP_GET_FORCE" @@ fun i m -> + let map_get_force = typer_2 "MAP_GET_FORCE" @@ fun i m -> let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind _ = assert_type_value_eq (src, i) in ok dst + let map_get = typer_2 "MAP_GET" @@ fun i m -> + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in + let%bind _ = assert_type_value_eq (src, i) in + ok @@ t_option dst () + let int : typer = typer_1 "INT" @@ fun t -> let%bind () = assert_t_nat t in ok @@ t_int () @@ -607,6 +617,8 @@ module Typer = struct map_map ; map_fold ; map_iter ; + map_get_force ; + map_get ; set_empty ; set_mem ; set_add ; @@ -619,7 +631,6 @@ module Typer = struct int ; size ; failwith_ ; - get_force ; bytes_pack ; bytes_unpack ; hash256 ; @@ -687,6 +698,7 @@ module Compiler = struct ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ; ("MAP_GET" , simple_binary @@ prim I_GET) ; + ("MAP_FIND_OPT" , simple_binary @@ prim I_GET) ; ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 6ddef98c6..1fb7cb18e 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -25,7 +25,7 @@ let literal ppf (l:literal) = match l with | Literal_int n -> fprintf ppf "%d" n | Literal_nat n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n - | Literal_tez n -> fprintf ppf "%dtz" n + | Literal_mutez n -> fprintf ppf "%dmtz" n | Literal_string s -> fprintf ppf "%S" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%S" s diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index 99f0f3af5..0890365d1 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -61,7 +61,7 @@ let e_timestamp ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_t let e_bool ?loc b : expression = location_wrap ?loc @@ E_literal (Literal_bool b) let e_string ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_string s) let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_address s) -let e_tez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_tez s) +let e_mutez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_mutez s) let e'_bytes b : expression' result = let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in ok @@ E_literal (Literal_bytes bytes) diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index 9484b1f09..ec9044c8a 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -45,9 +45,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_timestamp a, Literal_timestamp b when a = b -> ok () | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_tez a, Literal_tez b when a = b -> ok () - | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b - | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b + | Literal_mutez a, Literal_mutez b when a = b -> ok () + | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b + | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b | Literal_string a, Literal_string b when a = b -> ok () | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 1ca2a19cf..ea42d849d 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -91,7 +91,7 @@ and literal = | Literal_bool of bool | Literal_int of int | Literal_nat of int - | Literal_tez of int + | Literal_mutez of int | Literal_string of string | Literal_bytes of bytes | Literal_address of string diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 9af3eb49a..96825ecc3 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -70,7 +70,7 @@ and literal ppf (l:literal) : unit = | Literal_int n -> fprintf ppf "%d" n | Literal_nat n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n - | Literal_tez n -> fprintf ppf "%dtz" n + | Literal_mutez n -> fprintf ppf "%dmtz" n | Literal_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%s" s diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 1f4047d5b..d9dcebb73 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -232,7 +232,7 @@ let e_map lst : expression = E_map lst let e_unit : expression = E_literal (Literal_unit) let e_int n : expression = E_literal (Literal_int n) let e_nat n : expression = E_literal (Literal_nat n) -let e_tez n : expression = E_literal (Literal_tez n) +let e_mutez n : expression = E_literal (Literal_mutez n) let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_address s : expression = E_literal (Literal_address s) @@ -247,7 +247,7 @@ let e_let_in binder rhs result = E_let_in { binder ; rhs ; result } let e_a_unit = make_a_e e_unit (t_unit ()) let e_a_int n = make_a_e (e_int n) (t_int ()) let e_a_nat n = make_a_e (e_nat n) (t_nat ()) -let e_a_tez n = make_a_e (e_tez n) (t_tez ()) +let e_a_mutez n = make_a_e (e_mutez n) (t_tez ()) let e_a_bool b = make_a_e (e_bool b) (t_bool ()) let e_a_string s = make_a_e (e_string s) (t_string ()) let e_a_address s = make_a_e (e_address s) (t_address ()) diff --git a/src/stages/ast_typed/combinators_environment.ml b/src/stages/ast_typed/combinators_environment.ml index 4c41f7296..1446c8780 100644 --- a/src/stages/ast_typed/combinators_environment.ml +++ b/src/stages/ast_typed/combinators_environment.ml @@ -6,7 +6,7 @@ let make_a_e_empty expression type_annotation = make_a_e expression type_annotat let e_a_empty_unit = e_a_unit Environment.full_empty let e_a_empty_int n = e_a_int n Environment.full_empty let e_a_empty_nat n = e_a_nat n Environment.full_empty -let e_a_empty_tez n = e_a_tez n Environment.full_empty +let e_a_empty_mutez n = e_a_mutez n Environment.full_empty let e_a_empty_bool b = e_a_bool b Environment.full_empty let e_a_empty_string s = e_a_string s Environment.full_empty let e_a_empty_address s = e_a_address s Environment.full_empty diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 39b437060..5aaf28550 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -365,9 +365,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_timestamp a, Literal_timestamp b when a = b -> ok () | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_tez a, Literal_tez b when a = b -> ok () - | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b - | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b + | Literal_mutez a, Literal_mutez b when a = b -> ok () + | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b + | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b | Literal_string a, Literal_string b when a = b -> ok () | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index ce5627086..fc297b593 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -119,7 +119,7 @@ and literal = | Literal_int of int | Literal_nat of int | Literal_timestamp of int - | Literal_tez of int + | Literal_mutez of int | Literal_string of string | Literal_bytes of bytes | Literal_address of string diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index d35d38b64..660006521 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -49,7 +49,7 @@ let rec value ppf : value -> unit = function | D_int n -> fprintf ppf "%d" n | D_nat n -> fprintf ppf "+%d" n | D_timestamp n -> fprintf ppf "+%d" n - | D_tez n -> fprintf ppf "%dtz" n + | D_mutez n -> fprintf ppf "%dmtz" n | D_unit -> fprintf ppf "unit" | D_string s -> fprintf ppf "\"%s\"" s | D_bytes x -> diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index 074d66618..094d91928 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -34,6 +34,10 @@ let get_nat (v:value) = match v with | D_nat n -> ok n | _ -> simple_fail "not a nat" +let get_mutez (v:value) = match v with + | D_mutez n -> ok n + | _ -> simple_fail "not a mutez" + let get_timestamp (v:value) = match v with | D_timestamp n -> ok n | _ -> simple_fail "not a timestamp" diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index b2c7a2499..a0a367409 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -38,7 +38,7 @@ type value = | D_bool of bool | D_nat of int | D_timestamp of int - | D_tez of int + | D_mutez of int | D_int of int | D_string of string | D_bytes of bytes diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 7b7b38ae8..967130f3d 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -47,7 +47,7 @@ let card_pattern_ty = ] let card_pattern_ez (coeff , qtt) = - card_pattern (e_tez coeff , e_nat qtt) + card_pattern (e_mutez coeff , e_nat qtt) let make_card_patterns lst = let card_pattern_id_ty = t_nat in diff --git a/src/test/contracts/map.ligo b/src/test/contracts/map.ligo index 722412603..dd6770077 100644 --- a/src/test/contracts/map.ligo +++ b/src/test/contracts/map.ligo @@ -26,6 +26,11 @@ function get (const m : foobar) : option(int) is skip end with m[42] +function get_ (const m : foobar) : option(int) is + begin + skip + end with map_get(42 , m) + const bm : foobar = map 144 -> 23 ; 51 -> 23 ; diff --git a/src/test/contracts/map.mligo b/src/test/contracts/map.mligo index 7317dc6b8..375a69507 100644 --- a/src/test/contracts/map.mligo +++ b/src/test/contracts/map.mligo @@ -3,3 +3,5 @@ type foobar = (int , int) map let foobar : foobar = Map.empty let foobarz : foobar = Map.literal [ (1 , 10) ; (2 , 20) ] + +let foo : int = Map.find 1 foobarz diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 93aac4e01..5e8008999 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -363,6 +363,7 @@ let mmap () : unit result = (e_annotation (e_map []) (t_map t_int t_int)) in let%bind () = expect_eq_evaluate program "foobarz" (e_annotation (e_map [(e_int 1 , e_int 10) ; (e_int 2 , e_int 20)]) (t_map t_int t_int)) in + let%bind () = expect_eq_evaluate program "foo" (e_int 10) in ok () let map () : unit result = @@ -399,6 +400,11 @@ let map () : unit result = let make_expected = fun _ -> e_some @@ e_int 4 in expect_eq_n program "get" make_input make_expected in + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = fun _ -> e_some @@ e_int 4 in + expect_eq_n program "get_" make_input make_expected + in let%bind () = let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in expect_eq_evaluate program "bm" expected From 87bbdad55345285a855769be6af971e6fae5d635 Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 25 Sep 2019 10:49:14 +0200 Subject: [PATCH 43/53] fix stuff --- src/bin/cli.ml | 23 ++++++++++--- src/main/compile/of_mini_c.ml | 18 ++++------ src/main/compile/of_simplified.ml | 8 +++-- src/main/compile/of_source.ml | 29 +++------------- src/main/compile/of_typed.ml | 4 +-- src/main/display.ml | 6 ++-- src/main/run/of_michelson.ml | 51 ++++++++++++++-------------- src/main/run/of_mini_c.ml | 2 +- src/main/run/of_simplified.ml | 14 ++++++-- src/main/run/of_source.ml | 55 ++++++++++++++++++++++++++----- src/main/run/of_typed.ml | 16 +++++++-- 11 files changed, 138 insertions(+), 88 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 3ca3d2bf3..31e9261ab 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -89,7 +89,7 @@ let compile_parameter = toplevel ~display_format @@ let%bind value = trace (simple_error "compile-input") @@ - Ligo.Compile.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in + Ligo.Run.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = @@ -103,7 +103,7 @@ let compile_storage = toplevel ~display_format @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Compile.Of_source.compile_file_contract_storage ~value:bigmap source entry_point expression (Syntax_name syntax) in + Ligo.Run.Of_source.compile_file_contract_storage ~value:bigmap source entry_point expression (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = @@ -129,7 +129,7 @@ let run_function = let f source entry_point parameter amount syntax display_format = toplevel ~display_format @@ let%bind output = - Ligo.Run.Of_source.run_function ~amount source entry_point parameter (Syntax_name syntax) in + Ligo.Run.Of_source.run_function_entry ~amount source entry_point parameter (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = @@ -142,7 +142,7 @@ let evaluate_value = let f source entry_point amount syntax display_format = toplevel ~display_format @@ let%bind output = - Ligo.Run.Of_source.evaluate ~amount source entry_point (Syntax_name syntax) in + Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = @@ -151,11 +151,26 @@ let evaluate_value = let docs = "Subcommand: evaluate a given definition." in (term , Term.info ~docs cmdname) +let compile_expression = + let f expression syntax display_format = + toplevel ~display_format @@ + let%bind value = + trace (simple_error "compile-input") @@ + Ligo.Run.Of_source.compile_expression expression (Syntax_name syntax) in + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value + in + let term = + Term.(const f $ expression "" 0 $ syntax $ display_format) in + let cmdname = "compile-expression" in + let docs = "Subcommand: compile to a michelson value." in + (term , Term.info ~docs cmdname) + let () = Term.exit @@ Term.eval_choice main [ compile_file ; compile_parameter ; compile_storage ; + compile_expression ; dry_run ; run_function ; evaluate_value ; diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 34d8cd753..fd8de3570 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -5,21 +5,15 @@ open Tezos_utils let compile_value : value -> type_value -> Michelson.t result = Compiler.Program.translate_value -let compile_expression ?(value = false) : expression -> _ result = fun e -> - if value then ( - let%bind value = expression_to_value e in - Format.printf "Compile to value\n" ; - let%bind result = compile_value value e.type_value in - Format.printf "Compiled to value\n" ; - ok result - ) else ( - Compiler.Program.translate_expression e Compiler.Environment.empty - ) +let compile_expression_as_value : expression -> _ result = fun e -> + let%bind value = expression_to_value e in + let%bind result = compile_value value e.type_value in + ok result let compile_expression_as_function : expression -> _ result = fun e -> let (input , output) = t_unit , e.type_value in - let%bind body = get_function e in - let%bind body = compile_value body (t_function input output) in + let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in + let body = Michelson.(seq [ i_drop ; body ]) in let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in let open! Compiler.Program in ok { input ; output ; body } diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 215c908a5..cf8bc00fd 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -14,9 +14,13 @@ let compile_expression_as_function_entry (program : program) entry_point : _ res let%bind typed_program = Typer.type_program program in Of_typed.compile_expression_as_function_entry typed_program entry_point -let compile_expression ?(env = Ast_typed.Environment.full_empty) ?value ae : Michelson.t result = +let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = let%bind typed = Typer.type_expression env ae in - Of_typed.compile_expression ?value typed + Of_typed.compile_expression_as_value typed + +let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ae : _ result = + let%bind typed = Typer.type_expression env ae in + Of_typed.compile_expression_as_function typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let%bind output_type = diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 42c6adf91..f7576ec19 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -1,6 +1,5 @@ open Trace open Helpers -open Tezos_utils let parse_file_program source_filename syntax = let%bind syntax = syntax_to_variant syntax (Some source_filename) in @@ -18,31 +17,11 @@ let compile_file_contract_entry : string -> string -> s_syntax -> _ result = let%bind compiled_contract = Of_simplified.compile_contract_entry simplified entry_point in ok compiled_contract -let compile_file_contract_parameter : string -> string -> string -> s_syntax -> Michelson.t result = - fun source_filename _entry_point expression syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in +let compile_expression_as_function : string -> s_syntax -> _ result = + fun expression syntax -> + let%bind syntax = syntax_to_variant syntax None in let%bind simplified = parsify_expression syntax expression in - Of_simplified.compile_expression simplified - -let compile_file_expression : string -> string -> string -> s_syntax -> Michelson.t result = - fun source_filename _entry_point expression syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind simplified = parsify_expression syntax expression in - Of_simplified.compile_expression simplified - -let compile_file_contract_storage ~value : string -> string -> string -> s_syntax -> Michelson.t result = - fun source_filename _entry_point expression syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind simplified = parsify_expression syntax expression in - Of_simplified.compile_expression ~value simplified - -let compile_file_contract_args = - fun ?value source_filename _entry_point storage parameter syntax -> - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind storage_simplified = parsify_expression syntax storage in - let%bind parameter_simplified = parsify_expression syntax parameter in - let args = Ast_simplified.e_pair storage_simplified parameter_simplified in - Of_simplified.compile_expression ?value args + Of_simplified.compile_expression_as_function simplified let type_file ?(debug_simplify = false) ?(debug_typed = false) syntax (source_filename:string) : Ast_typed.program result = diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index e8ac1e8e7..79ca90040 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -3,9 +3,9 @@ open Ast_typed open Tezos_utils -let compile_expression ?(value = false) : annotated_expression -> Michelson.t result = fun e -> +let compile_expression_as_value : annotated_expression -> Michelson.t result = fun e -> let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in - let%bind expr = Of_mini_c.compile_expression ~value mini_c_expression in + let%bind expr = Of_mini_c.compile_expression_as_value mini_c_expression in ok expr let compile_expression_as_function : annotated_expression -> _ result = fun e -> diff --git a/src/main/display.ml b/src/main/display.ml index 2d24e8008..93eebbfe9 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -66,6 +66,8 @@ let result_pp_dev f out (r : _ result) = let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s" s) +let json_pp out x = Format.fprintf out "%s" (J.to_string x) + let string_result_pp_json out (r : string result) = let status_json status content : J.t = `Assoc ([ ("status" , `String status) ; @@ -73,10 +75,10 @@ let string_result_pp_json out (r : string result) = ]) in match r with | Ok (x , _) -> ( - Format.fprintf out "%a" J.pp (status_json "ok" (`String x)) + Format.fprintf out "%a" json_pp (status_json "ok" (`String x)) ) | Error e -> ( - Format.fprintf out "%a" J.pp (status_json "error" (e ())) + Format.fprintf out "%a" json_pp (status_json "error" (e ())) ) type display_format = [ diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 307aa2274..220bc26c2 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -6,36 +6,24 @@ open Memory_proto_alpha.X type options = Memory_proto_alpha.options -let run ?options ?(is_input_value = false) (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = +let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = let Compiler.Program.{input;output;body} : compiled_program = program in let (Ex_ty input_ty) = input in let (Ex_ty output_ty) = output in - let%bind input_ty_mich = - Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ - Memory_proto_alpha.unparse_michelson_ty input_ty in - let%bind output_ty_mich = - Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ - Memory_proto_alpha.unparse_michelson_ty output_ty in - Format.printf "code: %a\n" Michelson.pp program.body ; - Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ; - Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ; - Format.printf "input: %a\n" Michelson.pp input_michelson ; + (* let%bind input_ty_mich = + * Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ + * Memory_proto_alpha.unparse_michelson_ty input_ty in + * let%bind output_ty_mich = + * Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ + * Memory_proto_alpha.unparse_michelson_ty output_ty in + * Format.printf "code: %a\n" Michelson.pp program.body ; + * Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ; + * Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ; + * Format.printf "input: %a\n" Michelson.pp input_michelson ; *) let%bind input = - if is_input_value then ( - Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ - Memory_proto_alpha.parse_michelson_data input_michelson input_ty - ) else ( - let input_michelson = Michelson.(seq [ input_michelson ; dip i_drop ]) in - let body = Michelson.(strip_nops @@ strip_annots input_michelson) in - let%bind descr = - Trace.trace_tzresult_lwt (simple_error "error parsing input code") @@ - Memory_proto_alpha.parse_michelson body - (Item_t (Memory_proto_alpha.Protocol.Script_typed_ir.Unit_t None, Empty_t, None)) (Item_t (input_ty, Empty_t, None)) in - let%bind (Item(output, Empty)) = - Trace.trace_tzresult_lwt (simple_error "input error of execution") @@ - Memory_proto_alpha.interpret ?options descr (Item((), Empty)) in - ok output - ) in + Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ + Memory_proto_alpha.parse_michelson_data input_michelson input_ty + in let body = Michelson.(strip_nops @@ strip_annots body) in let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ @@ -47,4 +35,13 @@ let run ?options ?(is_input_value = false) (program:compiled_program) (input_mic Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let evaluate ?options program = run ?options ~is_input_value:true program Michelson.d_unit +let evaluate ?options program = run ?options program Michelson.d_unit + +let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result = + let (Ex_typed_value (value , ty)) = v in + Trace.trace_tzresult_lwt (simple_error "error unparsing michelson result") @@ + Memory_proto_alpha.unparse_michelson_data value ty + +let evaluate_michelson ?options program = + let%bind etv = evaluate ?options program in + ex_value_ty_to_michelson etv diff --git a/src/main/run/of_mini_c.ml b/src/main/run/of_mini_c.ml index dbe02bf08..131bf4ac5 100644 --- a/src/main/run/of_mini_c.ml +++ b/src/main/run/of_mini_c.ml @@ -38,7 +38,7 @@ let run_function ?options expression input ty = let run_function_value ?options expression input ty = let%bind code = Compile.Of_mini_c.compile_function expression in let%bind input = Compile.Of_mini_c.compile_value input ty in - let%bind ex_ty_value = Of_michelson.run ~is_input_value:true ?options code input in + let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_mini_c.uncompile_value ex_ty_value let run_function_entry ?options program entry input = diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 9c5d830cc..523ceed23 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -6,6 +6,16 @@ let get_final_environment program = let (Ast_typed.Declaration_constant (_ , (_ , post_env))) = last_declaration in post_env +let compile_expression ?(value = false) ?env expr = + if value + then ( + Compile.Of_simplified.compile_expression_as_value ?env expr + ) + else ( + let%bind code = Compile.Of_simplified.compile_expression_as_function ?env expr in + Of_michelson.evaluate_michelson code + ) + let run_typed_program ?options ?input_to_value (program : Ast_typed.program) (entry : string) @@ -13,9 +23,9 @@ let run_typed_program let%bind code = Compile.Of_typed.compile_function_entry program entry in let%bind input = let env = get_final_environment program in - Compile.Of_simplified.compile_expression ~env ?value:input_to_value input + compile_expression ?value:input_to_value ~env input in - let%bind ex_ty_value = Of_michelson.run ?is_input_value:input_to_value ?options code input in + let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value let evaluate_typed_program_entry diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index 3014cbbb7..5fed28c09 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -46,10 +46,45 @@ include struct ok () end +(* open Tezos_utils *) + +let compile_file_contract_parameter : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in + let%bind simplified = Compile.Helpers.parsify_expression syntax expression in + Of_simplified.compile_expression simplified + +let compile_file_expression : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in + let%bind simplified = Compile.Helpers.parsify_expression syntax expression in + Of_simplified.compile_expression simplified + +let compile_expression : string -> Compile.Helpers.s_syntax -> Michelson.t result = + fun expression syntax -> + let%bind syntax = Compile.Helpers.syntax_to_variant syntax None in + let%bind simplified = Compile.Helpers.parsify_expression syntax expression in + Of_simplified.compile_expression simplified + +let compile_file_contract_storage ~value : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in + let%bind simplified = Compile.Helpers.parsify_expression syntax expression in + Of_simplified.compile_expression ~value simplified + +let compile_file_contract_args = + fun ?value source_filename _entry_point storage parameter syntax -> + let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in + let%bind storage_simplified = Compile.Helpers.parsify_expression syntax storage in + let%bind parameter_simplified = Compile.Helpers.parsify_expression syntax parameter in + let args = Ast_simplified.e_pair storage_simplified parameter_simplified in + Of_simplified.compile_expression ?value args + + let run_contract ?amount ?storage_value source_filename entry_point storage parameter syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in let%bind code = Compile.Of_typed.compile_function_entry program entry_point in - let%bind args = Compile.Of_source.compile_file_contract_args ?value:storage_value source_filename entry_point storage parameter syntax in + let%bind args = compile_file_contract_args ?value:storage_value source_filename entry_point storage parameter syntax in let%bind ex_value_ty = let options = let open Proto_alpha_utils.Memory_proto_alpha in @@ -60,10 +95,10 @@ let run_contract ?amount ?storage_value source_filename entry_point storage para in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty -let run_function ?amount source_filename entry_point input syntax = +let run_function_entry ?amount source_filename entry_point input syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in let%bind code = Compile.Of_typed.compile_function_entry program entry_point in - let%bind args = Compile.Of_source.compile_file_expression source_filename entry_point input syntax in + let%bind args = compile_file_expression source_filename entry_point input syntax in let%bind ex_value_ty = let options = let open Proto_alpha_utils.Memory_proto_alpha in @@ -74,19 +109,21 @@ let run_function ?amount source_filename entry_point input syntax = in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty -let evaluate ?amount source_filename entry_point syntax = +let evaluate_entry ?amount source_filename entry_point syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry_point in - let%bind input = - let fake_input = Ast_simplified.e_unit () in - Compile.Of_simplified.compile_expression fake_input - in let%bind ex_value_ty = let options = let open Proto_alpha_utils.Memory_proto_alpha in let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in (make_options ?amount ()) in - Of_michelson.run ~options code input + Of_michelson.evaluate ~options code in Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry_point ex_value_ty + +let evaluate_michelson expression syntax = + let%bind code = Compile.Of_source.compile_expression_as_function expression syntax in + Of_michelson.evaluate_michelson code + + diff --git a/src/main/run/of_typed.ml b/src/main/run/of_typed.ml index a645250cc..644e99d26 100644 --- a/src/main/run/of_typed.ml +++ b/src/main/run/of_typed.ml @@ -1,9 +1,19 @@ open Trace open Ast_typed +let compile_expression ?(value = false) expr = + if value + then ( + Compile.Of_typed.compile_expression_as_value expr + ) + else ( + let%bind code = Compile.Of_typed.compile_expression_as_function expr in + Of_michelson.evaluate_michelson code + ) + let run_function ?options f input = let%bind code = Compile.Of_typed.compile_function f in - let%bind input = Compile.Of_typed.compile_expression input in + let%bind input = compile_expression input in let%bind ex_ty_value = Of_michelson.run ?options code input in let%bind ty = let%bind (_ , output_ty) = get_t_function f.type_annotation in @@ -15,7 +25,9 @@ let run_entry ?options (entry : string) (program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = let%bind code = Compile.Of_typed.compile_function_entry program entry in - let%bind input = Compile.Of_typed.compile_expression input in + let%bind input = + compile_expression input + in let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_typed.uncompile_entry_function_result program entry ex_ty_value From c60a02942b6a6cec6cd7d22515af08546552d270 Mon Sep 17 00:00:00 2001 From: Matej Sima Date: Wed, 25 Sep 2019 10:52:26 +0200 Subject: [PATCH 44/53] Update the CLI testing script CI pipeline --- .gitlab-ci.yml | 2 +- scripts/test_cli.sh | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 594efb1b5..ff385a1ce 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -111,7 +111,7 @@ build-and-publish-latest-docker-image: <<: *docker_build after_script: - docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD - - scripts/test_cli.sh + - sh scripts/test_cli.sh - docker push $LIGO_REGISTRY_IMAGE:next only: - dev diff --git a/scripts/test_cli.sh b/scripts/test_cli.sh index 04581fe72..ab02ff575 100755 --- a/scripts/test_cli.sh +++ b/scripts/test_cli.sh @@ -114,4 +114,6 @@ fi if [ "$dry_run_output" != "$expected_dry_run_output" ]; then echo "Expected $expected_dry_run_output as dry-run output, got $dry_run_output instead"; exit 1; -fi \ No newline at end of file +fi + +echo "CLI tests passed"; \ No newline at end of file From af9e6a90b98ab6c600eac9416084b39bdc237ac9 Mon Sep 17 00:00:00 2001 From: Matej Sima Date: Wed, 25 Sep 2019 13:11:10 +0200 Subject: [PATCH 45/53] Move docker publishing and testing to script instead of after_script in the CI --- .gitlab-ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ff385a1ce..85e38064e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -97,8 +97,8 @@ build-current-docker-image: stage: build_docker <<: *docker <<: *docker_build - after_script: - - scripts/test_cli.sh + script: + - sh scripts/test_cli.sh except: - master - dev @@ -109,7 +109,7 @@ build-and-publish-latest-docker-image: stage: build_and_deploy_docker <<: *docker <<: *docker_build - after_script: + script: - docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD - sh scripts/test_cli.sh - docker push $LIGO_REGISTRY_IMAGE:next From d1c1f0c08ef71d15e32d0f7bb73c5c0812762c34 Mon Sep 17 00:00:00 2001 From: Matej Sima Date: Wed, 25 Sep 2019 13:14:41 +0200 Subject: [PATCH 46/53] Move docker_build to 'script' level in the CI --- .gitlab-ci.yml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 85e38064e..e5801ca4f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -51,8 +51,7 @@ stages: - docker:dind .docker_build: &docker_build - script: - - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . + - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . .before_script: &before_script before_script: @@ -96,8 +95,8 @@ remote-repo-job: build-current-docker-image: stage: build_docker <<: *docker - <<: *docker_build script: + <<: *docker_build - sh scripts/test_cli.sh except: - master @@ -108,8 +107,8 @@ build-current-docker-image: build-and-publish-latest-docker-image: stage: build_and_deploy_docker <<: *docker - <<: *docker_build script: + <<: *docker_build - docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD - sh scripts/test_cli.sh - docker push $LIGO_REGISTRY_IMAGE:next From d9afee0fad25755a57337b563ac1f1ba3eb603b4 Mon Sep 17 00:00:00 2001 From: Matej Sima Date: Wed, 25 Sep 2019 13:19:44 +0200 Subject: [PATCH 47/53] Attempt to fix docker_build CI config --- .gitlab-ci.yml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e5801ca4f..1fa3cd9ec 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -50,8 +50,6 @@ stages: services: - docker:dind -.docker_build: &docker_build - - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . .before_script: &before_script before_script: @@ -96,7 +94,7 @@ build-current-docker-image: stage: build_docker <<: *docker script: - <<: *docker_build + - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . - sh scripts/test_cli.sh except: - master @@ -108,9 +106,9 @@ build-and-publish-latest-docker-image: stage: build_and_deploy_docker <<: *docker script: - <<: *docker_build - - docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD + - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . - sh scripts/test_cli.sh + - docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD - docker push $LIGO_REGISTRY_IMAGE:next only: - dev From be75fd48304f8a08f64b5cb17b5832c5134da37e Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 25 Sep 2019 17:21:44 +0200 Subject: [PATCH 48/53] fixed minor bug --- src/main/compile/dune | 3 +- src/main/compile/of_mini_c.ml | 6 ++-- src/passes/9-self_michelson/dune | 12 +++++++ src/passes/9-self_michelson/helpers.ml | 19 ++++++++++++ src/passes/9-self_michelson/main.ml | 0 src/passes/9-self_michelson/self_michelson.ml | 31 +++++++++++++++++++ 6 files changed, 67 insertions(+), 4 deletions(-) create mode 100644 src/passes/9-self_michelson/dune create mode 100644 src/passes/9-self_michelson/helpers.ml create mode 100644 src/passes/9-self_michelson/main.ml create mode 100644 src/passes/9-self_michelson/self_michelson.ml diff --git a/src/main/compile/dune b/src/main/compile/dune index e8520e473..a3c992c69 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -12,8 +12,9 @@ ast_typed transpiler mini_c - operators compiler + self_michelson + operators ) (preprocess (pps ppx_let) diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index fd8de3570..1a385040f 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -8,11 +8,13 @@ let compile_value : value -> type_value -> Michelson.t result = let compile_expression_as_value : expression -> _ result = fun e -> let%bind value = expression_to_value e in let%bind result = compile_value value e.type_value in + let%bind result = Self_michelson.all_expression result in ok result let compile_expression_as_function : expression -> _ result = fun e -> let (input , output) = t_unit , e.type_value in let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in + let%bind body = Self_michelson.all_expression body in let body = Michelson.(seq [ i_drop ; body ]) in let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in let open! Compiler.Program in @@ -22,13 +24,11 @@ let compile_function = fun e -> let%bind (input , output) = get_t_function e.type_value in let%bind body = get_function e in let%bind body = compile_value body (t_function input output) in + let%bind body = Self_michelson.all_expression body in let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in let open! Compiler.Program in ok { input ; output ; body } -(* let compile_function : anon_function -> (type_value * type_value) -> Compiler.Program.compiled_program result = fun f io -> - * Compiler.Program.translate_entry f io *) - let compile_expression_as_function_entry = fun program name -> let%bind aggregated = aggregate_entry program name true in compile_function aggregated diff --git a/src/passes/9-self_michelson/dune b/src/passes/9-self_michelson/dune new file mode 100644 index 000000000..047fe33a4 --- /dev/null +++ b/src/passes/9-self_michelson/dune @@ -0,0 +1,12 @@ +(library + (name self_michelson) + (public_name ligo.self_michelson) + (libraries + simple-utils + tezos-utils + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/9-self_michelson/helpers.ml b/src/passes/9-self_michelson/helpers.ml new file mode 100644 index 000000000..4ce8670c1 --- /dev/null +++ b/src/passes/9-self_michelson/helpers.ml @@ -0,0 +1,19 @@ +open Trace +open Tezos_utils +open Michelson +open Tezos_micheline.Micheline + +type mapper = michelson -> michelson result +let rec map_expression : mapper -> michelson -> michelson result = fun f e -> + let self = map_expression f in + let%bind e' = f e in + match e' with + | Prim (l , p , lst , a) -> ( + let%bind lst' = bind_map_list self lst in + ok @@ Prim (l , p , lst' , a) + ) + | Seq (l , lst) -> ( + let%bind lst' = bind_map_list self lst in + ok @@ Seq (l , lst') + ) + | x -> ok x diff --git a/src/passes/9-self_michelson/main.ml b/src/passes/9-self_michelson/main.ml new file mode 100644 index 000000000..e69de29bb diff --git a/src/passes/9-self_michelson/self_michelson.ml b/src/passes/9-self_michelson/self_michelson.ml new file mode 100644 index 000000000..07d8e4f64 --- /dev/null +++ b/src/passes/9-self_michelson/self_michelson.ml @@ -0,0 +1,31 @@ +open Trace +open Tezos_micheline.Micheline +open Memory_proto_alpha.Protocol.Michelson_v1_primitives + +let strip_annots = fun e -> + match e with + | Prim (l , p , lst , _) -> ok @@ Prim (l , p , lst , []) + | x -> ok x + +let strip_nops = fun e -> + match e with + | Seq(l, [Prim (_, I_UNIT, _, _) ; Prim(_, I_DROP, _, _)]) -> ok @@ Seq (l, []) + | x -> ok x + + +let all = [ + strip_annots ; + strip_nops ; +] + +let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> + match fs with + | [] -> ok x + | hd :: tl -> ( + let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in + bind aux (ok x) + ) + +let all_expression = + let all_expr = List.map Helpers.map_expression all in + bind_chain all_expr From 8a04ee8097536830a8a570e66440800e916f95e1 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 25 Sep 2019 13:29:00 -0500 Subject: [PATCH 49/53] Fix bug for compile-parameter and compile-storage --- src/main/run/of_simplified.ml | 7 +------ src/main/run/of_source.ml | 16 ++++++++++++---- src/stages/ast_typed/misc.ml | 5 +++++ 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 523ceed23..4bc7729b8 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -1,11 +1,6 @@ open Trace open Ast_simplified -let get_final_environment program = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - let (Ast_typed.Declaration_constant (_ , (_ , post_env))) = last_declaration in - post_env - let compile_expression ?(value = false) ?env expr = if value then ( @@ -22,7 +17,7 @@ let run_typed_program (input : expression) : expression result = let%bind code = Compile.Of_typed.compile_function_entry program entry in let%bind input = - let env = get_final_environment program in + let env = Ast_typed.program_environment program in compile_expression ?value:input_to_value ~env input in let%bind ex_ty_value = Of_michelson.run ?options code input in diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index 5fed28c09..f9a8e776c 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -50,15 +50,19 @@ end let compile_file_contract_parameter : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> + let%bind program = Compile.Of_source.type_file syntax source_filename in + let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression simplified + Of_simplified.compile_expression simplified ~env let compile_file_expression : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> + let%bind program = Compile.Of_source.type_file syntax source_filename in + let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression simplified + Of_simplified.compile_expression simplified ~env let compile_expression : string -> Compile.Helpers.s_syntax -> Michelson.t result = fun expression syntax -> @@ -68,17 +72,21 @@ let compile_expression : string -> Compile.Helpers.s_syntax -> Michelson.t resul let compile_file_contract_storage ~value : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> + let%bind program = Compile.Of_source.type_file syntax source_filename in + let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression ~value simplified + Of_simplified.compile_expression ~value simplified ~env let compile_file_contract_args = fun ?value source_filename _entry_point storage parameter syntax -> + let%bind program = Compile.Of_source.type_file syntax source_filename in + let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind storage_simplified = Compile.Helpers.parsify_expression syntax storage in let%bind parameter_simplified = Compile.Helpers.parsify_expression syntax parameter in let args = Ast_simplified.e_pair storage_simplified parameter_simplified in - Of_simplified.compile_expression ?value args + Of_simplified.compile_expression ?value args ~env let run_contract ?amount ?storage_value source_filename entry_point storage parameter syntax = diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 5aaf28550..db33f6062 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -500,3 +500,8 @@ let get_entry (lst : program) (name : string) : annotated_expression result = else None in List.find_map aux lst + +let program_environment (program : program) : full_environment = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env From 1f8a801ed92bbe9faea03bddc31f4e1313e28a02 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 25 Sep 2019 13:29:50 -0500 Subject: [PATCH 50/53] Don't test exact compiler output --- scripts/test_cli.sh | 92 +-------------------------------------------- 1 file changed, 1 insertion(+), 91 deletions(-) diff --git a/scripts/test_cli.sh b/scripts/test_cli.sh index ab02ff575..ad83f2e64 100755 --- a/scripts/test_cli.sh +++ b/scripts/test_cli.sh @@ -5,102 +5,12 @@ compiled_storage=$(./scripts/ligo_ci.sh compile-storage src/test/contracts/websi compiled_parameter=$(./scripts/ligo_ci.sh compile-parameter src/test/contracts/website2.ligo main "Increment(1)"); dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo main "Increment(1)" 1); -expected_compiled_contract="{ parameter (or int int) ; - storage int ; - code { {} ; - {} ; - {} ; - { PUSH (lambda (pair int int) int) - { {} ; - {} ; - {} ; - { { { DUP ; DIP { {} } } ; CAR } ; - { { { { DIP { DUP } ; SWAP } ; DIP { {} } } ; CDR } ; - { PUSH unit Unit ; - DROP ; - { { { DIP { DUP } ; SWAP } ; DIP { { DUP ; DIP { {} } } } } ; - ADD } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } ; - {} } ; - { PUSH (lambda (pair int int) int) - { {} ; - {} ; - {} ; - { { { DUP ; DIP { {} } } ; CAR } ; - { { { { DIP { DUP } ; SWAP } ; DIP { {} } } ; CDR } ; - { PUSH unit Unit ; - DROP ; - { { { DIP { DUP } ; SWAP } ; DIP { { DUP ; DIP { {} } } } } ; - SUB } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } ; - {} } ; - { { { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } ; DIP { {} } } ; - CAR } ; - { { { { DIP { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } } ; SWAP } ; - DIP { {} } } ; - CDR } ; - { PUSH unit Unit ; - DROP ; - { { NIL operation ; - DIP { { { { DIP { DUP } ; SWAP } ; - IF_LEFT - { { { DUP ; - { { { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } ; - DIP { { DUP ; DIP { {} } } } } ; - PAIR } ; - DIP { { DIP { { DIP { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } } ; SWAP } } ; - SWAP } } ; - EXEC } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } } - { { { DUP ; - { { { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } ; - DIP { { DUP ; DIP { {} } } } } ; - PAIR } ; - DIP { { DIP { { DIP { { DIP { { DIP { { DIP { DUP } ; SWAP } } ; SWAP } } ; SWAP } } ; - SWAP } } ; - SWAP } } ; - EXEC } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } } } ; - DIP { {} } } } } ; - PAIR } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } } ; - {} ; - DIP { DROP } ; - {} } }"; expected_compiled_parameter="(Right 1)"; expected_compiled_storage=1; expected_dry_run_output="tuple[ list[] 2 ]"; -if [ "$compiled_contract" != "$expected_compiled_contract" ]; then - echo "Expected $expected_compiled_contract as compile-storage output, got $compiled_contract instead"; - exit 1; -fi - if [ "$compiled_storage" != "$expected_compiled_storage" ]; then echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead"; exit 1; @@ -116,4 +26,4 @@ if [ "$dry_run_output" != "$expected_dry_run_output" ]; then exit 1; fi -echo "CLI tests passed"; \ No newline at end of file +echo "CLI tests passed"; From a521c01115bf49326245c05f779c98bb28cc35e0 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Sat, 21 Sep 2019 18:38:45 -0700 Subject: [PATCH 51/53] some michelson optimizations --- src/main/compile/dune | 1 - src/main/compile/michelson.ml | 0 src/main/compile/of_mini_c.ml | 12 +- src/passes/9-self_michelson/self_michelson.ml | 402 +++++++++++++++++- vendors/ligo-utils/simple-utils/x_list.ml | 9 +- 5 files changed, 393 insertions(+), 31 deletions(-) delete mode 100644 src/main/compile/michelson.ml diff --git a/src/main/compile/dune b/src/main/compile/dune index a3c992c69..705ed50b9 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -14,7 +14,6 @@ mini_c compiler self_michelson - operators ) (preprocess (pps ppx_let) diff --git a/src/main/compile/michelson.ml b/src/main/compile/michelson.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 1a385040f..296e4d814 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -2,19 +2,21 @@ open Trace open Mini_c open Tezos_utils -let compile_value : value -> type_value -> Michelson.t result = - Compiler.Program.translate_value +let compile_value : value -> type_value -> Michelson.t result = fun x a -> + let%bind body = Compiler.Program.translate_value x a in + let body = Self_michelson.optimize body in + ok body let compile_expression_as_value : expression -> _ result = fun e -> let%bind value = expression_to_value e in let%bind result = compile_value value e.type_value in - let%bind result = Self_michelson.all_expression result in + let result = Self_michelson.optimize result in ok result let compile_expression_as_function : expression -> _ result = fun e -> let (input , output) = t_unit , e.type_value in let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in - let%bind body = Self_michelson.all_expression body in + let body = Self_michelson.optimize body in let body = Michelson.(seq [ i_drop ; body ]) in let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in let open! Compiler.Program in @@ -24,7 +26,7 @@ let compile_function = fun e -> let%bind (input , output) = get_t_function e.type_value in let%bind body = get_function e in let%bind body = compile_value body (t_function input output) in - let%bind body = Self_michelson.all_expression body in + let body = Self_michelson.optimize body in let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in let open! Compiler.Program in ok { input ; output ; body } diff --git a/src/passes/9-self_michelson/self_michelson.ml b/src/passes/9-self_michelson/self_michelson.ml index 07d8e4f64..3085376e3 100644 --- a/src/passes/9-self_michelson/self_michelson.ml +++ b/src/passes/9-self_michelson/self_michelson.ml @@ -1,31 +1,387 @@ -open Trace +(* This file attempts to optimize Michelson code. The goal is to + reduce the code size (the size of the binary Micheline.) + + I have ignored the 'execution gas' completely, because it seems + that users will encounter code size problems earlier and more + often. +*) + open Tezos_micheline.Micheline -open Memory_proto_alpha.Protocol.Michelson_v1_primitives +open Tezos_utils.Michelson -let strip_annots = fun e -> - match e with - | Prim (l , p , lst , _) -> ok @@ Prim (l , p , lst , []) - | x -> ok x +(* `arity p` should be `Some n` only if p is (always) an instruction + which removes n items from the stack and uses them to push 1 item, + without effects other than gas consumption. It must never fail. *) -let strip_nops = fun e -> - match e with - | Seq(l, [Prim (_, I_UNIT, _, _) ; Prim(_, I_DROP, _, _)]) -> ok @@ Seq (l, []) - | x -> ok x +let arity : prim -> int option = function + | I_PACK -> Some 1 + | I_UNPACK -> Some 1 + | I_BLAKE2B -> Some 1 + | I_SHA256 -> Some 1 + | I_SHA512 -> Some 1 + | I_ABS -> Some 1 + | I_ADD -> None (* can fail for tez *) + | I_AMOUNT -> Some 0 + | I_AND -> Some 2 + | I_BALANCE -> Some 0 + | I_CAR -> Some 1 + | I_CDR -> Some 1 + | I_CHECK_SIGNATURE -> Some 3 + | I_COMPARE -> Some 2 + | I_CONCAT -> None (* sometimes 1, sometimes 2 :( *) + | I_CONS -> Some 2 + | I_CREATE_ACCOUNT -> None (* effects, kind of *) + | I_CREATE_CONTRACT -> None (* effects, kind of *) + | I_IMPLICIT_ACCOUNT -> Some 1 + | I_DIP -> None + | I_DROP -> None + | I_DUP -> None + | I_EDIV -> Some 2 + | I_EMPTY_MAP -> Some 0 + | I_EMPTY_SET -> Some 0 + | I_EQ -> Some 1 + | I_EXEC -> None (* effects *) + | I_FAILWITH -> None + | I_GE -> Some 1 + | I_GET -> Some 2 + | I_GT -> Some 1 + | I_HASH_KEY -> Some 1 + | I_IF -> None + | I_IF_CONS -> None + | I_IF_LEFT -> None + | I_IF_NONE -> None + | I_INT -> Some 1 + | I_LAMBDA -> Some 0 + | I_LE -> Some 1 + | I_LEFT -> Some 1 + | I_LOOP -> None + | I_LSL -> Some 1 + | I_LSR -> Some 1 + | I_LT -> Some 1 + | I_MAP -> None + | I_MEM -> Some 2 + | I_MUL -> None (* can fail for tez *) + | I_NEG -> Some 1 + | I_NEQ -> Some 1 + | I_NIL -> Some 0 + | I_NONE -> Some 0 + | I_NOT -> Some 1 + | I_NOW -> Some 0 + | I_OR -> Some 2 + | I_PAIR -> Some 2 + | I_PUSH -> Some 0 + | I_RIGHT -> Some 1 + | I_SIZE -> Some 1 + | I_SOME -> Some 1 + | I_SOURCE -> Some 0 + | I_SENDER -> Some 0 + | I_SELF -> Some 0 + | I_SLICE -> Some 3 + | I_STEPS_TO_QUOTA -> Some 0 + | I_SUB -> None (* can fail for tez *) + | I_SWAP -> None + | I_TRANSFER_TOKENS -> None (* effects, kind of *) + | I_SET_DELEGATE -> None (* effects, kind of *) + | I_UNIT -> Some 0 + | I_UPDATE -> Some 3 + | I_XOR -> Some 2 + | I_ITER -> None + | I_LOOP_LEFT -> None + | I_ADDRESS -> Some 1 + | I_CONTRACT -> Some 1 + | I_ISNAT -> Some 1 + | I_CAST -> None + | I_RENAME -> None + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address -> None -let all = [ - strip_annots ; - strip_nops ; -] +let is_nullary_op (p : prim) : bool = + match arity p with + | Some 0 -> true + | _ -> false -let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> +let is_unary_op (p : prim) : bool = + match arity p with + | Some 1 -> true + | _ -> false + +let is_binary_op (p : prim) : bool = + match arity p with + | Some 2 -> true + | _ -> false + +let is_ternary_op (p : prim) : bool = + match arity p with + | Some 3 -> true + | _ -> false + +let unseq : michelson -> michelson list = function + | Seq (_, args) -> args + | x -> [x] + +(* Replace `PUSH (lambda a b) {}` with `LAMBDA a b {}` *) +let rec use_lambda_instr : michelson -> michelson = + fun x -> + match x with + | Seq (l, args) -> + Seq (l, List.map use_lambda_instr args) + | Prim (_, I_PUSH, [Prim (_, T_lambda, [arg; ret], _); code], _) -> + i_lambda arg ret code + | Prim (_, I_PUSH, _, _) -> + x (* possibly missing some nested lambdas *) + | Prim (l, p, args, annot) -> + Prim (l, p, List.map use_lambda_instr args, annot) + | _ -> x + +(* This flattens nested seqs. {} is erased, { { code1 } ; { code2 } } + becomes { code1 ; code2 }, etc. This is important because each seq + costs 5 bytes, for the "Seq" tag and a 4 byte length. *) +let rec flatten_seqs : michelson -> michelson = + fun x -> + match x with + | Seq (l, args) -> + let args = List.concat @@ List.map (fun x -> unseq (flatten_seqs x)) args in + Seq (l, args) + (* Should not flatten literal seq data in PUSH. Ugh... *) + | Prim (_, I_PUSH, _, _) -> x + | Prim (l, p, args, annot) -> Prim (l, p, List.map flatten_seqs args, annot) + | _ -> x + +type peep1 = michelson -> michelson list option +type peep2 = michelson * michelson -> michelson list option +type peep3 = michelson * michelson * michelson -> michelson list option +type peep4 = michelson * michelson * michelson * michelson -> michelson list option + +let rec peep1 (f : peep1) : michelson list -> bool * michelson list = function + | [] -> (false, []) + | x1 :: xs -> + match f x1 with + | Some xs' -> let (_, xs') = peep1 f (xs' @ xs) in + (true, xs') + | None -> let (changed, xs) = peep1 f xs in + (changed, x1 :: xs) + +let rec peep2 (f : peep2) : michelson list -> bool * michelson list = function + | [] -> (false, []) + | [x] -> (false, [x]) + | x1 :: x2 :: xs -> + match f (x1, x2) with + | Some xs' -> let (_, xs') = peep2 f (xs' @ xs) in + (true, xs') + | None -> let (changed, xs') = peep2 f (x2 :: xs) in + (changed, x1 :: xs') + +let rec peep3 (f : peep3) : michelson list -> bool * michelson list = function + | [] -> (false, []) + | [x] -> (false, [x]) + | [x ; y] -> (false, [x ; y]) + | x1 :: x2 :: x3 :: xs -> + match f (x1, x2, x3) with + | Some xs' -> let (_, xs') = peep3 f (xs' @ xs) in + (true, xs') + | None -> let (changed, xs') = peep3 f (x2 :: x3 :: xs) in + (changed, x1 :: xs') + +let rec peep4 (f : peep4) : michelson list -> bool * michelson list = function + | [] -> (false, []) + | [x] -> (false, [x]) + | [x ; y] -> (false, [x ; y]) + | [x ; y ; z] -> (false, [x ; y ; z]) + | x1 :: x2 :: x3 :: x4 :: xs -> + match f (x1, x2, x3, x4) with + | Some xs' -> let (_, xs') = peep4 f (xs' @ xs) in + (true, xs') + | None -> let (changed, xs') = peep4 f (x2 :: x3 :: x4 :: xs) in + (changed, x1 :: xs') + +(* apply f to all seqs *) +let rec peephole (f : michelson list -> bool * michelson list) : michelson -> bool * michelson = + let peep_args ~seq args = + let (changed, args) = if seq + then f args + else (false, args) in + List.fold_map_acc + (fun changed1 arg -> + let (changed2, arg) = peephole f arg in + (changed1 || changed2, arg)) + changed + args in + function + | Seq (l, args) -> let (changed, args) = peep_args ~seq:true args in + (changed, Seq (l, args)) + | Prim (l, p, args, annot) -> let (changed, args) = peep_args ~seq:false args in + (changed, Prim (l, p, args, annot)) + | x -> (false, x) + +(* apply the optimizers in order *) +let rec sequence_optimizers (fs : (michelson -> bool * michelson) list) : michelson -> bool * michelson = match fs with - | [] -> ok x - | hd :: tl -> ( - let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in - bind aux (ok x) - ) + | [] -> fun x -> (false, x) + | f :: fs -> fun x -> let (changed1, x) = f x in + let (changed2, x) = sequence_optimizers fs x in + (changed1 || changed2, x) -let all_expression = - let all_expr = List.map Helpers.map_expression all in - bind_chain all_expr +(* take the fixed point of an optimizer (!) *) +let rec iterate_optimizer (f : michelson -> bool * michelson) : michelson -> michelson = + fun x -> + let (changed, x) = f x in + if changed + then iterate_optimizer f x + else x + +let opt_drop2 : peep2 = function + (* nullary_op ; DROP ↦ *) + | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_nullary_op p -> Some [] + (* DUP ; DROP ↦ *) + | Prim (_, I_DUP, _, _), Prim (_, I_DROP, _, _) -> Some [] + (* unary_op ; DROP ↦ DROP *) + | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_unary_op p -> Some [i_drop] + (* binary_op ; DROP ↦ DROP ; DROP *) + | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_binary_op p -> Some [i_drop; i_drop] + (* ternary_op ; DROP ↦ DROP ; DROP ; DROP *) + | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_ternary_op p -> Some [i_drop; i_drop; i_drop] + | _ -> None + +let opt_drop4 : peep4 = function + (* DUP; unary_op; SWAP; DROP ↦ unary_op *) + | Prim (_, I_DUP, _, _), + (Prim (_, p, _, _) as unary_op), + Prim (_, I_SWAP, _, _), + Prim (_, I_DROP, _, _) + when is_unary_op p -> + Some [unary_op] + | _ -> None + +let opt_dip1 : peep1 = function + (* DIP {} ↦ *) + | Prim (_, I_DIP, [Seq (_, [])], _) -> Some [] + (* DIP { nullary_op } ↦ nullary_op ; SWAP *) + | Prim (_, I_DIP, [Seq (_, [(Prim (_, p, _, _) as push)])], _) when is_nullary_op p -> + Some [push ; i_swap] + (* DIP { unary_op } ↦ SWAP ; unary_op ; SWAP *) + | Prim (_, I_DIP, [Seq (_, [(Prim (_, p, _, _) as unary_op)])], _) when is_unary_op p -> + Some [i_swap ; unary_op ; i_swap] + (* saves 5 bytes *) + (* DIP { DROP } ↦ SWAP ; DROP *) + | Prim (_, I_DIP, [Seq (_, [Prim (_, I_DROP, _, _)])], _) -> + Some [i_swap; i_drop] + (* saves 3 bytes *) + (* DIP { DROP ; DROP } ↦ SWAP ; DROP ; SWAP ; DROP *) + | Prim (_, I_DIP, [Seq (_, [Prim (_, I_DROP, _, _) ; Prim (_, I_DROP, _, _)])], _) -> + Some [i_swap; i_drop; i_swap; i_drop] + (* still saves 1 byte *) + (* DIP { DROP ; DROP ; DROP } ↦ SWAP ; DROP ; SWAP ; DROP ; SWAP ; DROP *) + | Prim (_, I_DIP, [Seq (_, [Prim (_, I_DROP, _, _) ; Prim (_, I_DROP, _, _) ; Prim (_, I_DROP, _, _)])], _) -> + Some [i_swap; i_drop; i_swap; i_drop; i_swap; i_drop] + (* after this, DIP { DROP ; ... } is smaller *) + | _ -> None + +let opt_dip2 : peep2 = function + (* combine adjacent dips, shaving a seq and enabling further + optimization inside the DIP: *) + (* DIP { code1 } ; DIP { code2 } ↦ DIP { code1 ; code2 } *) + | Prim (_, I_DIP, [Seq (_, code1)], _), Prim (_, I_DIP, [Seq (_, code2)], _) -> + Some [Prim (0, I_DIP, [Seq (0, code1 @ code2)], [])] + (* DIP { code } ; DROP ↦ DROP ; code *) + | Prim (_, I_DIP, code, _), (Prim (_, I_DROP, _, _) as drop) -> + Some (drop :: code) + (* nullary_op ; DIP { code } ↦ code ; nullary_op *) + | (Prim (_, p, _, _) as nullary_op), Prim (_, I_DIP, [Seq (_, code)], _) when is_nullary_op p -> + Some (code @ [nullary_op]) + (* DIP { code } ; unary_op ↦ unary_op ; DIP { code } *) + | (Prim (_, I_DIP, _, _) as dip), (Prim (_, p, _, _) as unary_op) when is_unary_op p -> + Some [unary_op; dip] + (* unary_op ; DIP { code } ↦ DIP { code } ; unary_op *) + (* | (Prim (_, p, _, _) as unary_op), (Prim (_, I_DIP, _, _) as dip) when is_unary_op p -> + * Some [dip; unary_op] *) + | _ -> None + +let opt_dip3 : peep3 = function + (* replace UNPAIR/UNPIAR with a smaller version *) + (* TODO probably better to implement optimal UNPAIR in the compiler *) + (* DUP ; CAR ; DIP { CDR } ↦ DUP ; CDR ; SWAP ; CAR *) + | Prim (_, I_DUP, _, _), + (Prim (_, (I_CAR | I_CDR), _, _) as proj1), + Prim (_, I_DIP, [Seq (_, [(Prim (_, (I_CAR | I_CDR), _, _) as proj2)])], _) -> + Some [ i_dup ; proj2 ; i_swap ; proj1 ] + | _ -> None + +let opt_swap2 : peep2 = function + (* SWAP ; SWAP ↦ *) + | Prim (_, I_SWAP, _, _), Prim (_, I_SWAP, _, _) -> + Some [] + (* DUP ; SWAP ↦ DUP *) + | Prim (_, I_DUP, _, _), Prim (_, I_SWAP, _, _) -> + Some [i_dup] + (* SWAP ; ADD ↦ ADD *) + (* etc *) + | Prim (_, I_SWAP, _, _), (Prim (_, (I_ADD | I_OR | I_AND | I_XOR), _, _) as comm_op) -> + Some [comm_op] + | _ -> None + +(* This "optimization" deletes dead code produced by the compiler + after a FAILWITH, which is illegal in Michelson. This means we are + thwarting the intent of the Michelson tail fail restriction -- the + LIGO _user_ might accidentally write dead code immediately after a + failure, and we will simply erase it. *) +let rec opt_tail_fail : michelson -> michelson = + function + | Seq (l, args) -> + let rec aux args = + match args with + | [] -> [] + | Prim (l, I_FAILWITH, args, annot) :: _ -> [ Prim (l, I_FAILWITH, args, annot) ] + | arg :: args -> arg :: aux args in + let args = aux args in + Seq (l, List.map opt_tail_fail args) + | Prim (l, p, args, annot) -> + Prim (l, p, List.map opt_tail_fail args, annot) + | x -> x + +let optimize : michelson -> michelson = + fun x -> + let x = use_lambda_instr x in + let x = flatten_seqs x in + let x = opt_tail_fail x in + let optimizers = [ peephole @@ peep2 opt_drop2 ; + peephole @@ peep4 opt_drop4 ; + peephole @@ peep3 opt_dip3 ; + peephole @@ peep2 opt_dip2 ; + peephole @@ peep1 opt_dip1 ; + peephole @@ peep2 opt_swap2 ; + ] in + let x = iterate_optimizer (sequence_optimizers optimizers) x in + x diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 67ee96331..a7d36261b 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -22,7 +22,7 @@ let fold_map_right : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> el in snd @@ aux (acc , []) f (List.rev lst) -let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list = +let fold_map_acc : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> acc * ret list = fun f acc lst -> let rec aux (acc , prev) f = function | [] -> (acc , prev) @@ -30,7 +30,12 @@ let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list let (acc' , hd') = f acc hd in aux (acc' , hd' :: prev) f tl in - List.rev @@ snd @@ aux (acc , []) f lst + let (acc, lst) = aux (acc , []) f lst in + (acc, List.rev lst) + +let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list = + fun f acc lst -> + snd (fold_map_acc f acc lst) let fold_right' f init lst = List.fold_left f init (List.rev lst) From 8a96e38f040203b5b818bbc1cdd7572451d9b23a Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Sat, 21 Sep 2019 18:39:06 -0700 Subject: [PATCH 52/53] More failure tests, fix mligo assert --- src/passes/operators/operators.ml | 3 +-- src/test/contracts/assert.mligo | 3 +++ src/test/contracts/coase.ligo | 6 +++--- src/test/contracts/failwith.ligo | 12 ++++++++++++ src/test/integration_tests.ml | 23 +++++++++++++++++++++-- 5 files changed, 40 insertions(+), 7 deletions(-) create mode 100644 src/test/contracts/assert.mligo create mode 100644 src/test/contracts/failwith.ligo diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 75b940e22..6568b2863 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -703,8 +703,7 @@ module Compiler = struct ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; - ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; - ("ASSERT" , simple_unary @@ i_if (seq [i_push_unit ; i_failwith]) (seq [i_push_unit])) ; + ("ASSERT" , simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_unit ; i_failwith])) ; ("INT" , simple_unary @@ prim I_INT) ; ("ABS" , simple_unary @@ prim I_ABS) ; ("CONS" , simple_binary @@ prim I_CONS) ; diff --git a/src/test/contracts/assert.mligo b/src/test/contracts/assert.mligo new file mode 100644 index 000000000..9b57d7c9e --- /dev/null +++ b/src/test/contracts/assert.mligo @@ -0,0 +1,3 @@ +let%entry main (p : bool) (s : unit) = + let u : unit = assert(p) in + (([] : operation list), s) diff --git a/src/test/contracts/coase.ligo b/src/test/contracts/coase.ligo index ea7f9d057..b1f1da4a4 100644 --- a/src/test/contracts/coase.ligo +++ b/src/test/contracts/coase.ligo @@ -41,7 +41,7 @@ function transfer_single(const action : action_transfer_single ; const s : stora begin const cards : cards = s.cards ; const card : card = get_force(action.card_to_transfer , cards) ; - if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; + if (card.card_owner =/= source) then failwith("This card doesn't belong to you") else skip ; card.card_owner := action.destination ; cards[action.card_to_transfer] := card ; s.cards := cards ; @@ -51,7 +51,7 @@ function transfer_single(const action : action_transfer_single ; const s : stora function sell_single(const action : action_sell_single ; const s : storage_type) : (list(operation) * storage_type) is begin const card : card = get_force(action.card_to_sell , s.cards) ; - if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; + if (card.card_owner =/= source) then failwith("This card doesn't belong to you") else skip ; const card_pattern : card_pattern = get_force(card.card_pattern , s.card_patterns) ; card_pattern.quantity := abs(card_pattern.quantity - 1n); const card_patterns : card_patterns = s.card_patterns ; @@ -71,7 +71,7 @@ function buy_single(const action : action_buy_single ; const s : storage_type) : // Check funds const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ; const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ; - if (price > amount) then fail "Not enough money" else skip ; + if (price > amount) then failwith("Not enough money") else skip ; // Administrative procedure const operations : list(operation) = nil ; // Increase quantity diff --git a/src/test/contracts/failwith.ligo b/src/test/contracts/failwith.ligo new file mode 100644 index 000000000..9a59c5ec4 --- /dev/null +++ b/src/test/contracts/failwith.ligo @@ -0,0 +1,12 @@ +type param is +| Zero of nat +| Pos of nat + +function main (const p : param; const s : unit) : list(operation) * unit is + block { + case p of + | Zero (n) -> if n > 0n then failwith("fail") else skip + | Pos (n) -> if n > 0n then skip else failwith("fail") + end + } + with ((nil : list(operation)), s) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 5e8008999..10d671050 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -643,11 +643,28 @@ let dispatch_counter_contract () : unit result = e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected +let failwith_ligo () : unit result = + let%bind program = type_file "./contracts/failwith.ligo" in + let should_fail = expect_fail program "main" in + let should_work input = expect_eq program "main" input (e_pair (e_typed_list [] t_operation) (e_unit ())) in + let%bind _ = should_work (e_pair (e_constructor "Zero" (e_nat 0)) (e_unit ())) in + let%bind _ = should_fail (e_pair (e_constructor "Zero" (e_nat 1)) (e_unit ())) in + let%bind _ = should_work (e_pair (e_constructor "Pos" (e_nat 1)) (e_unit ())) in + let%bind _ = should_fail (e_pair (e_constructor "Pos" (e_nat 0)) (e_unit ())) in + ok () + let failwith_mligo () : unit result = let%bind program = mtype_file "./contracts/failwith.mligo" in let make_input = e_pair (e_unit ()) (e_unit ()) in + expect_fail program "main" make_input + +let assert_mligo () : unit result = + let%bind program = mtype_file "./contracts/assert.mligo" in + let make_input b = e_pair (e_bool b) (e_unit ()) in let make_expected = e_pair (e_typed_list [] t_operation) (e_unit ()) in - expect_eq program "main" make_input make_expected + let%bind _ = expect_fail program "main" (make_input false) in + let%bind _ = expect_eq program "main" (make_input true) make_expected in + ok () let guess_the_hash_mligo () : unit result = let%bind program = mtype_file "./contracts/new-syntax.mligo" in @@ -800,7 +817,9 @@ let main = test_suite "Integration (End to End)" [ test "match variant 2 (mligo)" match_matej ; test "list matching (mligo)" mligo_list ; (* test "guess the hash mligo" guess_the_hash_mligo ; WIP? *) - (* test "failwith mligo" failwith_mligo ; *) + test "failwith ligo" failwith_ligo ; + test "failwith mligo" failwith_mligo ; + test "assert mligo" assert_mligo ; (* test "guess string mligo" guess_string_mligo ; WIP? *) test "lambda mligo" lambda_mligo ; test "lambda ligo" lambda_ligo ; From 389cbdbdedb488d536978abd8347d0037ea086e3 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Thu, 26 Sep 2019 06:01:09 -0500 Subject: [PATCH 53/53] Hotfix: display errors, fix mystery `fail` --- src/bin/cli_helpers.ml | 4 ++-- src/passes/operators/operators.ml | 1 + src/test/contracts/coase.ligo | 6 +++--- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index ee757ffba..7057e0975 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -10,7 +10,7 @@ let toplevel ~(display_format : string) (x : string result) = ) in match x with - | Ok _ -> Format.printf "%a" (formatted_string_result_pp display_format) x + | Ok _ -> Format.printf "%a\n%!" (formatted_string_result_pp display_format) x | Error _ -> - Format.eprintf "%a" (formatted_string_result_pp display_format) x ; + Format.eprintf "%a\n%!" (formatted_string_result_pp display_format) x ; exit 1 diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 6568b2863..ceb17f17a 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -703,6 +703,7 @@ module Compiler = struct ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; + ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; ("ASSERT" , simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_unit ; i_failwith])) ; ("INT" , simple_unary @@ prim I_INT) ; ("ABS" , simple_unary @@ prim I_ABS) ; diff --git a/src/test/contracts/coase.ligo b/src/test/contracts/coase.ligo index b1f1da4a4..ea7f9d057 100644 --- a/src/test/contracts/coase.ligo +++ b/src/test/contracts/coase.ligo @@ -41,7 +41,7 @@ function transfer_single(const action : action_transfer_single ; const s : stora begin const cards : cards = s.cards ; const card : card = get_force(action.card_to_transfer , cards) ; - if (card.card_owner =/= source) then failwith("This card doesn't belong to you") else skip ; + if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; card.card_owner := action.destination ; cards[action.card_to_transfer] := card ; s.cards := cards ; @@ -51,7 +51,7 @@ function transfer_single(const action : action_transfer_single ; const s : stora function sell_single(const action : action_sell_single ; const s : storage_type) : (list(operation) * storage_type) is begin const card : card = get_force(action.card_to_sell , s.cards) ; - if (card.card_owner =/= source) then failwith("This card doesn't belong to you") else skip ; + if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; const card_pattern : card_pattern = get_force(card.card_pattern , s.card_patterns) ; card_pattern.quantity := abs(card_pattern.quantity - 1n); const card_patterns : card_patterns = s.card_patterns ; @@ -71,7 +71,7 @@ function buy_single(const action : action_buy_single ; const s : storage_type) : // Check funds const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ; const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ; - if (price > amount) then failwith("Not enough money") else skip ; + if (price > amount) then fail "Not enough money" else skip ; // Administrative procedure const operations : list(operation) = nil ; // Increase quantity