balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'feature/transpiler' into 'dev'

Browse Source 
Feature/transpiler

See merge request ligolang/ligo!696
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-06-29 13:05:35 +00:00
commit b1ccaef07e
91 changed files with 4562 additions and 739 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/bin/cli.ml
View File

@ -137,9 +137,9 @@ let optimize =
value @@ opt (some string) None info
module Helpers = Ligo.Compile.Helpers
module Compile = Ligo.Compile
module Uncompile = Ligo.Uncompile
module Helpers = Ligo.Compile.Helpers
module Compile = Ligo.Compile
module Decompile = Ligo.Decompile
module Run = Ligo.Run.Of_michelson
let compile_file =
@ -285,7 +285,7 @@ let compile_parameter =
let interpret =
let f expression init_file syntax amount balance sender source predecessor_timestamp display_format =
return_result ~display_format (Uncompile.Formatter.expression_format) @@
return_result ~display_format (Decompile.Formatter.expression_format) @@
let%bind (decl_list,state,env) = match init_file with
| Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
@ -299,7 +299,7 @@ let interpret =
let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
Uncompile.uncompile_expression typed_exp.type_expression runres
Decompile.Of_michelson.decompile_expression typed_exp.type_expression runres
in
let term =
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
@ -345,7 +345,7 @@ let compile_storage =
let dry_run =
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
return_result ~display_format (Uncompile.Formatter.expression_format) @@
return_result ~display_format (Decompile.Formatter.expression_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
@ -359,7 +359,7 @@ let dry_run =
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
Decompile.Of_michelson.decompile_typed_program_entry_function_result typed_prg entry_point runres
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@ -369,7 +369,7 @@ let dry_run =
let run_function =
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
return_result ~display_format (Uncompile.Formatter.expression_format) @@
return_result ~display_format (Decompile.Formatter.expression_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
@ -386,7 +386,7 @@ let run_function =
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in
Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
Decompile.Of_michelson.decompile_typed_program_entry_function_result typed_prg entry_point runres
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@ -396,14 +396,14 @@ let run_function =
let evaluate_value =
let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
return_result ~display_format Uncompile.Formatter.expression_format @@
return_result ~display_format Decompile.Formatter.expression_format @@
let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
let%bind mini_c = Compile.Of_typed.compile typed_prg in
let%bind (exp,_) = trace_option Main_errors.entrypoint_not_found @@ Mini_c.get_entry mini_c entry_point in
let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options compiled.expr compiled.expr_ty in
Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point runres
Decompile.Of_michelson.decompile_typed_program_entry_expression_result typed_prg entry_point runres
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@ -449,6 +449,41 @@ let list_declarations =
let doc = "Subcommand: List all the top-level declarations." in
(Term.ret term , Term.info ~doc cmdname)
let transpile_contract =
let f source_file new_syntax syntax display_format =
return_result ~display_format (Parser.Formatter.ppx_format) @@
let%bind core = Compile.Utils.to_core source_file syntax in
let%bind sugar = Decompile.Of_core.decompile core in
let%bind imperative = Decompile.Of_sugar.decompile sugar in
let%bind buffer = Decompile.Of_imperative.decompile imperative (Syntax_name new_syntax) in
ok @@ buffer
in
let term =
Term.(const f $ source_file 0 $ req_syntax 1 $ syntax $ display_format) in
let cmdname = "transpile-contract" in
let doc = "Subcommand: Transpile a contract to another syntax." in
(Term.ret term , Term.info ~doc cmdname)
let transpile_expression =
let f expression new_syntax syntax display_format =
return_result ~display_format (Parser.Formatter.ppx_format) @@
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) None in
let%bind n_syntax = Decompile.Helpers.syntax_to_variant (Syntax_name new_syntax) None in
let%bind imperative = Compile.Of_source.compile_expression v_syntax expression in
let%bind sugar = Compile.Of_imperative.compile_expression imperative in
let%bind core = Compile.Of_sugar.compile_expression sugar in
let%bind sugar = Decompile.Of_core.decompile_expression core in
let%bind imperative = Decompile.Of_sugar.decompile_expression sugar in
let%bind buffer = Decompile.Of_imperative.decompile_expression imperative n_syntax in
ok @@ buffer
in
let term =
Term.(const f $ expression "" 1 $ req_syntax 2 $ req_syntax 0 $ display_format) in
let cmdname = "transpile-expression" in
let doc = "Subcommand: Transpile an expression to another syntax." in
(Term.ret term , Term.info ~doc cmdname)
let run ?argv () =
Term.eval_choice ?argv main [
temp_ligo_interpreter ;
@ -457,6 +492,8 @@ let run ?argv () =
compile_parameter ;
compile_storage ;
compile_expression ;
transpile_contract ;
transpile_expression ;
interpret ;
dry_run ;
run_function ;

12
src/bin/expect_tests/help_tests.ml
View File

@ -87,6 +87,12 @@ let%expect_test _ =
run-function
Subcommand: Run a function with the given parameter.
transpile-contract
Subcommand: Transpile a contract to another syntax.
transpile-expression
Subcommand: Transpile an expression to another syntax.
OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of `auto',
@ -181,6 +187,12 @@ let%expect_test _ =
run-function
Subcommand: Run a function with the given parameter.
transpile-contract
Subcommand: Transpile a contract to another syntax.
transpile-expression
Subcommand: Transpile an expression to another syntax.
OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of `auto',

2085
src/bin/expect_tests/transpiler_test.ml Normal file
View File

File diff suppressed because it is too large Load Diff

54
src/main/compile/helpers.ml
View File

@ -18,97 +18,97 @@ let syntax_to_variant (Syntax_name syntax) source =
| _ -> fail (invalid_syntax syntax)
let parsify_pascaligo source =
let parse_and_abstract_pascaligo source =
let%bind raw = trace parser_tracer @@
Parser.Pascaligo.parse_file source in
let%bind imperative = trace cit_pascaligo_tracer @@
Tree_abstraction.Pascaligo.compile_program raw
in ok imperative
let parsify_expression_pascaligo source =
let parse_and_abstract_expression_pascaligo source =
let%bind raw = trace parser_tracer @@
Parser.Pascaligo.parse_expression source in
let%bind imperative = trace cit_pascaligo_tracer @@
Tree_abstraction.Pascaligo.compile_expression raw
in ok imperative
let parsify_cameligo source =
let parse_and_abstract_cameligo source =
let%bind raw = trace parser_tracer @@
Parser.Cameligo.parse_file source in
let%bind imperative = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.compile_program raw
in ok imperative
let parsify_expression_cameligo source =
let parse_and_abstract_expression_cameligo source =
let%bind raw = trace parser_tracer @@
Parser.Cameligo.parse_expression source in
let%bind imperative = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.compile_expression raw
in ok imperative
let parsify_reasonligo source =
let parse_and_abstract_reasonligo source =
let%bind raw = trace parser_tracer @@
Parser.Reasonligo.parse_file source in
let%bind imperative = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.compile_program raw
in ok imperative
let parsify_expression_reasonligo source =
let parse_and_abstract_expression_reasonligo source =
let%bind raw = trace parser_tracer @@
Parser.Reasonligo.parse_expression source in
let%bind imperative = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.compile_expression raw
in ok imperative
let parsify syntax source : (Ast_imperative.program, _) Trace.result =
let%bind parsify =
let parse_and_abstract syntax source : (Ast_imperative.program, _) Trace.result =
let%bind parse_and_abstract =
match syntax with
PascaLIGO -> ok parsify_pascaligo
| CameLIGO -> ok parsify_cameligo
| ReasonLIGO -> ok parsify_reasonligo in
let%bind parsified = parsify source in
PascaLIGO -> ok parse_and_abstract_pascaligo
| CameLIGO -> ok parse_and_abstract_cameligo
| ReasonLIGO -> ok parse_and_abstract_reasonligo in
let%bind parsified = parse_and_abstract source in
let%bind applied = trace self_ast_imperative_tracer @@
Self_ast_imperative.all_program parsified in
ok applied
let parsify_expression syntax source =
let%bind parsify = match syntax with
PascaLIGO -> ok parsify_expression_pascaligo
| CameLIGO -> ok parsify_expression_cameligo
| ReasonLIGO -> ok parsify_expression_reasonligo in
let%bind parsified = parsify source in
let parse_and_abstract_expression syntax source =
let%bind parse_and_abstract = match syntax with
PascaLIGO -> ok parse_and_abstract_expression_pascaligo
| CameLIGO -> ok parse_and_abstract_expression_cameligo
| ReasonLIGO -> ok parse_and_abstract_expression_reasonligo in
let%bind parsified = parse_and_abstract source in
let%bind applied = trace self_ast_imperative_tracer @@
Self_ast_imperative.all_expression parsified
in ok applied
let parsify_string_reasonligo source =
let parse_and_abstract_string_reasonligo source =
let%bind raw = trace parser_tracer @@
Parser.Reasonligo.parse_string source in
let%bind imperative = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.compile_program raw
in ok imperative
let parsify_string_pascaligo source =
let parse_and_abstract_string_pascaligo source =
let%bind raw = trace parser_tracer @@
Parser.Pascaligo.parse_string source in
let%bind imperative = trace cit_pascaligo_tracer @@
Tree_abstraction.Pascaligo.compile_program raw
in ok imperative
let parsify_string_cameligo source =
let parse_and_abstract_string_cameligo source =
let%bind raw = trace parser_tracer @@
Parser.Cameligo.parse_string source in
let%bind imperative = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.compile_program raw
in ok imperative
let parsify_string syntax source =
let%bind parsify =
let parse_and_abstract_string syntax source =
let%bind parse_and_abstract =
match syntax with
PascaLIGO -> ok parsify_string_pascaligo
| CameLIGO -> ok parsify_string_cameligo
| ReasonLIGO -> ok parsify_string_reasonligo in
let%bind parsified = parsify source in
PascaLIGO -> ok parse_and_abstract_string_pascaligo
| CameLIGO -> ok parse_and_abstract_string_cameligo
| ReasonLIGO -> ok parse_and_abstract_string_reasonligo in
let%bind parsified = parse_and_abstract source in
let%bind applied = trace self_ast_imperative_tracer @@
Self_ast_imperative.all_program parsified
in ok applied

6
src/main/compile/of_core.ml
View File

@ -24,10 +24,12 @@ let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem
let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result =
let name = Var.of_name entry_point in
let entry_point_var : Ast_core.expression =
{ expression_content = Ast_core.E_variable name ;
{ content = Ast_core.E_variable name ;
sugar = None ;
location = Virtual "generated entry-point variable" } in
let applied : Ast_core.expression =
{ expression_content = Ast_core.E_application {lamb=entry_point_var; args=param} ;
{ content = Ast_core.E_application {lamb=entry_point_var; args=param} ;
sugar = None ;
location = Virtual "generated application" } in
ok applied

4
src/main/compile/of_imperative.ml
View File

@ -3,10 +3,6 @@ open Trace
open Ast_imperative
open Purification
type form =
| Contract of string
| Env
let compile (program : program) : (Ast_sugar.program, _) result =
trace purification_tracer @@ compile_program program

8
src/main/compile/of_source.ml
View File

@ -3,16 +3,16 @@ open Helpers
let compile (source_filename:string) syntax : (Ast_imperative.program , _) result =
let%bind syntax = syntax_to_variant syntax (Some source_filename) in
let%bind abstract = parsify syntax source_filename in
let%bind abstract = parse_and_abstract syntax source_filename in
ok abstract
let compile_string (source:string) syntax : (Ast_imperative.program , _) result =
let%bind abstract = parsify_string syntax source in
let%bind abstract = parse_and_abstract_string syntax source in
ok abstract
let compile_expression : v_syntax -> string -> (Ast_imperative.expression , _) result =
fun syntax exp ->
parsify_expression syntax exp
parse_and_abstract_expression syntax exp
let compile_contract_input : string -> string -> v_syntax -> (Ast_imperative.expression , _) result =
fun storage parameter syntax ->
@ -26,4 +26,4 @@ let preprocess source_filename syntax =
Helpers.preprocess syntax source_filename
let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename
Helpers.pretty_print syntax source_filename

4
src/main/compile/of_sugar.ml
View File

@ -3,10 +3,6 @@ open Ast_sugar
open Desugaring
open Main_errors
type form =
| Contract of string
| Env
let compile (program : program) : (Ast_core.program , _) result =
trace desugaring_tracer @@ compile_program program

19
src/main/uncompile/dune → src/main/decompile/dune
View File

@ -1,17 +1,30 @@
(library
(name uncompile)
(public_name ligo.uncompile)
(name decompile)
(public_name ligo.decompile)
(libraries
main_errors
simple-utils
tezos-utils
parser
tree_abstraction
ast_imperative
self_ast_imperative
purification
ast_sugar
self_ast_sugar
desugaring
ast_core
self_ast_core
typer_new
typer
ast_typed
self_ast_typed
interpreter
spilling
mini_c
self_mini_c
stacking
main_errors
self_michelson
)
(preprocess
(pps ppx_let bisect_ppx --conditional)

0
src/main/uncompile/formatter.ml → src/main/decompile/formatter.ml
View File

78
src/main/decompile/helpers.ml Normal file
View File

@ -0,0 +1,78 @@
open Trace
open Main_errors
type s_syntax = Syntax_name of string
type v_syntax = PascaLIGO | CameLIGO | ReasonLIGO
let syntax_to_variant (Syntax_name syntax) source =
match syntax, source with
"auto", Some sf ->
(match Filename.extension sf with
".ligo" | ".pligo" -> ok PascaLIGO
| ".mligo" -> ok CameLIGO
| ".religo" -> ok ReasonLIGO
| ext -> fail (syntax_auto_detection ext))
| ("pascaligo" | "PascaLIGO"), _ -> ok PascaLIGO
| ("cameligo" | "CameLIGO"), _ -> ok CameLIGO
| ("reasonligo" | "ReasonLIGO"), _ -> ok ReasonLIGO
| _ -> fail (invalid_syntax syntax)
let specialise_and_print_pascaligo program =
let%bind cst = trace cit_pascaligo_tracer @@
Tree_abstraction.Pascaligo.decompile_program program in
let%bind source = trace pretty_tracer @@
Parser.Pascaligo.pretty_print cst
in ok source
let specialise_and_print_expression_pascaligo expression =
let%bind cst = trace cit_pascaligo_tracer @@
Tree_abstraction.Pascaligo.decompile_expression expression in
let%bind source = trace pretty_tracer @@
Parser.Pascaligo.pretty_print_expression cst
in ok source
let specialise_and_print_cameligo program =
let%bind cst = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.decompile_program program in
let%bind source = trace pretty_tracer @@
Parser.Cameligo.pretty_print cst
in ok source
let specialise_and_print_expression_cameligo expression =
let%bind cst = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.decompile_expression expression in
let%bind source = trace pretty_tracer @@
Parser.Cameligo.pretty_print_expression cst
in ok source
let specialise_and_print_reasonligo program =
let%bind cst = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.decompile_program program in
let%bind source = trace pretty_tracer @@
Parser.Reasonligo.pretty_print cst
in ok source
let specialise_and_print_expression_reasonligo expression =
let%bind cst = trace cit_cameligo_tracer @@
Tree_abstraction.Cameligo.decompile_expression expression in
let%bind source = trace pretty_tracer @@
Parser.Reasonligo.pretty_print_expression cst
in ok source
let specialise_and_print syntax source : (Buffer.t, _) Trace.result =
let%bind specialise_and_print =
match syntax with
PascaLIGO -> ok specialise_and_print_pascaligo
| CameLIGO -> ok specialise_and_print_cameligo
| ReasonLIGO -> ok specialise_and_print_reasonligo in
let%bind source = specialise_and_print source in
ok source
let specialise_and_print_expression syntax source =
let%bind specialise_and_print = match syntax with
PascaLIGO -> ok specialise_and_print_expression_pascaligo
| CameLIGO -> ok specialise_and_print_expression_cameligo
| ReasonLIGO -> ok specialise_and_print_expression_reasonligo in
let%bind source = specialise_and_print source in
ok source

10
src/main/decompile/of_core.ml Normal file
View File

@ -0,0 +1,10 @@
open Trace
open Ast_core
open Desugaring
open Main_errors
let decompile (program : program) : (Ast_sugar.program , _) result =
trace sugaring_tracer @@ decompile_program program
let decompile_expression (e : expression) : (Ast_sugar.expression , _) result =
trace sugaring_tracer @@ decompile_expression e

10
src/main/decompile/of_imperative.ml Normal file
View File

@ -0,0 +1,10 @@
open Trace
open Ast_imperative
open Helpers
let decompile (program : program) syntax : (_ , _) result =
let%bind syntax = syntax_to_variant syntax None in
specialise_and_print syntax program
let decompile_expression (e : expression) syntax : (_ , _) result =
specialise_and_print_expression syntax e

30
src/main/uncompile/uncompile.ml → src/main/decompile/of_michelson.ml
View File

@ -5,7 +5,7 @@ open Trace
open Simple_utils.Runned_result
type ret_type = Function | Expression
let uncompile_value func_or_expr program entry ex_ty_value =
let decompile_value func_or_expr program entry ex_ty_value =
let%bind output_type =
let%bind entry_expression = trace_option entrypoint_not_found @@ Ast_typed.get_entry program entry in
match func_or_expr with
@ -14,30 +14,30 @@ let uncompile_value func_or_expr program entry ex_ty_value =
| Function ->
let%bind (_,output_type) = trace_option entrypoint_not_a_function @@ Ast_typed.get_t_function entry_expression.type_expression in
ok output_type in
let%bind mini_c = trace uncompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
let%bind typed = trace uncompile_mini_c @@ Spilling.decompile mini_c output_type in
let%bind core = trace uncompile_typed @@ Typer.untype_expression typed in
let%bind mini_c = trace decompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
let%bind typed = trace decompile_mini_c @@ Spilling.decompile mini_c output_type in
let%bind core = trace decompile_typed @@ Typer.untype_expression typed in
ok @@ core
let uncompile_typed_program_entry_expression_result program entry runned_result =
let decompile_typed_program_entry_expression_result program entry runned_result =
match runned_result with
| Fail s -> ok (Fail s)
| Success ex_ty_value ->
let%bind uncompiled_value = uncompile_value Expression program entry ex_ty_value in
ok (Success uncompiled_value)
let%bind decompiled_value = decompile_value Expression program entry ex_ty_value in
ok (Success decompiled_value)
let uncompile_typed_program_entry_function_result program entry runned_result =
let decompile_typed_program_entry_function_result program entry runned_result =
match runned_result with
| Fail s -> ok (Fail s)
| Success ex_ty_value ->
let%bind uncompiled_value = uncompile_value Function program entry ex_ty_value in
ok (Success uncompiled_value)
let%bind decompiled_value = decompile_value Function program entry ex_ty_value in
ok (Success decompiled_value)
let uncompile_expression type_value runned_result =
let decompile_expression type_value runned_result =
match runned_result with
| Fail s -> ok (Fail s)
| Success ex_ty_value ->
let%bind mini_c = trace uncompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
let%bind typed = trace uncompile_mini_c @@ Spilling.decompile mini_c type_value in
let%bind uncompiled_value = trace uncompile_typed @@ Typer.untype_expression typed in
ok (Success uncompiled_value)
let%bind mini_c = trace decompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
let%bind typed = trace decompile_mini_c @@ Spilling.decompile mini_c type_value in
let%bind decompiled_value = trace decompile_typed @@ Typer.untype_expression typed in
ok (Success decompiled_value)

10
src/main/decompile/of_sugar.ml Normal file
View File

@ -0,0 +1,10 @@
open Trace
open Ast_sugar
open Purification
open Main_errors
let decompile (program : program) : (Ast_imperative.program , _) result =
trace depurification_tracer @@ decompile_program program
let decompile_expression (e : expression) : (Ast_imperative.expression , _) result =
trace depurification_tracer @@ decompile_expression e

2
src/main/dune
View File

@ -4,7 +4,7 @@
(libraries
run
compile
uncompile
decompile
main_errors
)
(preprocess

4
src/main/main.ml
View File

@ -1,5 +1,5 @@
module Run = Run
module Compile = Compile
module Uncompile = Uncompile
module Compile = Compile
module Decompile = Decompile
module Display = Display
module Formatter = Main_errors.Formatter

18
src/main/main_errors/formatter.ml
View File

@ -121,9 +121,12 @@ let rec error_ppformat' : display_format:string display_format ->
| `Main_michelson_execution_error _ -> Format.fprintf f "@[<hv>Error of execution@]"
| `Main_parser e -> Parser.Errors.error_ppformat ~display_format f e
| `Main_pretty _e -> () (*no error in this pass*)
| `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_ppformat ~display_format f e
| `Main_purification e -> Purification.Errors.error_ppformat ~display_format f e
| `Main_depurification _e -> () (*no error in this pass*)
| `Main_desugaring _e -> () (*no error in this pass*)
| `Main_sugaring _e -> () (*no error in this pass*)
| `Main_cit_pascaligo e -> Tree_abstraction.Pascaligo.Errors.error_ppformat ~display_format f e
| `Main_cit_cameligo e -> Tree_abstraction.Cameligo.Errors.error_ppformat ~display_format f e
| `Main_typer e -> Typer.Errors.error_ppformat ~display_format f e
@ -133,9 +136,9 @@ let rec error_ppformat' : display_format:string display_format ->
| `Main_spilling e -> Spilling.Errors.error_ppformat ~display_format f e
| `Main_stacking e -> Stacking.Errors.error_ppformat ~display_format f e
| `Main_uncompile_michelson e -> Stacking.Errors.error_ppformat ~display_format f e
| `Main_uncompile_mini_c e -> Spilling.Errors.error_ppformat ~display_format f e
| `Main_uncompile_typed e -> Typer.Errors.error_ppformat ~display_format f e
| `Main_decompile_michelson e -> Stacking.Errors.error_ppformat ~display_format f e
| `Main_decompile_mini_c e -> Spilling.Errors.error_ppformat ~display_format f e
| `Main_decompile_typed e -> Typer.Errors.error_ppformat ~display_format f e
)
let error_ppformat : display_format:string display_format ->
@ -272,9 +275,12 @@ let rec error_jsonformat : Types.all -> J.t = fun a ->
| `Main_entrypoint_not_found -> json_error ~stage:"top-level glue" ~content:(`String "Missing entrypoint")
| `Main_parser e -> Parser.Errors.error_jsonformat e
| `Main_pretty _ -> `Null (*no error in this pass*)
| `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_jsonformat e
| `Main_purification e -> Purification.Errors.error_jsonformat e
| `Main_depurification _ -> `Null (*no error in this pass*)
| `Main_desugaring _ -> `Null (*no error in this pass*)
| `Main_sugaring _ -> `Null (*no error in this pass*)
| `Main_cit_pascaligo e -> Tree_abstraction.Pascaligo.Errors.error_jsonformat e
| `Main_cit_cameligo e -> Tree_abstraction.Cameligo.Errors.error_jsonformat e
| `Main_typer e -> Typer.Errors.error_jsonformat e
@ -284,9 +290,9 @@ let rec error_jsonformat : Types.all -> J.t = fun a ->
| `Main_self_mini_c e -> Self_mini_c.Errors.error_jsonformat e
| `Main_stacking e -> Stacking.Errors.error_jsonformat e
| `Main_uncompile_michelson e -> Stacking.Errors.error_jsonformat e
| `Main_uncompile_mini_c e -> Spilling.Errors.error_jsonformat e
| `Main_uncompile_typed e -> Typer.Errors.error_jsonformat e
| `Main_decompile_michelson e -> Stacking.Errors.error_jsonformat e
| `Main_decompile_mini_c e -> Spilling.Errors.error_jsonformat e
| `Main_decompile_typed e -> Typer.Errors.error_jsonformat e
let error_format : _ Display.format = {
pp = error_ppformat;

9
src/main/main_errors/main_errors.ml
View File

@ -5,11 +5,14 @@ type all = Types.all
(* passes tracers *)
let parser_tracer (e:Parser.Errors.parser_error) : all = `Main_parser e
let pretty_tracer (e:Parser.Errors.parser_error) : all = `Main_pretty e
let cit_cameligo_tracer (e:Tree_abstraction.Cameligo.Errors.abs_error) : all = `Main_cit_cameligo e
let cit_pascaligo_tracer (e:Tree_abstraction.Pascaligo.Errors.abs_error) : all = `Main_cit_pascaligo e
let self_ast_imperative_tracer (e:Self_ast_imperative.Errors.self_ast_imperative_error) : all = `Main_self_ast_imperative e
let purification_tracer (e:Purification.Errors.purification_error) : all = `Main_purification e
let depurification_tracer (e:Purification.Errors.purification_error) : all = `Main_depurification e
let desugaring_tracer (e:Desugaring.Errors.desugaring_error) : all = `Main_desugaring e
let sugaring_tracer (e:Desugaring.Errors.desugaring_error) : all = `Main_sugaring e
let typer_tracer (e:Typer.Errors.typer_error) : all = `Main_typer e
let self_ast_typed_tracer (e:Self_ast_typed.Errors.self_ast_typed_error) : all = `Main_self_ast_typed e
let self_mini_c_tracer (e:Self_mini_c.Errors.self_mini_c_error) : all = `Main_self_mini_c e
@ -17,9 +20,9 @@ let spilling_tracer (e:Spilling.Errors.spilling_error) : all = `Main_spilling e
let stacking_tracer (e:Stacking.Errors.stacking_error) : all = `Main_stacking e
let interpret_tracer (e:Interpreter.interpreter_error) : all = `Main_interpreter e
let uncompile_mini_c : Spilling.Errors.spilling_error -> all = fun e -> `Main_uncompile_mini_c e
let uncompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_uncompile_typed e
let uncompile_michelson : Stacking.Errors.stacking_error -> all = fun e -> `Main_uncompile_michelson e
let decompile_mini_c : Spilling.Errors.spilling_error -> all = fun e -> `Main_decompile_mini_c e
let decompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_decompile_typed e
let decompile_michelson : Stacking.Errors.stacking_error -> all = fun e -> `Main_decompile_michelson e
(* top-level glue (in between passes) *)

11
src/main/main_errors/types.ml
View File

@ -21,9 +21,12 @@ type all =
| `Main_michelson_execution_error of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_parser of Parser.Errors.parser_error
| `Main_pretty of Parser.Errors.parser_error
| `Main_self_ast_imperative of Self_ast_imperative.Errors.self_ast_imperative_error
| `Main_purification of Purification.Errors.purification_error
| `Main_purification of Purification.Errors.purification_error
| `Main_depurification of Purification.Errors.purification_error
| `Main_desugaring of Desugaring.Errors.desugaring_error
| `Main_sugaring of Desugaring.Errors.desugaring_error
| `Main_cit_pascaligo of Tree_abstraction.Pascaligo.Errors.abs_error
| `Main_cit_cameligo of Tree_abstraction.Cameligo.Errors.abs_error
| `Main_typer of Typer.Errors.typer_error
@ -33,9 +36,9 @@ type all =
| `Main_spilling of Spilling.Errors.spilling_error
| `Main_stacking of Stacking.Errors.stacking_error
| `Main_uncompile_michelson of Stacking.Errors.stacking_error
| `Main_uncompile_mini_c of Spilling.Errors.spilling_error
| `Main_uncompile_typed of Typer.Errors.typer_error
| `Main_decompile_michelson of Stacking.Errors.stacking_error
| `Main_decompile_mini_c of Spilling.Errors.spilling_error
| `Main_decompile_typed of Typer.Errors.typer_error
| `Main_entrypoint_not_a_function
| `Main_entrypoint_not_found
| `Main_invalid_amount of string

33
src/passes/01-parsing/cameligo.ml
View File

@ -145,15 +145,28 @@ let preprocess source = apply (fun () -> Unit.preprocess source)
(* Pretty-print a file (after parsing it). *)
let pretty_print source =
let pretty_print cst =
let doc = Pretty.print cst in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
let pretty_print_from_source source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
| Ok cst ->
pretty_print @@ fst cst
let pretty_print_expression cst =
let doc = Pretty.pp_expr cst in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer

7
src/passes/01-parsing/cameligo.mli
View File

@ -22,4 +22,9 @@ val parse_expression : string -> (CST.expr , Errors.parser_error) result
val preprocess : string -> (Buffer.t , Errors.parser_error) result
(** Pretty-print a given CameLIGO file (after parsing it). *)
val pretty_print : string -> (Buffer.t, Errors.parser_error) result
val pretty_print_from_source : string -> (Buffer.t, Errors.parser_error) result
(** Take a CameLIGO cst and pretty_print it *)
val pretty_print : CST.t -> (Buffer.t, _) result
val pretty_print_expression : CST.expr -> (Buffer.t, _) result

22
src/passes/01-parsing/cameligo/Parser.mly
View File

@ -93,7 +93,7 @@ tuple(item):
list__(item):
"[" sep_or_term_list(item,";")? "]" {
let compound = Brackets ($1,$3)
let compound = Some (Brackets ($1,$3))
and region = cover $1 $3 in
let elements, terminator =
match $2 with
@ -194,7 +194,7 @@ record_type:
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
and value = {compound = Braces ($1,$3); ne_elements; terminator}
and value = {compound = Some (Braces ($1,$3)); ne_elements; terminator}
in TRecord {region; value} }
field_decl:
@ -300,7 +300,7 @@ record_pattern:
"{" sep_or_term_list(field_pattern,";") "}" {
let ne_elements, terminator = $2 in
let region = cover $1 $3 in
let value = {compound = Braces ($1,$3); ne_elements; terminator}
let value = {compound = Some (Braces ($1,$3)); ne_elements; terminator}
in {region; value} }
field_pattern:
@ -377,22 +377,18 @@ if_then_else(right_expr):
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = $5;
ifnot = $6}
ifnot = Some($5,$6)}
in ECond {region; value} }
if_then(right_expr):
"if" expr "then" right_expr {
let the_unit = ghost, ghost in
let ifnot = EUnit (wrap_ghost the_unit) in
let stop = expr_to_region $4 in
let region = cover $1 stop in
let value = {kwd_if = $1;
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = ghost;
ifnot}
ifnot = None}
in ECond {region; value} }
base_if_then_else__open(x):
@ -630,7 +626,7 @@ record_expr:
"{" sep_or_term_list(field_assignment,";") "}" {
let ne_elements, terminator = $2 in
let region = cover $1 $3 in
let value = {compound = Braces ($1,$3);
let value = {compound = Some (Braces ($1,$3));
ne_elements;
terminator}
in {region; value} }
@ -643,7 +639,7 @@ update_record:
lbrace = $1;
record = $2;
kwd_with = $3;
updates = {value = {compound = Braces (ghost, ghost);
updates = {value = {compound = None;
ne_elements;
terminator};
region = cover $3 $5};
@ -671,7 +667,7 @@ path :
sequence:
"begin" series? "end" {
let region = cover $1 $3
and compound = BeginEnd ($1,$3) in
and compound = Some (BeginEnd ($1,$3)) in
let elements = $2 in
let value = {compound; elements; terminator=None}
in {region; value} }
@ -691,7 +687,7 @@ let_in_sequence:
let seq = $6 in
let stop = nsepseq_to_region expr_to_region seq in
let region = cover $1 stop in
let compound = BeginEnd (Region.ghost, Region.ghost) in
let compound = None in
let elements = Some seq in
let value = {compound; elements; terminator=None} in
let body = ESeq {region; value} in

33
src/passes/01-parsing/cameligo/Pretty.ml
View File

@ -173,13 +173,15 @@ and pp_clause {value; _} =
pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs)
and pp_cond_expr {value; _} =
let {test; ifso; kwd_else; ifnot; _} = value in
let {test; ifso; ifnot; _} = value in
let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
in if kwd_else#is_ghost
then test ^/^ ifso
else test ^/^ ifso ^/^ ifnot
in match ifnot with
Some (_,ifnot) ->
let ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) in
test ^/^ ifso ^/^ ifnot
| None ->
test ^/^ ifso
and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in
@ -243,18 +245,15 @@ and pp_injection :
let sep = string ";" ^^ break 1 in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep printer elements in
match pp_compound compound with
match Option.map pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 1 elements ^^ string closing
and pp_compound = function
BeginEnd (start, _) ->
if start#is_ghost then None else Some ("begin","end")
| Braces (start, _) ->
if start#is_ghost then None else Some ("{","}")
| Brackets (start, _) ->
if start#is_ghost then None else Some ("[","]")
BeginEnd (_, _) -> ("begin","end")
| Braces (_, _) -> ("{","}")
| Brackets (_, _) -> ("[","]")
and pp_constr_expr = function
ENone _ -> string "None"
@ -282,7 +281,7 @@ and pp_ne_injection :
fun printer {value; _} ->
let {compound; ne_elements; _} = value in
let elements = pp_nsepseq ";" printer ne_elements in
match pp_compound compound with
match Option.map pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 1 elements ^^ string closing
@ -356,8 +355,8 @@ and pp_let_in {value; _} =
| Some _ -> "let rec " in
let binding = pp_let_binding binding
and attr = pp_attributes attributes
in string let_str ^^ binding ^^ attr
^^ hardline ^^ group (string "in " ^^ nest 3 (pp_expr body))
in string let_str ^^ binding ^^ attr ^^ string " in"
^^ hardline ^^ group (pp_expr body)
and pp_fun {value; _} =
let {binders; lhs_type; body; _} = value in
@ -375,7 +374,7 @@ and pp_seq {value; _} =
let sep = string ";" ^^ hardline in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep pp_expr elements in
match pp_compound compound with
match Option.map pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening
@ -406,7 +405,7 @@ and pp_variants {value; _} =
let head = pp_variant head in
let head = if tail = [] then head else ifflat head (blank 2 ^^ head) in
let rest = List.map snd tail in
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
let app variant = group (break 1 ^^ string "| " ^^ pp_variant variant)
in head ^^ concat_map app rest
and pp_variant {value; _} =

21
src/passes/01-parsing/pascaligo.ml
View File

@ -5,6 +5,7 @@ module Scoping = Parser_pascaligo.Scoping
module Region = Simple_utils.Region
module ParErr = Parser_pascaligo.ParErr
module SSet = Set.Make (String)
module Pretty = Parser_pascaligo.Pretty
(* Mock IOs TODO: Fill them with CLI options *)
@ -153,3 +154,23 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
(* Preprocessing a contract in a file *)
let preprocess source = apply (fun () -> Unit.preprocess source)
let pretty_print cst =
let doc = Pretty.print cst in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
let pretty_print_expression cst =
let doc = Pretty.pp_expr cst in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer

5
src/passes/01-parsing/pascaligo.mli
View File

@ -21,3 +21,8 @@ val parse_expression : string -> (CST.expr, parser_error) result
(** Preprocess a given PascaLIGO file and preprocess it. *)
val preprocess : string -> (Buffer.t, parser_error) result
(** Take a PascaLIGO cst and pretty_print it *)
val pretty_print : CST.t -> (Buffer.t, _) result
val pretty_print_expression : CST.expr -> (Buffer.t, _) result

37
src/passes/01-parsing/pascaligo/Parser.mly
View File

@ -255,23 +255,6 @@ fun_expr:
open_fun_decl:
ioption ("recursive") "function" fun_name parameters type_expr_colon? "is"
block "with" expr {
Scoping.check_reserved_name $3;
let stop = expr_to_region $9 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
kwd_function = $2;
fun_name = $3;
param = $4;
ret_type = $5;
kwd_is = $6;
block_with = Some ($7, $8);
return = $9;
terminator = None;
attributes = None}
in {region; value}
}
| ioption ("recursive") "function" fun_name parameters type_expr_colon? "is"
expr {
Scoping.check_reserved_name $3;
let stop = expr_to_region $7 in
@ -282,11 +265,11 @@ open_fun_decl:
param = $4;
ret_type = $5;
kwd_is = $6;
block_with = None;
return = $7;
terminator = None;
attributes = None}
in {region; value} }
in {region; value}
}
fun_decl:
open_fun_decl ";"? {
@ -588,7 +571,7 @@ case_clause(rhs):
assignment:
lhs ":=" rhs {
let stop = rhs_to_region $3 in
let stop = expr_to_region $3 in
let region = cover (lhs_to_region $1) stop
and value = {lhs = $1; assign = $2; rhs = $3}
in {region; value} }
@ -665,6 +648,20 @@ expr:
| cond_expr { $1 }
| disj_expr { $1 }
| fun_expr { EFun $1 }
| block_with { EBlock $1 }
block_with :
block "with" expr {
let start = $2
and stop = expr_to_region $3 in
let region = cover start stop in
let value : CST.block_with = {
block = $1;
kwd_with = $2;
expr = $3;
}
in {value;region}
}
cond_expr:
"if" expr "then" expr ";"? "else" expr {

19
src/passes/01-parsing/pascaligo/Pretty.ml
View File

@ -81,7 +81,7 @@ and pp_variants {value; _} =
let head = if tail = [] then head
else ifflat head (string " " ^^ head) in
let rest = List.map snd tail in
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
let app variant = group (break 1 ^^ string "| " ^^ pp_variant variant)
in head ^^ concat_map app rest
and pp_variant {value; _} =
@ -136,7 +136,7 @@ and pp_fun_expr {value; _} =
and pp_fun_decl {value; _} =
let {kwd_recursive; fun_name; param;
ret_type; block_with; return; attributes; _} = value in
ret_type; return; attributes; _} = value in
let start =
match kwd_recursive with
None -> string "function"
@ -145,10 +145,9 @@ and pp_fun_decl {value; _} =
let parameters = pp_par pp_parameters param in
let expr = pp_expr return in
let body =
match block_with with
None -> group (nest 2 (break 1 ^^ expr))
| Some (b,_) -> hardline ^^ pp_block b ^^ string " with"
^^ group (nest 4 (break 1 ^^ expr))
match return with
EBlock _ -> group (break 1 ^^ expr)
| _ -> group (nest 2 (break 1 ^^ expr))
and attr =
match attributes with
None -> empty
@ -379,6 +378,14 @@ and pp_expr = function
| EPar e -> pp_par pp_expr e
| EFun e -> pp_fun_expr e
| ECodeInj e -> pp_code_inj e
| EBlock e -> pp_block_with e
and pp_block_with {value; _} =
let {block;kwd_with; expr;_} = value in
let expr = value.expr in
let expr = pp_expr expr in
group(pp_block block ^^ string " with"
^^ group (nest 4 (break 1 ^^ expr)))
and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in

24
src/passes/01-parsing/pascaligo/error.messages.checked-in
View File

@ -4147,30 +4147,6 @@ contract: Function With
<YOUR SYNTAX ERROR MESSAGE HERE>
contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is Begin Skip End While
##
## Ends in an error in state: 582.
##
## open_fun_decl -> Recursive Function Ident parameters COLON type_expr Is block . With expr [ Type SEMI Recursive RBRACE Function End EOF Const Attributes ]
##
## The known suffix of the stack is as follows:
## Recursive Function Ident parameters COLON type_expr Is block
##
<YOUR SYNTAX ERROR MESSAGE HERE>
contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is Begin Skip End With With
##
## Ends in an error in state: 583.
##
## open_fun_decl -> Recursive Function Ident parameters COLON type_expr Is block With . expr [ Type SEMI Recursive RBRACE Function End EOF Const Attributes ]
##
## The known suffix of the stack is as follows:
## Recursive Function Ident parameters COLON type_expr Is block With
##
<YOUR SYNTAX ERROR MESSAGE HERE>
contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is With
##
## Ends in an error in state: 89.

33
src/passes/01-parsing/reasonligo.ml
View File

@ -146,16 +146,29 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
let preprocess source = apply (fun () -> Unit.preprocess source)
(* Pretty-print a file (after parsing it). *)
let pretty_print cst =
let doc = Pretty.print cst in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
let pretty_print source =
let pretty_print_from_source source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
| Ok cst ->
pretty_print @@ fst cst
let pretty_print_expression cst =
let doc = Pretty.pp_expr cst in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer

9
src/passes/01-parsing/reasonligo.mli
View File

@ -21,5 +21,10 @@ val parse_expression : string -> (CST.expr , Errors.parser_error) result
(** Preprocess a given ReasonLIGO file and preprocess it. *)
val preprocess : string -> (Buffer.t , Errors.parser_error) result
(** Pretty-print a given CameLIGO file (after parsing it). *)
val pretty_print : string -> (Buffer.t , Errors.parser_error) result
(** Pretty-print a given ReasonLIGO file (after parsing it). *)
val pretty_print_from_source : string -> (Buffer.t , Errors.parser_error) result
(** Take a ReasonLIGO cst and pretty_print it *)
val pretty_print : CST.t -> (Buffer.t, _) result
val pretty_print_expression : CST.expr -> (Buffer.t, _) result

28
src/passes/01-parsing/reasonligo/Parser.mly
View File

@ -131,7 +131,7 @@ tuple(item):
list__(item):
"[" sep_or_term_list(item,";")? "]" {
let compound = Brackets ($1,$3)
let compound = Some (Brackets ($1,$3))
and region = cover $1 $3 in
let elements, terminator =
match $2 with
@ -224,7 +224,7 @@ record_type:
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
and value = {compound = Braces ($1,$3); ne_elements; terminator}
and value = {compound = Some(Braces ($1,$3)); ne_elements; terminator}
in TRecord {region; value} }
type_expr_field:
@ -362,7 +362,7 @@ record_pattern:
"{" sep_or_term_list(field_pattern,",") "}" {
let ne_elements, terminator = $2 in
let region = cover $1 $3 in
let value = {compound = Braces ($1,$3);
let value = {compound = Some (Braces ($1,$3));
ne_elements;
terminator}
in {region; value} }
@ -592,15 +592,12 @@ parenthesized_expr:
if_then(right_expr):
"if" parenthesized_expr "{" closed_if ";"? "}" {
let the_unit = ghost, ghost in
let ifnot = EUnit {region=ghost; value=the_unit} in
let region = cover $1 $6 in
let value = {kwd_if = $1;
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = ghost;
ifnot}
ifnot = None}
in ECond {region; value} }
if_then_else(right_expr):
@ -611,8 +608,7 @@ if_then_else(right_expr):
test = $2;
kwd_then = $3;
ifso = $4;
kwd_else = $6;
ifnot = $9}
ifnot = Some ($6,$9)}
in ECond {region; value} }
base_if_then_else__open(x):
@ -825,7 +821,7 @@ list_or_spread:
let elts, terminator = $4 in
let elts = Utils.nsepseq_cons $2 $3 elts in
let value = {
compound = Brackets ($1,$5);
compound = Some (Brackets ($1,$5));
elements = Some elts;
terminator}
and region = cover $1 $5 in
@ -837,7 +833,7 @@ list_or_spread:
in EList (ECons {region; value})
}
| "[" expr? "]" {
let compound = Brackets ($1,$3)
let compound = Some (Brackets ($1,$3))
and elements =
match $2 with
None -> None
@ -913,7 +909,7 @@ update_record:
lbrace = $1;
record = $3;
kwd_with = $4;
updates = {value = {compound = Braces (ghost, ghost);
updates = {value = {compound = None;
ne_elements;
terminator};
region = cover $4 $6};
@ -949,7 +945,7 @@ exprs:
in
let sequence = ESeq {
value = {
compound = BeginEnd (ghost, ghost);
compound = None;
elements = Some val_;
terminator = snd c};
region = sequence_region
@ -982,7 +978,7 @@ more_field_assignments:
sequence:
"{" exprs "}" {
let elts, _region = $2 in
let compound = Braces ($1, $3) in
let compound = Some (Braces ($1, $3)) in
let value = {compound;
elements = Some elts;
terminator = None} in
@ -991,7 +987,7 @@ sequence:
record:
"{" field_assignment more_field_assignments? "}" {
let compound = Braces ($1,$4) in
let compound = Some (Braces ($1,$4)) in
let region = cover $1 $4 in
match $3 with
@ -1010,7 +1006,7 @@ record:
let field_name = {$2 with value} in
let comma, elts = $3 in
let ne_elements = Utils.nsepseq_cons field_name comma elts in
let compound = Braces ($1,$4) in
let compound = Some (Braces ($1,$4)) in
let region = cover $1 $4 in
{value = {compound; ne_elements; terminator = None}; region} }

23
src/passes/01-parsing/reasonligo/Pretty.ml
View File

@ -179,13 +179,13 @@ and pp_clause {value; _} =
prefix 4 1 (pp_pattern pattern ^^ string " =>") (pp_expr rhs)
and pp_cond_expr {value; _} =
let {test; ifso; kwd_else; ifnot; _} = value in
let {test; ifso; ifnot; _} = value in
let if_then =
string "if" ^^ string " (" ^^ pp_expr test ^^ string ")" ^^ string " {" ^^ break 0
^^ group (nest 2 (break 2 ^^ pp_expr ifso)) ^^ hardline ^^ string "}" in
if kwd_else#is_ghost then
if_then
else
match ifnot with
None -> if_then
| Some (_,ifnot) ->
if_then
^^ string " else" ^^ string " {" ^^ break 0 ^^ group (nest 2 (break 2 ^^ pp_expr ifnot)) ^^ hardline ^^ string "}"
@ -252,18 +252,15 @@ and pp_injection :
let sep = (string ",") ^^ break 1 in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep printer elements in
match pp_compound compound with
match Option.map pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 1 elements ^^ string closing
and pp_compound = function
BeginEnd (start, _) ->
if start#is_ghost then None else Some ("begin","end")
| Braces (start, _) ->
if start#is_ghost then None else Some ("{","}")
| Brackets (start, _) ->
if start#is_ghost then None else Some ("[","]")
BeginEnd (_, _) -> ("begin","end")
| Braces (_, _) -> ("{","}")
| Brackets (_, _) -> ("[","]")
and pp_constr_expr = function
ENone _ -> string "None"
@ -291,7 +288,7 @@ and pp_ne_injection :
fun printer {value; _} ->
let {compound; ne_elements; _} = value in
let elements = pp_nsepseq "," printer ne_elements in
match pp_compound compound with
match Option.map pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 2 (break 0 ^^ elements) ^^ break 1 ^^ string closing
@ -387,7 +384,7 @@ and pp_seq {value; _} =
let sep = string ";" ^^ hardline in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep pp_expr elements in
match pp_compound compound with
match Option.map pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening

6
src/passes/03-tree_abstraction/cameligo/cameligo.ml
View File

@ -1,8 +1,12 @@
module CST = Cst.Cameligo
module AST = Ast_imperative
module Compiler = Compiler
module Compiler = Compiler
module Decompiler = Decompiler
module Errors = Errors
let compile_program = Compiler.compile_program
let compile_expression = Compiler.compile_expression
let decompile_program = Decompiler.decompile_program
let decompile_expression = Decompiler.decompile_expression

4
src/passes/03-tree_abstraction/cameligo/cameligo.mli
View File

@ -8,5 +8,7 @@ module Errors = Errors
val compile_expression : CST.expr -> (AST.expr, Errors.abs_error) result
val compile_program : CST.ast -> (AST.program, Errors.abs_error) result
val decompile_expression : AST.expr -> (CST.expr, _) result
val decompile_program : AST.program -> (CST.ast, _) result

8
src/passes/03-tree_abstraction/cameligo/compiler.ml
View File

@ -11,6 +11,7 @@ module Option = Simple_utils.Option
open Combinators
let (<@) f g x = f (g x)
let nseq_to_list (hd, tl) = hd :: tl
let npseq_to_list (hd, tl) = hd :: (List.map snd tl)
let npseq_to_nelist (hd, tl) = hd, (List.map snd tl)
@ -247,7 +248,7 @@ in trace (abstracting_expr_tracer t) @@
let%bind ty_opt =
bind_map_option (fun (re,te) -> let%bind te = compile_type_expression te in ok(Location.lift re,te)) lhs_type in
let%bind rhs = compile_expression let_rhs in
let rhs_b = Var.fresh ~name: "rhs" () in
let rhs_b = Var.fresh ~name:"rhs" () in
let rhs',rhs_b_expr =
match ty_opt with
None -> rhs, e_variable ~loc rhs_b
@ -491,7 +492,8 @@ in trace (abstracting_expr_tracer t) @@
let (c , loc) = r_split c in
let%bind expr = compile_expression c.test in
let%bind match_true = compile_expression c.ifso in
let%bind match_false = compile_expression c.ifnot in
let%bind match_false = bind_map_option (compile_expression <@ snd) c.ifnot in
let match_false = Option.unopt ~default:(e_unit ()) match_false in
return @@ e_cond ~loc expr match_true match_false
| ECodeInj ci ->
let ci, loc = r_split ci in
@ -541,7 +543,7 @@ and compile_fun lamb' : (expr , abs_error) result =
let aux ((var : Raw.variable) , ty_opt) =
match var.value , ty_opt with
| "storage" , None ->
ok (var , t_variable ~loc @@ Var.fresh ~name:"storage" ())
ok (var , t_variable_ez ~loc "storage")
| _ , None ->
fail @@ untyped_fun_param var
| _ , Some ty -> (

504
src/passes/03-tree_abstraction/cameligo/decompiler.ml Normal file
View File

@ -0,0 +1,504 @@
module AST = Ast_imperative
module CST = Cst.Cameligo
module Predefined = Predefined.Tree_abstraction.Cameligo
open Trace
(* General tools *)
let (<@) f g x = f (g x)
(* Utils *)
let rg = Region.ghost
let wrap : type a. a -> a CST.reg = fun value -> {value;region=rg}
let list_to_sepseq lst =
match lst with
[] -> None
| hd :: lst ->
let aux e = (rg, e) in
Some (hd, List.map aux lst)
let list_to_nsepseq lst =
match list_to_sepseq lst with
Some s -> ok @@ s
| None -> failwith "List is empty"
let nelist_to_npseq (hd, lst) = (hd, List.map (fun e -> (rg, e)) lst)
let npseq_cons hd lst = hd,(rg, fst lst)::(snd lst)
let par a = CST.{lpar=rg;inside=a;rpar=rg}
let inject compound a = CST.{compound;elements=a;terminator=Some(rg)}
let ne_inject compound a = CST.{compound;ne_elements=a;terminator=Some(rg)}
let prefix_colon a = (rg, a)
let braces = Some (CST.Braces (rg,rg))
let brackets = Some (CST.Brackets (rg,rg))
let beginEnd = Some (CST.BeginEnd (rg,rg))
(* Decompiler *)
let decompile_variable : type a. a Var.t -> CST.variable = fun var ->
let var = Format.asprintf "%a" Var.pp var in
if String.contains var '#' then
let var = String.split_on_char '#' var in
wrap @@ "gen__" ^ (String.concat "" var)
else
if String.length var > 4 && String.equal "gen__" @@ String.sub var 0 5 then
wrap @@ "user__" ^ var
else
wrap @@ var
let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
let return te = ok @@ te in
match te.type_content with
T_sum sum ->
let sum = AST.CMap.to_kv_list sum in
let aux (AST.Constructor c, AST.{ctor_type;_}) =
let constr = wrap c in
let%bind arg = decompile_type_expr ctor_type in
let arg = Some (rg, arg) in
let variant : CST.variant = {constr;arg} in
ok @@ wrap variant
in
let%bind sum = bind_map_list aux sum in
let%bind sum = list_to_nsepseq sum in
return @@ CST.TSum (wrap sum)
| T_record record ->
let record = AST.LMap.to_kv_list record in
let aux (AST.Label c, AST.{field_type;_}) =
let field_name = wrap c in
let colon = rg in
let%bind field_type = decompile_type_expr field_type in
let variant : CST.field_decl = {field_name;colon;field_type} in
ok @@ wrap variant
in
let%bind record = bind_map_list aux record in
let%bind record = list_to_nsepseq record in
return @@ CST.TRecord (wrap @@ ne_inject (braces) record)
| T_tuple tuple ->
let%bind tuple = bind_map_list decompile_type_expr tuple in
let%bind tuple = list_to_nsepseq @@ tuple in
return @@ CST.TProd (wrap tuple)
| T_arrow {type1;type2} ->
let%bind type1 = decompile_type_expr type1 in
let%bind type2 = decompile_type_expr type2 in
let arrow = (type1, rg, type2) in
return @@ CST.TFun (wrap arrow)
| T_variable var ->
let var = decompile_variable var in
return @@ CST.TVar (var)
| T_constant const ->
let const = Predefined.type_constant_to_string const in
return @@ CST.TVar (wrap const)
| T_operator (operator, lst) ->
let operator = wrap @@ Predefined.type_operator_to_string operator in
let%bind lst = bind_map_list decompile_type_expr lst in
let%bind lst = list_to_nsepseq lst in
let lst : _ CST.par = {lpar=rg;inside=lst;rpar=rg} in
return @@ CST.TApp (wrap (operator,wrap lst))
| T_annoted _annot ->
failwith "let's work on it later"
let get_e_variable : AST.expression -> _ result = fun expr ->
match expr.expression_content with
E_variable var -> ok @@ var
| _ -> failwith @@
Format.asprintf "%a should be a variable expression"
AST.PP.expression expr
let get_e_tuple : AST.expression -> _ result = fun expr ->
match expr.expression_content with
E_tuple tuple -> ok @@ tuple
| E_variable _
| E_literal _
| E_constant _
| E_lambda _ -> ok @@ [expr]
| _ -> failwith @@
Format.asprintf "%a should be a tuple expression"
AST.PP.expression expr
let pattern_type var ty_opt =
let var = CST.PVar (decompile_variable var) in
match ty_opt with
Some s ->
let%bind type_expr = decompile_type_expr s in
ok @@ CST.PTyped (wrap @@ CST.{pattern=var;colon=rg;type_expr})
| None -> ok @@ var
let rec decompile_expression : AST.expression -> _ result = fun expr ->
let return_expr expr = ok @@ expr in
let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in
match expr.expression_content with
E_variable name ->
let var = decompile_variable name in
return_expr @@ CST.EVar (var)
| E_constant {cons_name; arguments} ->
let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in
(match arguments with
[] -> return_expr @@ expr
| _ ->
let%bind arguments = map List.Ne.of_list @@
map (List.map (fun x -> CST.EPar (wrap @@ par @@ x))) @@
bind_map_list decompile_expression arguments in
let const = wrap (expr, arguments) in
return_expr_with_par @@ CST.ECall const
)
| E_literal literal ->
(match literal with
Literal_unit -> return_expr @@ CST.EUnit (wrap (rg,rg))
| Literal_int i -> return_expr @@ CST.EArith (Int (wrap ("",i)))
| Literal_nat n -> return_expr @@ CST.EArith (Nat (wrap ("",n)))
| Literal_timestamp time ->
let time = Tezos_utils.Time.Protocol.to_notation @@
Tezos_utils.Time.Protocol.of_seconds @@ Z.to_int64 time in
(* TODO combinators for CSTs. *)
let%bind ty = decompile_type_expr @@ AST.t_timestamp () in
let time = CST.EString (String (wrap time)) in
return_expr @@ CST.EAnnot (wrap @@ par (time, rg, ty))
| Literal_mutez mtez -> return_expr @@ CST.EArith (Mutez (wrap ("",mtez)))
| Literal_string (Standard str) -> return_expr @@ CST.EString (String (wrap str))
| Literal_string (Verbatim ver) -> return_expr @@ CST.EString (Verbatim (wrap ver))
| Literal_bytes b ->
let b = Hex.of_bytes b in
let s = Hex.to_string b in
return_expr @@ CST.EBytes (wrap (s,b))
| Literal_address addr ->
let addr = CST.EString (String (wrap addr)) in
let%bind ty = decompile_type_expr @@ AST.t_address () in
return_expr @@ CST.EAnnot (wrap @@ par (addr,rg,ty))
| Literal_signature sign ->
let sign = CST.EString (String (wrap sign)) in
let%bind ty = decompile_type_expr @@ AST.t_signature () in
return_expr @@ CST.EAnnot (wrap @@ par (sign,rg,ty))
| Literal_key k ->
let k = CST.EString (String (wrap k)) in
let%bind ty = decompile_type_expr @@ AST.t_key () in
return_expr @@ CST.EAnnot (wrap @@ par (k,rg,ty))
| Literal_key_hash kh ->
let kh = CST.EString (String (wrap kh)) in
let%bind ty = decompile_type_expr @@ AST.t_key_hash () in
return_expr @@ CST.EAnnot (wrap @@ par (kh,rg,ty))
| Literal_chain_id _
| Literal_void
| Literal_operation _ ->
failwith "chain_id, void, operation are not created currently ?"
)
| E_application {lamb;args} ->
let%bind lamb = decompile_expression lamb in
let%bind args = map List.Ne.of_list @@
bind (bind_map_list decompile_expression) @@
get_e_tuple args
in
return_expr @@ CST.ECall (wrap (lamb,args))
| E_lambda lambda ->
let%bind (binders,_lhs_type,_block_with,body) = decompile_lambda lambda in
let fun_expr : CST.fun_expr = {kwd_fun=rg;binders;lhs_type=None;arrow=rg;body} in
return_expr_with_par @@ CST.EFun (wrap @@ fun_expr)
| E_recursive _ ->
failwith "corner case : annonymous recursive function"
| E_let_in {let_binder;rhs;let_result;inline} ->
let var = CST.PVar (decompile_variable @@ fst let_binder) in
let binders = (var,[]) in
let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) @@ snd let_binder in
let%bind let_rhs = decompile_expression rhs in
let binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
let%bind body = decompile_expression let_result in
let attributes = decompile_attributes inline in
let lin : CST.let_in = {kwd_let=rg;kwd_rec=None;binding;kwd_in=rg;body;attributes} in
return_expr @@ CST.ELetIn (wrap lin)
| E_raw_code {language; code} ->
let language = wrap @@ wrap @@ language in
let%bind code = decompile_expression code in
let ci : CST.code_inj = {language;code;rbracket=rg} in
return_expr @@ CST.ECodeInj (wrap ci)
| E_constructor {constructor;element} ->
let Constructor constr = constructor in
let constr = wrap constr in
let%bind element = decompile_expression element in
return_expr_with_par @@ CST.EConstr (EConstrApp (wrap (constr, Some element)))
| E_matching {matchee; cases} ->
let%bind expr = decompile_expression matchee in
let%bind cases = decompile_matching_cases cases in
let cases : _ CST.case = {kwd_match=rg;expr;kwd_with=rg;lead_vbar=None;cases} in
return_expr @@ CST.ECase (wrap cases)
| E_record record ->
let record = AST.LMap.to_kv_list record in
let aux (AST.Label str, expr) =
let field_name = wrap str in
let%bind field_expr = decompile_expression expr in
let field : CST.field_assign = {field_name;assignment=rg;field_expr} in
ok @@ wrap field
in
let%bind record = bind_map_list aux record in
let%bind record = list_to_nsepseq record in
let record = ne_inject braces record in
(* why is the record not empty ? *)
return_expr @@ CST.ERecord (wrap record)
| E_accessor {record; path} ->
(match List.rev path with
Access_map e :: [] ->
let%bind map = decompile_expression record in
let%bind e = decompile_expression e in
let arg = e,[map] in
return_expr @@ CST.ECall( wrap (CST.EVar (wrap "Map.find_opt"), arg))
| Access_map e :: lst ->
let path = List.rev lst in
let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
let proj : CST.projection = {struct_name;selector=rg;field_path} in
let%bind e = decompile_expression e in
let arg = e,[CST.EProj (wrap proj)] in
return_expr @@ CST.ECall( wrap (CST.EVar (wrap "Map.find_opt"), arg))
| _ ->
let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
let proj : CST.projection = {struct_name;selector=rg;field_path} in
return_expr @@ CST.EProj (wrap proj)
)
(* Update on multiple field of the same record. may be removed by adding sugar *)
| E_update {record={expression_content=E_update _;_} as record;path;update} ->
let%bind record = decompile_expression record in
let%bind (record,updates) = match record with
CST.EUpdate {value;_} -> ok @@ (value.record,value.updates)
| _ -> failwith @@ Format.asprintf "Inpossible case %a" AST.PP.expression expr
in
let%bind var,path = match path with
Access_record var::path -> ok @@ (var,path)
| _ -> failwith "Impossible case %a"
in
let%bind field_path = decompile_to_path (Var.of_name var) path in
let%bind field_expr = decompile_expression update in
let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = updates.value.ne_elements in
let updates = wrap @@ ne_inject braces @@ npseq_cons (wrap @@ field_assign) updates in
let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
return_expr @@ CST.EUpdate (wrap @@ update)
| E_update {record; path; update} ->
let%bind record = map (decompile_variable) @@ get_e_variable record in
let%bind field_expr = decompile_expression update in
let (struct_name,field_path) = List.Ne.of_list path in
(match field_path with
[] ->
(match struct_name with
Access_record name ->
let record : CST.path = Name record in
let field_path = CST.Name (wrap name) in
let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in
let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
return_expr @@ CST.EUpdate (wrap update)
| Access_tuple i ->
let record : CST.path = Name record in
let field_path = CST.Name (wrap @@ Z.to_string i) in
let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in
let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
return_expr @@ CST.EUpdate (wrap update)
| Access_map e ->
let%bind e = decompile_expression e in
let arg = field_expr,[e; CST.EVar record] in
return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"), arg))
)
| _ ->
let%bind struct_name = match struct_name with
Access_record name -> ok @@ wrap name
| Access_tuple i -> ok @@ wrap @@ Z.to_string i
| Access_map _ -> failwith @@ Format.asprintf "invalid map update %a" AST.PP.expression expr
in
(match List.rev field_path with
Access_map e :: lst ->
let field_path = List.rev lst in
let%bind field_path = bind_map_list decompile_to_selection field_path in
let%bind field_path = list_to_nsepseq field_path in
let field_path : CST.projection = {struct_name; selector=rg;field_path} in
let field_path = CST.EProj (wrap @@ field_path) in
let%bind e = decompile_expression e in
let arg = field_expr, [e; field_path] in
return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"),arg))
| _ ->
let%bind field_path = bind_map_list decompile_to_selection field_path in
let%bind field_path = list_to_nsepseq field_path in
let field_path : CST.projection = {struct_name; selector=rg;field_path} in
let field_path = CST.Path (wrap @@ field_path) in
let record : CST.path = Name record in
let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in
let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
return_expr @@ CST.EUpdate (wrap update)
)
)
| E_ascription {anno_expr;type_annotation} ->
let%bind expr = decompile_expression anno_expr in
let%bind ty = decompile_type_expr type_annotation in
return_expr @@ CST.EAnnot (wrap @@ par (expr,rg,ty))
| E_cond {condition;then_clause;else_clause} ->
let%bind test = decompile_expression condition in
let%bind ifso = decompile_expression then_clause in
let%bind ifnot = decompile_expression else_clause in
let ifnot = Some(rg,ifnot) in
let cond : CST.cond_expr = {kwd_if=rg;test;kwd_then=rg;ifso;ifnot} in
return_expr @@ CST.ECond (wrap cond)
| E_sequence {expr1;expr2} ->
let%bind expr1 = decompile_expression expr1 in
let%bind expr2 = decompile_expression expr2 in
return_expr @@ CST.ESeq (wrap @@ inject beginEnd @@ list_to_sepseq [expr1; expr2])
| E_tuple tuple ->
let%bind tuple = bind_map_list decompile_expression tuple in
let%bind tuple = list_to_nsepseq tuple in
return_expr @@ CST.ETuple (wrap @@ tuple)
| E_map map ->
let%bind map = bind_map_list (bind_map_pair decompile_expression) map in
let aux (k,v) = CST.ETuple (wrap (k,[(rg,v)])) in
let map = List.map aux map in
(match map with
[] -> return_expr @@ CST.EVar (wrap "Big_map.empty")
| _ ->
let var = CST.EVar (wrap "Map.literal") in
return_expr @@ CST.ECall (wrap @@ (var, List.Ne.of_list @@ map))
)
| E_big_map big_map ->
let%bind big_map = bind_map_list (bind_map_pair decompile_expression) big_map in
let aux (k,v) = CST.ETuple (wrap (k,[(rg,v)])) in
let big_map = List.map aux big_map in
(match big_map with
[] -> return_expr @@ CST.EVar (wrap "Big_map.empty")
| _ ->
let var = CST.EVar (wrap "Big_map.literal") in
return_expr @@ CST.ECall (wrap @@ (var, List.Ne.of_list @@ big_map))
)
| E_list lst ->
let%bind lst = bind_map_list decompile_expression lst in
let lst = list_to_sepseq lst in
return_expr @@ CST.EList (EListComp (wrap @@ inject brackets @@ lst))
| E_set set ->
let%bind set = bind_map_list decompile_expression set in
let set = List.Ne.of_list @@ set in
let var = CST.EVar (wrap "Set.literal") in
return_expr @@ CST.ECall (wrap @@ (var,set))
(* We should avoid to generate skip instruction*)
| E_skip -> return_expr @@ CST.EUnit (wrap (rg,rg))
| E_assign _
| E_for _
| E_for_each _
| E_while _ ->
failwith @@ Format.asprintf "Decompiling a imperative construct to CameLIGO %a"
AST.PP.expression expr
and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access ->
let struct_name = decompile_variable var in
match access with
[] -> ok @@ CST.Name struct_name
| lst ->
let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection lst in
let path : CST.projection = {struct_name;selector=rg;field_path} in
ok @@ (CST.Path (wrap @@ path) : CST.path)
and decompile_to_selection : AST.access -> (CST.selection, _) result = fun access ->
match access with
Access_tuple index -> ok @@ CST.Component (wrap @@ ("",index))
| Access_record str -> ok @@ CST.FieldName (wrap str)
| Access_map _ ->
failwith @@ Format.asprintf
"Can't decompile access_map to selection"
and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} ->
let%bind param_decl = pattern_type binder input_type in
let param = (param_decl, []) in
let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in
let%bind return = decompile_expression result in
ok @@ (param,ret_type,None,return)
and decompile_attributes = function
true -> [wrap "inline"]
| false -> []
and decompile_matching_cases : AST.matching_expr -> ((CST.expr CST.case_clause Region.reg, Region.t) Parser_shared.Utils.nsepseq Region.reg,_) result =
fun m ->
let%bind cases = match m with
Match_variable (var, ty_opt, expr) ->
let%bind pattern = pattern_type var ty_opt in
let%bind rhs = decompile_expression expr in
let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
ok @@ [wrap case]
| Match_tuple (lst, ty_opt, expr) ->
let%bind tuple = match ty_opt with
Some ty_lst ->
let aux (var, ty) =
let pattern = CST.PVar (decompile_variable var) in
let%bind type_expr = decompile_type_expr ty in
ok @@ CST.PTyped (wrap @@ CST.{pattern;colon=rg;type_expr})
in
bind list_to_nsepseq @@ bind_map_list aux @@ List.combine lst ty_lst
| None ->
let aux var = CST.PVar (decompile_variable var) in
list_to_nsepseq @@ List.map aux lst
in
let pattern : CST.pattern = PTuple (wrap @@ tuple) in
let%bind rhs = decompile_expression expr in
let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
ok @@ [wrap case]
| Match_record _ -> failwith "match_record not availiable yet"
| Match_option {match_none;match_some}->
let%bind rhs = decompile_expression match_none in
let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in
let%bind rhs = decompile_expression @@ snd match_some in
let var = CST.PVar (decompile_variable @@ fst match_some)in
let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in
ok @@ [wrap some_case;wrap none_case]
| Match_list {match_nil; match_cons} ->
let (hd,tl,expr) = match_cons in
let hd = CST.PVar (decompile_variable hd) in
let tl = CST.PVar (decompile_variable tl) in
let cons = (hd,rg,tl) in
let%bind rhs = decompile_expression @@ expr in
let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in
let%bind rhs = decompile_expression @@ match_nil in
let nil_case : _ CST.case_clause = {pattern=PList (PListComp (wrap @@ inject brackets None));arrow=rg; rhs} in
ok @@ [wrap cons_case; wrap nil_case]
| Match_variant lst ->
let aux ((c,v),e) =
let AST.Constructor c = c in
let constr = wrap @@ c in
let var : CST.pattern = PVar (decompile_variable v) in
let tuple = var in
let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in
let%bind rhs = decompile_expression e in
let case : _ CST.case_clause = {pattern;arrow=rg;rhs} in
ok @@ wrap case
in
bind_map_list aux lst
in
map wrap @@ list_to_nsepseq cases
let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _) result = fun decl ->
let decl = Location.unwrap decl in
let wrap value = ({value;region=Region.ghost} : _ Region.reg) in
match decl with
Declaration_type (name, te) ->
let name = decompile_variable name in
let%bind type_expr = decompile_type_expr te in
ok @@ CST.TypeDecl (wrap (CST.{kwd_type=rg; name; eq=rg; type_expr}))
| Declaration_constant (var, ty_opt, inline, expr) ->
let attributes : CST.attributes = decompile_attributes inline in
let var = CST.PVar (decompile_variable var) in
let binders = (var,[]) in
match expr.expression_content with
E_lambda lambda ->
let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
let%bind let_rhs = decompile_expression @@ AST.make_e @@ AST.E_lambda lambda in
let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
let let_decl : CST.let_decl = wrap (rg,None,let_binding,attributes) in
ok @@ CST.Let let_decl
| E_recursive {lambda; _} ->
let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
let%bind let_rhs = decompile_expression @@ AST.make_e @@ AST.E_lambda lambda in
let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
let let_decl : CST.let_decl = wrap (rg,Some rg,let_binding,attributes) in
ok @@ CST.Let (let_decl)
| _ ->
let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
let%bind let_rhs = decompile_expression expr in
let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
let let_decl : CST.let_decl = wrap (rg,None,let_binding,attributes) in
ok @@ CST.Let let_decl
let decompile_program : AST.program -> (CST.ast, _) result = fun prg ->
let%bind decl = bind_map_list decompile_declaration prg in
let decl = List.Ne.of_list decl in
ok @@ ({decl;eof=rg}: CST.ast)

32
src/passes/03-tree_abstraction/pascaligo/compiler.ml
View File

@ -418,6 +418,11 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
let (language, _) = r_split language in
let%bind code = compile_expression ci.code in
return @@ e_raw_code ~loc language code
| EBlock be ->
let be, _ = r_split be in
let%bind next = compile_expression be.expr in
compile_block ~next be.block
and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ =
fun compiler cases ->
@ -497,11 +502,11 @@ fun compiler cases ->
return @@ AST.Match_variant (List.combine constrs lst)
| (p, _), _ -> fail @@ unsupported_pattern_type p
let compile_attribute_declaration = function
and compile_attribute_declaration = function
None -> return false
| Some _ -> return true
let compile_parameters (params : CST.parameters) =
and compile_parameters (params : CST.parameters) =
let compile_param_decl (param : CST.param_decl) =
match param with
ParamConst pc ->
@ -519,10 +524,10 @@ let compile_parameters (params : CST.parameters) =
let params = npseq_to_list params.inside in
bind_map_list compile_param_decl params
let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction ->
let return expr = match next with
Some e -> return @@ e_sequence expr e
| None -> return expr
and compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction ->
let return expr = match next with
Some e -> ok @@ e_sequence expr e
| None -> ok @@ expr
in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in
@ -534,7 +539,7 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause ->
match if_clause with
ClauseInstr i -> compile_instruction ?next i
| ClauseBlock (LongBlock block) -> compile_block ?next block
| ClauseBlock (LongBlock block) -> compile_block ?next block
| ClauseBlock (ShortBlock block) ->
(* This looks like it should be the job of the parser *)
let CST.{lbrace; inside; rbrace} = block.value in
@ -734,16 +739,13 @@ and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun
Some block -> return block
| None -> fail @@ block_start_with_attribute block
and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) =
and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attributes}: CST.fun_decl) =
let%bind attr = compile_attribute_declaration attributes in
let (fun_name, loc) = r_split fun_name in
let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in
let%bind param = compile_parameters param in
let%bind r = compile_expression r in
let%bind result = compile_expression r in
let (param, param_type) = List.split param in
let%bind body = Option.unopt ~default:(return r) @@
Option.map (compile_block ~next:r <@ fst) block_with
in
(* This handle the parameter case *)
let (lambda,fun_type) = (match param_type with
ty::[] ->
@ -751,18 +753,18 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
binder = (Var.of_name @@ List.hd param);
input_type = ty ;
output_type = ret_type ;
result = body;
result;
} in
lambda,Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type)
| lst ->
let lst = Option.bind_list lst in
let input_type = Option.map t_tuple lst in
let binder = Var.fresh ~name:"parameter" () in
let binder = Var.fresh ~name:"parameters" () in
let lambda : AST.lambda = {
binder;
input_type = input_type;
output_type = ret_type;
result = e_matching_tuple_ez (e_variable binder) param lst body;
result = e_matching_tuple_ez (e_variable binder) param lst result;
} in
lambda,Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type)
)

660
src/passes/03-tree_abstraction/pascaligo/decompiler.ml Normal file
View File

@ -0,0 +1,660 @@
module AST = Ast_imperative
module CST = Cst.Pascaligo
module Predefined = Predefined.Tree_abstraction.Pascaligo
open Trace
(* General tools *)
let (<@) f g x = f (g x)
(* Utils *)
let rg = Region.ghost
let wrap : type a. a -> a CST.reg = fun value -> {value;region=rg}
let list_to_sepseq lst =
match lst with
[] -> None
| hd :: lst ->
let aux e = (rg, e) in
Some (hd, List.map aux lst)
let list_to_nsepseq lst =
match list_to_sepseq lst with
Some s -> ok @@ s
| None -> failwith "List is not a non_empty list"
let nelist_to_npseq (hd, lst) = (hd, List.map (fun e -> (rg, e)) lst)
let npseq_cons hd lst = hd,(rg, fst lst)::(snd lst)
let par a = CST.{lpar=rg;inside=a;rpar=rg}
let braces a = CST.{lbrace=rg;inside=a;rbrace=rg}
let brackets a = CST.{lbracket=rg;inside=a;rbracket=rg}
let inject kind a = CST.{kind;enclosing=Brackets (rg,rg);elements=a;terminator=Some(rg)}
let ne_inject kind a = CST.{kind;enclosing=Brackets (rg,rg);ne_elements=a;terminator=Some(rg)}
let prefix_colon a = (rg, a)
let suffix_with a = (a, rg)
let to_block a = CST.{enclosing=Block (rg,rg,rg);statements=a;terminator=Some rg}
let empty_block = to_block (CST.Instr (CST.Skip rg),[])
(* Decompiler *)
let decompile_variable : type a. a Var.t -> CST.variable = fun var ->
let var = Format.asprintf "%a" Var.pp var in
if String.contains var '#' then
let var = String.split_on_char '#' var in
wrap @@ "gen__" ^ (String.concat "" var)
else
if String.length var > 4 && String.equal "gen__" @@ String.sub var 0 5 then
wrap @@ "user__" ^ var
else
wrap @@ var
let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
let return te = ok @@ te in
match te.type_content with
T_sum sum ->
let sum = AST.CMap.to_kv_list sum in
let aux (AST.Constructor c, AST.{ctor_type;_}) =
let constr = wrap c in
let%bind arg = decompile_type_expr ctor_type in
let arg = Some (rg, arg) in
let variant : CST.variant = {constr;arg} in
ok @@ wrap variant
in
let%bind sum = bind_map_list aux sum in
let%bind sum = list_to_nsepseq sum in
return @@ CST.TSum (wrap sum)
| T_record record ->
let record = AST.LMap.to_kv_list record in
let aux (AST.Label c, AST.{field_type;_}) =
let field_name = wrap c in
let colon = rg in
let%bind field_type = decompile_type_expr field_type in
let variant : CST.field_decl = {field_name;colon;field_type} in
ok @@ wrap variant
in
let%bind record = bind_map_list aux record in
let%bind record = list_to_nsepseq record in
return @@ CST.TRecord (wrap @@ ne_inject (NEInjRecord rg) record)
| T_tuple tuple ->
let%bind tuple = bind_map_list decompile_type_expr tuple in
let%bind tuple = list_to_nsepseq @@ tuple in
return @@ CST.TProd (wrap tuple)
| T_arrow {type1;type2} ->
let%bind type1 = decompile_type_expr type1 in
let%bind type2 = decompile_type_expr type2 in
let arrow = (type1, rg, type2) in
return @@ CST.TFun (wrap arrow)
| T_variable var ->
let var = decompile_variable var in
return @@ CST.TVar (var)
| T_constant const ->
let const = Predefined.type_constant_to_string const in
return @@ CST.TVar (wrap const)
| T_operator (operator, lst) ->
let operator = wrap @@ Predefined.type_operator_to_string operator in
let%bind lst = bind_map_list decompile_type_expr lst in
let%bind lst = list_to_nsepseq lst in
let lst : _ CST.par = {lpar=rg;inside=lst;rpar=rg} in
return @@ CST.TApp (wrap (operator,wrap lst))
| T_annoted _annot ->
failwith "let's work on it later"
let get_e_variable : AST.expression -> _ result = fun expr ->
match expr.expression_content with
E_variable var -> ok @@ var
| _ -> failwith @@
Format.asprintf "%a should be a variable expression"
AST.PP.expression expr
let rec get_e_accessor : AST.expression -> _ result = fun expr ->
match expr.expression_content with
E_variable var -> ok @@ (var, [])
| E_accessor {record;path} ->
let%bind (var, lst) = get_e_accessor record in
ok @@ (var, lst @ path)
| _ -> failwith @@
Format.asprintf "%a should be a variable expression"
AST.PP.expression expr
let get_e_tuple : AST.expression -> _ result = fun expr ->
match expr.expression_content with
E_tuple tuple -> ok @@ tuple
| E_variable _
| E_literal _
| E_constant _
| E_lambda _ -> ok @@ [expr]
| _ -> failwith @@
Format.asprintf "%a should be a tuple expression"
AST.PP.expression expr
type eos =
| Expression
| Statements
type state = Cst_pascaligo.ParserLog.state
let statements_of_expression : CST.expr -> CST.statement List.Ne.t option = fun stat ->
match stat with
| CST.ECall call -> Some (CST.Instr (CST.ProcCall call), [])
| _ -> None
let rec decompile_expression : AST.expression -> _ result = fun e ->
let%bind (block,expr) = decompile_to_block e in
match expr with
Some expr ->
( match block with
Some block ->
let block = wrap @@ block in
ok @@ CST.EBlock (wrap @@ CST.{block;kwd_with=rg;expr})
| None -> ok @@ expr
)
| None ->
failwith @@ Format.asprintf
"An expression was expected, but this was decompile to statements. \n
Expr : %a
Loc : %a"
AST.PP.expression e
Location.pp e.location
and decompile_statements : AST.expression -> _ result = fun expr ->
let%bind (stat,_) = decompile_eos Statements expr in
match stat with
Some stat -> ok @@ stat
| None ->
failwith @@ Format.asprintf
"Statements was expected, but this was decompile to expression. \n
Expr : %a
Loc : %a"
AST.PP.expression expr
Location.pp expr.location
and decompile_to_block : AST.expression -> _ result = fun expr ->
let to_block a = CST.{enclosing=Block (rg,rg,rg);statements=a;terminator=Some rg} in
let%bind (stats,next) = decompile_eos Expression expr in
let block = Option.map (to_block <@ nelist_to_npseq) stats in
ok @@ (block, next)
and decompile_to_tuple_expr : AST.expression list -> (CST.tuple_expr,_) result = fun expr ->
let%bind tuple_expr = bind_map_list decompile_expression expr in
let%bind tuple_expr = list_to_nsepseq tuple_expr in
let tuple_expr : CST.tuple_expr = wrap @@ par @@ tuple_expr in
ok @@ tuple_expr
and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)* (CST.expr option), _) result = fun output expr ->
let return (a,b) = ok @@ (a,b) in
let return_expr expr = return @@ (None, Some expr) in
let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in
let return_stat stat = return @@ (Some stat, None) in
let return_stat_ez stat = return_stat @@ (stat, []) in
let return_inst inst = return_stat_ez @@ CST.Instr inst in
match expr.expression_content with
E_variable name ->
let var = decompile_variable name in
return_expr @@ CST.EVar (var)
| E_constant {cons_name; arguments} ->
let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in
(match arguments with
[] -> return_expr @@ expr
| _ ->
let%bind arguments = decompile_to_tuple_expr arguments in
let const : CST.fun_call = wrap (expr, arguments) in
(match output with
Expression -> return_expr (CST.ECall const)
| Statements -> return_inst (CST.ProcCall const)
)
)
| E_literal literal ->
(match literal with
Literal_unit -> return_expr @@ CST.EUnit rg
| Literal_int i -> return_expr @@ CST.EArith (Int (wrap ("",i)))
| Literal_nat n -> return_expr @@ CST.EArith (Nat (wrap ("",n)))
| Literal_timestamp time ->
let time = Tezos_utils.Time.Protocol.to_notation @@
Tezos_utils.Time.Protocol.of_seconds @@ Z.to_int64 time in
(* TODO combinators for CSTs. *)
let%bind ty = decompile_type_expr @@ AST.t_timestamp () in
let time = CST.EString (String (wrap time)) in
return_expr @@ CST.EAnnot (wrap @@ par (time, rg, ty))
| Literal_mutez mtez -> return_expr @@ CST.EArith (Mutez (wrap ("",mtez)))
| Literal_string (Standard str) -> return_expr @@ CST.EString (String (wrap str))
| Literal_string (Verbatim ver) -> return_expr @@ CST.EString (Verbatim (wrap ver))
| Literal_bytes b ->
let b = Hex.of_bytes b in
let s = Hex.to_string b in
return_expr @@ CST.EBytes (wrap (s,b))
| Literal_address addr ->
let addr = CST.EString (String (wrap addr)) in
let%bind ty = decompile_type_expr @@ AST.t_address () in
return_expr @@ CST.EAnnot (wrap @@ par (addr,rg,ty))
| Literal_signature sign ->
let sign = CST.EString (String (wrap sign)) in
let%bind ty = decompile_type_expr @@ AST.t_signature () in
return_expr @@ CST.EAnnot (wrap @@ par (sign,rg,ty))
| Literal_key k ->
let k = CST.EString (String (wrap k)) in
let%bind ty = decompile_type_expr @@ AST.t_key () in
return_expr @@ CST.EAnnot (wrap @@ par (k,rg,ty))
| Literal_key_hash kh ->
let kh = CST.EString (String (wrap kh)) in
let%bind ty = decompile_type_expr @@ AST.t_key_hash () in
return_expr @@ CST.EAnnot (wrap @@ par (kh,rg,ty))
| Literal_chain_id _
| Literal_void
| Literal_operation _ ->
failwith "chain_id, void, operation are not created currently ?"
)
| E_application {lamb;args} ->
let%bind lamb = decompile_expression lamb in
let%bind args = bind decompile_to_tuple_expr @@ get_e_tuple args in
(match output with
Expression ->
return_expr @@ CST.ECall (wrap (lamb,args))
| Statements ->
return_inst @@ CST.ProcCall (wrap (lamb,args))
)
| E_lambda lambda ->
let%bind (param,ret_type,return) = decompile_lambda lambda in
let fun_expr : CST.fun_expr = {kwd_function=rg;param;ret_type;kwd_is=rg;return} in
return_expr_with_par @@ CST.EFun (wrap @@ fun_expr)
| E_recursive _ ->
failwith "corner case : annonymous recursive function"
| E_let_in {let_binder;rhs={expression_content=E_update {record={expression_content=E_variable var;_};path;update};_};let_result;inline=_} when Var.equal (fst let_binder) var ->
let%bind lhs = (match List.rev path with
Access_map e :: path ->
let%bind path = decompile_to_path var @@ List.rev path in
let%bind index = map (wrap <@ brackets) @@ decompile_expression e in
let mlu : CST.map_lookup = {path; index} in
ok @@ CST.MapPath (wrap @@ mlu)
| _ ->
let%bind path = decompile_to_path var @@ path in
ok @@ (CST.Path (path) : CST.lhs)
)
in
let%bind rhs = decompile_expression update in
let assign : CST.assignment = {lhs;assign=rg;rhs} in
let assign = CST.Instr (CST.Assign (wrap @@ assign)) in
let%bind (stat,expr) = decompile_eos output let_result in
let stat = (match stat with
Some (stat) -> Some (List.Ne.cons assign stat)
| None -> Some (assign,[])
)
in
return @@ (stat,expr)
| E_let_in {let_binder;rhs;let_result;inline} ->
let%bind lin = decompile_to_data_decl let_binder rhs inline in
let%bind (lst, expr) = decompile_eos Expression let_result in
let lst = match lst with
Some lst -> List.Ne.cons (CST.Data lin) lst
| None -> (CST.Data lin, [])
in
return @@ (Some lst, expr)
| E_raw_code {language; code} ->
let language = wrap @@ wrap @@ language in
let%bind code = decompile_expression code in
let ci : CST.code_inj = {language;code;rbracket=rg} in
return_expr @@ CST.ECodeInj (wrap ci)
| E_constructor {constructor;element} ->
let Constructor constr = constructor in
let constr = wrap constr in
let%bind element = bind decompile_to_tuple_expr @@ get_e_tuple element in
return_expr_with_par @@ CST.EConstr (ConstrApp (wrap (constr, Some element)))
| E_matching {matchee; cases} ->
let%bind expr = decompile_expression matchee in
(match output with
Expression ->
let%bind cases = decompile_matching_expr decompile_expression cases in
let cases : _ CST.case = {kwd_case=rg;expr;kwd_of=rg;enclosing=End rg;lead_vbar=None;cases} in
return_expr @@ CST.ECase (wrap cases)
| Statements ->
let%bind cases = decompile_matching_expr decompile_if_clause cases in
let cases : _ CST.case = {kwd_case=rg;expr;kwd_of=rg;enclosing=End rg;lead_vbar=None;cases} in
return_inst @@ CST.CaseInstr (wrap cases)
)
| E_record record ->
let record = AST.LMap.to_kv_list record in
let aux (AST.Label str, expr) =
let field_name = wrap str in
let%bind field_expr = decompile_expression expr in
let field : CST.field_assignment = {field_name;assignment=rg;field_expr} in
ok @@ wrap field
in
let%bind record = bind_map_list aux record in
let%bind record = list_to_nsepseq record in
let record = ne_inject (NEInjRecord rg) record in
(* why is the record not empty ? *)
return_expr @@ CST.ERecord (wrap record)
| E_accessor {record; path} ->
(match List.rev path with
Access_map e :: [] ->
let%bind (var,lst) = get_e_accessor @@ record in
let%bind path = decompile_to_path var lst in
let%bind e = decompile_expression e in
let index = wrap @@ brackets @@ e in
let mlu : CST.map_lookup = {path;index} in
return_expr @@ CST.EMap(MapLookUp (wrap @@ mlu))
| Access_map e :: lst ->
let path = List.rev lst in
let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
let proj : CST.projection = {struct_name;selector=rg;field_path} in
let path : CST.path = CST.Path (wrap proj) in
let%bind e = decompile_expression e in
let index = wrap @@ brackets @@ e in
let mlu : CST.map_lookup = {path;index} in
return_expr @@ CST.EMap(MapLookUp (wrap @@ mlu))
| _ ->
let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
let proj : CST.projection = {struct_name;selector=rg;field_path} in
return_expr @@ CST.EProj (wrap proj)
)
(* Update on multiple field of the same record. may be removed by adding sugar *)
| E_update {record={expression_content=E_update _;_} as record;path;update} ->
let%bind record = decompile_expression record in
let%bind (record,updates) = match record with
CST.EUpdate {value;_} -> ok @@ (value.record,value.updates)
| _ -> failwith @@ Format.asprintf "Inpossible case %a" AST.PP.expression expr
in
let%bind var,path = match path with
Access_record var::path -> ok @@ (var,path)
| _ -> failwith "Impossible case %a"
in
let%bind field_path = decompile_to_path (Var.of_name var) path in
let%bind field_expr = decompile_expression update in
let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = updates.value.ne_elements in
let updates = wrap @@ ne_inject (NEInjRecord rg) @@ npseq_cons (wrap @@ field_assign) updates in
let update : CST.update = {record;kwd_with=rg;updates} in
return_expr @@ CST.EUpdate (wrap @@ update)
| E_update {record; path; update} ->
let%bind record = map (decompile_variable) @@ get_e_variable record in
let%bind field_expr = decompile_expression update in
let (struct_name,field_path) = List.Ne.of_list path in
(match field_path with
[] ->
(match struct_name with
Access_record name ->
let record : CST.path = Name record in
let field_path = CST.Name (wrap name) in
let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = wrap @@ ne_inject (NEInjRecord rg) @@ (wrap update,[]) in
let update : CST.update = {record;kwd_with=rg;updates;} in
return_expr @@ CST.EUpdate (wrap update)
| Access_tuple _ -> failwith @@ Format.asprintf "invalid tuple update %a" AST.PP.expression expr
| Access_map e ->
let%bind e = decompile_expression e in
let arg : CST.tuple_expr = wrap @@ par @@ nelist_to_npseq (field_expr,[e; CST.EVar record]) in
return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"), arg))
)
| _ ->
let%bind struct_name = match struct_name with
Access_record name -> ok @@ wrap name
| Access_tuple _ -> failwith @@ Format.asprintf "invalid tuple update %a" AST.PP.expression expr
| Access_map _ -> failwith @@ Format.asprintf "invalid map update %a" AST.PP.expression expr
in
(match List.rev field_path with
Access_map e :: lst ->
let field_path = List.rev lst in
let%bind field_path = bind_map_list decompile_to_selection field_path in
let%bind field_path = list_to_nsepseq field_path in
let field_path : CST.projection = {struct_name; selector=rg;field_path} in
let field_path = CST.EProj (wrap @@ field_path) in
let%bind e = decompile_expression e in
let arg = wrap @@ par @@ nelist_to_npseq (field_expr, [e; field_path]) in
return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"),arg))
| _ ->
let%bind field_path = bind_map_list decompile_to_selection field_path in
let%bind field_path = list_to_nsepseq field_path in
let field_path : CST.projection = {struct_name; selector=rg;field_path} in
let field_path : CST.path = CST.Path (wrap @@ field_path) in
let record : CST.path = Name record in
let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = wrap @@ ne_inject (NEInjRecord rg) @@ (wrap update,[]) in
let update : CST.update = {record;kwd_with=rg;updates;} in
return_expr @@ CST.EUpdate (wrap update)
)
)
| E_ascription {anno_expr;type_annotation} ->
let%bind expr = decompile_expression anno_expr in
let%bind ty = decompile_type_expr type_annotation in
return_expr @@ CST.EAnnot (wrap @@ par (expr,rg,ty))
| E_cond {condition;then_clause;else_clause} ->
let%bind test = decompile_expression condition in
(match output with
Expression ->
let%bind ifso = decompile_expression then_clause in
let%bind ifnot = decompile_expression else_clause in
let cond : CST.cond_expr = {kwd_if=rg;test;kwd_then=rg;ifso;terminator=Some rg;kwd_else=rg;ifnot} in
return_expr @@ CST.ECond (wrap cond)
| Statements ->
let%bind ifso = decompile_if_clause then_clause in
let%bind ifnot = decompile_if_clause else_clause in
let cond : CST.conditional = {kwd_if=rg;test;kwd_then=rg;ifso;terminator=Some rg; kwd_else=rg;ifnot} in
return_inst @@ CST.Cond (wrap cond)
)
| E_sequence {expr1;expr2} ->
let%bind expr1 = decompile_statements expr1 in
let%bind (expr2,next) = decompile_eos Statements expr2 in
let expr1 = Option.unopt ~default:expr1 @@ Option.map (List.Ne.append expr1) expr2 in
return @@ (Some expr1, next)
| E_skip -> return_inst @@ CST.Skip rg
| E_tuple tuple ->
let%bind tuple = bind_map_list decompile_expression tuple in
let%bind tuple = list_to_nsepseq tuple in
return_expr @@ CST.ETuple (wrap @@ par tuple)
| E_map map ->
let%bind map = bind_map_list (bind_map_pair decompile_expression) map in
let aux (k,v) =
let binding : CST.binding = {source=k;arrow=rg;image=v} in
wrap @@ binding
in
let map = list_to_sepseq @@ List.map aux map in
return_expr @@ CST.EMap (MapInj (wrap @@ inject (InjMap rg) @@ map))
| E_big_map big_map ->
let%bind big_map = bind_map_list (bind_map_pair decompile_expression) big_map in
let aux (k,v) =
let binding : CST.binding = {source=k;arrow=rg;image=v} in
wrap @@ binding
in
let big_map = list_to_sepseq @@ List.map aux big_map in
return_expr @@ CST.EMap (BigMapInj (wrap @@ inject (InjBigMap rg) @@ big_map))
| E_list lst ->
let%bind lst = bind_map_list decompile_expression lst in
let lst = list_to_sepseq lst in
return_expr @@ CST.EList (EListComp (wrap @@ inject (InjList rg) @@ lst))
| E_set set ->
let%bind set = bind_map_list decompile_expression set in
let set = list_to_sepseq set in
return_expr @@ CST.ESet (SetInj (wrap @@ inject (InjSet rg) @@ set))
| E_assign {variable;access_path;expression} ->
let%bind lhs = decompile_to_lhs variable access_path in
let%bind rhs = decompile_expression expression in
let assign : CST.assignment = {lhs;assign=rg;rhs} in
return_inst @@ Assign (wrap assign)
| E_for {binder;start;final;increment;body} ->
let binder = decompile_variable binder in
let%bind init = decompile_expression start in
let%bind bound = decompile_expression final in
let%bind step = decompile_expression increment in
let step = Some (rg, step) in
let%bind (block,_next) = decompile_to_block body in
let block = wrap @@ Option.unopt ~default:(empty_block) block in
let fl : CST.for_int = {kwd_for=rg;binder;assign=rg;init;kwd_to=rg;bound;step;block} in
return_inst @@ CST.Loop (For (ForInt (wrap fl)))
| E_for_each {binder;collection;collection_type;body} ->
let var = decompile_variable @@ fst binder in
let bind_to = Option.map (fun x -> (rg,decompile_variable x)) @@ snd binder in
let%bind expr = decompile_expression collection in
let collection = match collection_type with
Map -> CST.Map rg | Set -> Set rg | List -> List rg in
let%bind (block,_next) = decompile_to_block body in
let block = wrap @@ Option.unopt ~default:(empty_block) block in
let fc : CST.for_collect = {kwd_for=rg;var;bind_to;kwd_in=rg;collection;expr;block} in
return_inst @@ CST.Loop (For (ForCollect (wrap fc)))
| E_while {condition;body} ->
let%bind cond = decompile_expression condition in
let%bind (block,_next) = decompile_to_block body in
let block = wrap @@ Option.unopt ~default:(empty_block) block in
let loop : CST.while_loop = {kwd_while=rg;cond;block} in
return_inst @@ CST.Loop (While (wrap loop))
and decompile_if_clause : AST.expression -> (CST.if_clause, _) result = fun e ->
let%bind clause = decompile_statements e in
match clause with
CST.Instr instr,[] ->
ok @@ CST.ClauseInstr instr
| _ ->
let clause = nelist_to_npseq clause, Some rg in
ok @@ CST.ClauseBlock (ShortBlock (wrap @@ braces @@ clause))
and decompile_to_data_decl : (AST.expression_variable * AST.type_expression option) -> AST.expression -> bool -> (CST.data_decl, _) result = fun (name,ty_opt) expr inline ->
let name = decompile_variable name in
let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
let attributes : CST.attr_decl option = match inline with
true -> Some (wrap @@ ne_inject (NEInjAttr rg) @@ (wrap @@ "inline",[]))
| false -> None
in
let fun_name = name in
match expr.expression_content with
E_lambda lambda ->
let%bind (param,ret_type,return) = decompile_lambda lambda in
let fun_decl : CST.fun_decl = {kwd_recursive=None;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
ok @@ CST.LocalFun (wrap fun_decl)
| E_recursive {lambda; _} ->
let%bind (param,ret_type,return) = decompile_lambda lambda in
let fun_decl : CST.fun_decl = {kwd_recursive=Some rg;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
ok @@ CST.LocalFun (wrap fun_decl)
| _ ->
let%bind init = decompile_expression expr in
let const_decl : CST.const_decl = {kwd_const=rg;name;const_type;equal=rg;init;terminator=Some rg; attributes} in
let data_decl : CST.data_decl = LocalConst (wrap const_decl) in
ok @@ data_decl
and decompile_to_lhs : AST.expression_variable -> AST.access list -> (CST.lhs, _) result = fun var access ->
match List.rev access with
[] -> ok @@ (CST.Path (Name (decompile_variable var)) : CST.lhs)
| hd :: tl ->
match hd with
| AST.Access_map e ->
let%bind path = decompile_to_path var @@ List.rev tl in
let%bind index = map (wrap <@ brackets) @@ decompile_expression e in
let mlu: CST.map_lookup = {path;index} in
ok @@ CST.MapPath (wrap @@ mlu)
| _ ->
let%bind path = decompile_to_path var @@ access in
ok @@ (CST.Path (path) : CST.lhs)
and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access ->
let struct_name = decompile_variable var in
match access with
[] -> ok @@ CST.Name struct_name
| lst ->
let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection lst in
let path : CST.projection = {struct_name;selector=rg;field_path} in
ok @@ (CST.Path (wrap @@ path) : CST.path)
and decompile_to_selection : AST.access -> (CST.selection, _) result = fun access ->
match access with
Access_tuple index -> ok @@ CST.Component (wrap @@ ("",index))
| Access_record str -> ok @@ CST.FieldName (wrap str)
| Access_map _ ->
failwith @@ Format.asprintf
"Can't decompile access_map to selection"
and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} ->
let var = decompile_variable binder in
let%bind param_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) input_type in
let param_const : CST.param_const = {kwd_const=rg;var;param_type} in
let param_decl : CST.param_decl = ParamConst (wrap param_const) in
let param = nelist_to_npseq (param_decl, []) in
let param : CST.parameters = wrap @@ par param in
let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in
let%bind return = decompile_expression result in
ok @@ (param,ret_type,return)
and decompile_matching_expr : type a.(AST.expr ->(a,_) result) -> AST.matching_expr -> ((a CST.case_clause Region.reg, Region.t) Parser_shared.Utils.nsepseq Region.reg,_) result =
fun f m ->
let%bind cases = match m with
Match_variable (var, _ty_opt, expr) ->
let pattern : CST.pattern = PVar (decompile_variable var) in
let%bind rhs = f expr in
let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
ok @@ [wrap case]
| Match_tuple (lst, _ty_opt, expr) ->
let aux var = CST.PVar (decompile_variable var) in
let%bind tuple = list_to_nsepseq @@ List.map aux lst in
let pattern : CST.pattern = PTuple (wrap @@ par @@ tuple) in
let%bind rhs = f expr in
let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
ok @@ [wrap case]
| Match_record _ -> failwith "match_record not availiable yet"
| Match_option {match_none;match_some}->
let%bind rhs = f match_none in
let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in
let%bind rhs = f @@ snd match_some in
let var = wrap @@ par @@ CST.PVar (decompile_variable @@ fst match_some)in
let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in
ok @@ [wrap some_case;wrap none_case]
| Match_list {match_nil; match_cons} ->
let (hd,tl,expr) = match_cons in
let hd = CST.PVar (decompile_variable hd) in
let tl = CST.PVar (decompile_variable tl) in
let cons = (hd,[rg,tl]) in
let%bind rhs = f @@ expr in
let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in
let%bind rhs = f @@ match_nil in
let nil_case : _ CST.case_clause = {pattern=PList (PNil rg);arrow=rg; rhs} in
ok @@ [wrap cons_case; wrap nil_case]
| Match_variant lst ->
let aux ((c,v),e) =
let AST.Constructor c = c in
let constr = wrap @@ c in
let var : CST.pattern = PVar (decompile_variable v) in
let tuple = wrap @@ par @@ (var,[]) in
let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in
let%bind rhs = f e in
let case : _ CST.case_clause = {pattern;arrow=rg;rhs} in
ok @@ wrap case
in
bind_map_list aux lst
in
map wrap @@ list_to_nsepseq cases
let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _) result = fun decl ->
let decl = Location.unwrap decl in
let wrap value = ({value;region=Region.ghost} : _ Region.reg) in
match decl with
Declaration_type (name, te) ->
let kwd_type = Region.ghost
and name = decompile_variable name
and kwd_is = Region.ghost in
let%bind type_expr = decompile_type_expr te in
let terminator = Some Region.ghost in
ok @@ CST.TypeDecl (wrap (CST.{kwd_type; name; kwd_is; type_expr; terminator}))
| Declaration_constant (var, ty_opt, inline, expr) ->
let attributes = match inline with
true ->
let attr = wrap "inline" in
let ne_inj : _ CST.ne_injection =
{kind=NEInjAttr rg;enclosing=End rg;ne_elements=(attr, []);terminator=Some rg} in
let attr_decl = wrap ne_inj in
Some attr_decl
| false -> None
in
let name = decompile_variable var in
let fun_name = name in
match expr.expression_content with
E_lambda lambda ->
let%bind (param,ret_type,return) = decompile_lambda lambda in
let fun_decl : CST.fun_decl = {kwd_recursive=None;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
ok @@ CST.FunDecl (wrap fun_decl)
| E_recursive {lambda; _} ->
let%bind (param,ret_type,return) = decompile_lambda lambda in
let fun_decl : CST.fun_decl = {kwd_recursive=Some rg;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
ok @@ CST.FunDecl (wrap fun_decl)
| _ ->
let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
let%bind init = decompile_expression expr in
let const_decl : CST.const_decl = {kwd_const=rg;name;const_type;equal=rg;init;terminator=Some rg; attributes} in
ok @@ CST.ConstDecl (wrap const_decl)
let decompile_program : AST.program -> (CST.ast, _) result = fun prg ->
let%bind decl = bind_map_list decompile_declaration prg in
let decl = List.Ne.of_list decl in
ok @@ ({decl;eof=rg}: CST.ast)

10
src/passes/03-tree_abstraction/pascaligo/pascaligo.ml
View File

@ -1,8 +1,12 @@
module CST = Cst.Pascaligo
module AST = Ast_imperative
module Compiler = Compiler
module Compiler = Compiler
module Decompiler = Decompiler
module Errors = Errors
let compile_program = Compiler.compile_program
let compile_expression = Compiler.compile_expression
let compile_program = Compiler.compile_program
let compile_expression = Compiler.compile_expression
let decompile_program = Decompiler.decompile_program
let decompile_expression = Decompiler.decompile_expression

10
src/passes/03-tree_abstraction/pascaligo/pascaligo.mli
View File

@ -6,10 +6,14 @@ module Errors = Errors
open Trace
(** Convert a concrete PascaLIGO expression AST to the imperative
(** Convert a concrete PascaLIGO expression CST to the imperative
expression AST used by the compiler. *)
val compile_expression : CST.expr -> (AST.expr , Errors.abs_error) result
val compile_expression : CST.expr -> (AST.expr, Errors.abs_error) result
(** Convert a concrete PascaLIGO program AST to the miperative program
(** Convert a concrete PascaLIGO program CST to the miperative program
AST used by the compiler. *)
val compile_program : CST.ast -> (AST.program, Errors.abs_error) result
val decompile_expression : AST.expr -> (CST.expr, _) result
val decompile_program : AST.program -> (CST.ast, _) result

22
src/passes/05-purification/compiler.ml
View File

@ -252,7 +252,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression,
let%bind condition = compile_expression condition in
let%bind then_clause' = compile_expression then_clause in
let%bind else_clause' = compile_expression else_clause in
let env = Var.fresh () in
let env = Var.fresh ~name:"env" () in
let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in
let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in
let then_clause = add_to_end then_clause (O.e_variable env) in
@ -283,7 +283,9 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression,
| I.E_assign {variable; access_path; expression} ->
let%bind access_path = compile_path access_path in
let%bind expression = compile_expression expression in
let rhs = O.e_update ~loc (O.e_variable ~loc variable) access_path expression in
let rhs = match access_path with
[] -> expression
| _ -> O.e_update ~loc (O.e_variable ~loc variable) access_path expression in
ok @@ fun expr -> (match expr with
| None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ())
| Some e -> O.e_let_in ~loc (variable, None) true false rhs e
@ -328,7 +330,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let%bind match_none' = compile_expression match_none in
let (n,expr) = match_some in
let%bind expr' = compile_expression expr in
let env = Var.fresh () in
let env = Var.fresh ~name:"env" () in
let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in
let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in
let match_none = add_to_end match_none (O.e_variable env) in
@ -348,7 +350,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let%bind match_nil' = compile_expression match_nil in
let (hd,tl,expr) = match_cons in
let%bind expr' = compile_expression expr in
let env = Var.fresh () in
let env = Var.fresh ~name:"name" () in
let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in
let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in
let match_nil = add_to_end match_nil (O.e_variable env) in
@ -365,7 +367,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
else
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')}
| I.Match_variant lst ->
let env = Var.fresh () in
let env = Var.fresh ~name:"env" () in
let aux fv ((c,n),expr) =
let%bind expr = compile_expression expr in
let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in
@ -401,8 +403,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr)
and compile_while I.{condition;body} =
let env_rec = Var.fresh () in
let binder = Var.fresh () in
let env_rec = Var.fresh ~name:"env_rec" () in
let binder = Var.fresh ~name:"binder" () in
let%bind cond = compile_expression condition in
let ctrl =
@ -436,7 +438,7 @@ and compile_while I.{condition;body} =
and compile_for I.{binder;start;final;increment;body} =
let env_rec = Var.fresh () in
let env_rec = Var.fresh ~name:"env_rec" () in
(*Make the cond and the step *)
let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) (I.t_bool ()) in
let%bind cond = compile_expression cond in
@ -481,8 +483,8 @@ and compile_for I.{binder;start;final;increment;body} =
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
and compile_for_each I.{binder;collection;collection_type; body} =
let env_rec = Var.fresh () in
let args = Var.fresh () in
let env_rec = Var.fresh ~name:"env_rec" () in
let args = Var.fresh ~name:"args" () in
let%bind element_names = ok @@ match snd binder with
| Some v -> [fst binder;v]

55
src/passes/07-desugaring/compiler.ml
View File

@ -6,7 +6,7 @@ open Errors
let rec compile_type_expression : I.type_expression -> (O.type_expression , desugaring_error) result =
fun te ->
let return tc = ok @@ O.make_t ~loc:te.location tc in
let return tc = ok @@ O.make_t ~loc:te.location ~sugar:te tc in
match te.type_content with
| I.T_sum sum ->
let sum = I.CMap.to_kv_list sum in
@ -48,9 +48,9 @@ let rec compile_type_expression : I.type_expression -> (O.type_expression , desu
return @@ T_operator (type_operator, lst)
let rec compile_expression : I.expression -> (O.expression , desugaring_error) result =
fun e ->
let return expr = ok @@ O.make_e ~loc:e.location expr in
match e.expression_content with
fun sugar ->
let return expr = ok @@ O.make_e ~loc:sugar.location ~sugar expr in
match sugar.expression_content with
| I.E_literal literal -> return @@ O.E_literal literal
| I.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list compile_expression arguments in
@ -81,7 +81,7 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} ->
let%bind matchee = compile_expression matchee in
compile_matching e.location matchee cases
compile_matching sugar matchee cases
| I.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
@ -93,33 +93,33 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
return @@ O.E_record (O.LMap.of_list record)
| I.E_accessor {record;path} ->
let%bind record = compile_expression record in
let accessor ?loc e a =
let accessor ?loc expr a =
match a with
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
| I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc expr (Label (Z.to_string i))
| I.Access_record a -> ok @@ O.e_record_accessor ?loc expr (Label a)
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;expr]
in
bind_fold_list accessor record path
| I.E_update {record;path;update} ->
let%bind record = compile_expression record in
let%bind update = compile_expression update in
let accessor ?loc e a =
let accessor ?loc expr a =
match a with
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
| I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc expr (Label (Z.to_string i))
| I.Access_record a -> ok @@ O.e_record_accessor ?loc expr (Label a)
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;expr]
in
let updator ?loc (s:O.expression) a e =
let updator ?loc (s:O.expression) a expr =
match a with
I.Access_tuple i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) e
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
I.Access_tuple i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) expr
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) expr
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_ADD [k;e;s]
ok @@ O.e_constant ?loc C_MAP_ADD [k;expr;s]
in
let aux (s, e : O.expression * _) lst =
let%bind s' = accessor ~loc:s.location s lst in
@ -176,7 +176,7 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in
return @@ O.E_let_in {let_binder=(Var.of_name "_", Some (O.t_unit ())); rhs=expr1;let_result=expr2; inline=false}
| I.E_skip -> ok @@ O.e_unit ~loc:e.location ()
| I.E_skip -> ok @@ O.e_unit ~loc:sugar.location ~sugar ()
| I.E_tuple t ->
let aux (i,acc) el =
let%bind el = compile_expression el in
@ -191,19 +191,20 @@ and compile_lambda : I.lambda -> (O.lambda , desugaring_error) result =
let%bind output_type = bind_map_option compile_type_expression output_type in
let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result}
and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expression, desugaring_error) result =
fun loc e m ->
and compile_matching : I.expression -> O.expression -> I.matching_expr -> (O.expression, desugaring_error) result =
fun sugar e m ->
let loc = sugar.location in
match m with
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr) = match_cons in
let%bind expr = compile_expression expr in
ok @@ O.e_matching ~loc e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)}
ok @@ O.e_matching ~loc ~sugar e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)}
| I.Match_option {match_none;match_some} ->
let%bind match_none = compile_expression match_none in
let (n,expr) = match_some in
let%bind expr = compile_expression expr in
ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)}
ok @@ O.e_matching ~loc ~sugar e @@ O.Match_option {match_none; match_some=(n,expr)}
| I.Match_variant lst ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
@ -211,7 +212,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
ok @@ ((c,n),expr)
) lst
in
ok @@ O.e_matching ~loc e @@ O.Match_variant lst
ok @@ O.e_matching ~loc ~sugar e @@ O.Match_variant lst
| I.Match_record (fields,field_types, expr) ->
let combine fields field_types =
match field_types with
@ -221,7 +222,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
let%bind next = compile_expression expr in
let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
let aux ((index,expr) : int * _ ) ((field,name): (O.label * (O.expression_variable * O.type_expression option))) =
let f = fun expr' -> O.e_let_in name false (O.e_record_accessor e field) expr' in
let f = fun expr' -> O.e_let_in ~sugar name false (O.e_record_accessor ~sugar e field) expr' in
(index+1, fun expr' -> expr (f expr'))
in
let (_,header) = List.fold_left aux (0, fun e -> e) @@
@ -238,7 +239,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
let%bind next = compile_expression expr in
let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
let aux ((index,expr) : int * _ ) (field: O.expression_variable * O.type_expression option) =
let f = fun expr' -> O.e_let_in field false (O.e_record_accessor e (Label (string_of_int index))) expr' in
let f = fun expr' -> O.e_let_in ~sugar field false (O.e_record_accessor ~sugar e (Label (string_of_int index))) expr' in
(index+1, fun expr' -> expr (f expr'))
in
let (_,header) = List.fold_left aux (0, fun e -> e) @@
@ -248,7 +249,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
| I.Match_variable (a, ty_opt, expr) ->
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind expr = compile_expression expr in
ok @@ O.e_let_in (a,ty_opt) false e expr
ok @@ O.e_let_in ~sugar (a,ty_opt) false e expr
let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} ->
@ -257,7 +258,7 @@ let compile_declaration : I.declaration Location.wrap -> _ =
| I.Declaration_constant (n, te_opt, inline, expr) ->
let%bind expr = compile_expression expr in
let%bind te_opt = bind_map_option compile_type_expression te_opt in
return @@ O.Declaration_constant (n, te_opt, inline, expr)
return @@ O.Declaration_constant (n, te_opt, {inline}, expr)
| I.Declaration_type (n, te) ->
let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te)

190
src/passes/07-desugaring/decompiler.ml
View File

@ -7,101 +7,107 @@ open Errors
let rec decompile_type_expression : O.type_expression -> (I.type_expression, desugaring_error) result =
fun te ->
let return te = ok @@ I.make_t te in
match te.type_content with
| O.T_sum sum ->
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let {ctor_type;michelson_annotation;ctor_decl_pos} : O.ctor_content = v in
let%bind ctor_type = decompile_type_expression ctor_type in
let v' : I.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
ok @@ (k,v')
) sum
in
return @@ I.T_sum (O.CMap.of_list sum)
| O.T_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let {field_type;field_annotation;field_decl_pos} : O.field_content = v in
let%bind field_type = decompile_type_expression field_type in
let v' : I.field_content = {field_type ; michelson_annotation=field_annotation ; field_decl_pos} in
ok @@ (k,v')
) record
in
return @@ I.T_record (O.LMap.of_list record)
| O.T_arrow {type1;type2} ->
let%bind type1 = decompile_type_expression type1 in
let%bind type2 = decompile_type_expression type2 in
return @@ T_arrow {type1;type2}
| O.T_variable type_variable -> return @@ T_variable type_variable
| O.T_constant type_constant -> return @@ T_constant type_constant
| O.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list decompile_type_expression lst in
return @@ T_operator (type_operator, lst)
match te.sugar with
Some te -> ok @@ te
| None ->
match te.content with
| O.T_sum sum ->
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let {ctor_type;michelson_annotation;ctor_decl_pos} : O.ctor_content = v in
let%bind ctor_type = decompile_type_expression ctor_type in
let v' : I.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
ok @@ (k,v')
) sum
in
return @@ I.T_sum (O.CMap.of_list sum)
| O.T_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let {field_type;field_annotation;field_decl_pos} : O.field_content = v in
let%bind field_type = decompile_type_expression field_type in
let v' : I.field_content = {field_type ; michelson_annotation=field_annotation ; field_decl_pos} in
ok @@ (k,v')
) record
in
return @@ I.T_record (O.LMap.of_list record)
| O.T_arrow {type1;type2} ->
let%bind type1 = decompile_type_expression type1 in
let%bind type2 = decompile_type_expression type2 in
return @@ T_arrow {type1;type2}
| O.T_variable type_variable -> return @@ T_variable type_variable
| O.T_constant type_constant -> return @@ T_constant type_constant
| O.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list decompile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec decompile_expression : O.expression -> (I.expression, desugaring_error) result =
fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with
O.E_literal lit -> return @@ I.E_literal lit
| O.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list decompile_expression arguments in
return @@ I.E_constant {cons_name;arguments}
| O.E_variable name -> return @@ I.E_variable name
| O.E_application {lamb; args} ->
let%bind lamb = decompile_expression lamb in
let%bind args = decompile_expression args in
return @@ I.E_application {lamb; args}
| O.E_lambda lambda ->
let%bind lambda = decompile_lambda lambda in
return @@ I.E_lambda lambda
| O.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = decompile_type_expression fun_type in
let%bind lambda = decompile_lambda lambda in
return @@ I.E_recursive {fun_name;fun_type;lambda}
| O.E_let_in {let_binder;inline=false;rhs=expr1;let_result=expr2} when let_binder = (Var.of_name "_", Some (O.t_unit ())) ->
let%bind expr1 = decompile_expression expr1 in
let%bind expr2 = decompile_expression expr2 in
return @@ I.E_sequence {expr1;expr2}
| O.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option decompile_type_expression ty_opt in
let%bind rhs = decompile_expression rhs in
let%bind let_result = decompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
| O.E_raw_code {language;code} ->
let%bind code = decompile_expression code in
return @@ I.E_raw_code {language;code}
| O.E_constructor {constructor;element} ->
let%bind element = decompile_expression element in
return @@ I.E_constructor {constructor;element}
| O.E_matching {matchee; cases} ->
let%bind matchee = decompile_expression matchee in
let%bind cases = decompile_matching cases in
return @@ I.E_matching {matchee;cases}
| O.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v = decompile_expression v in
ok @@ (k,v)
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} ->
let%bind record = decompile_expression record in
let Label path = path in
return @@ I.E_accessor {record;path=[I.Access_record path]}
| O.E_record_update {record;path;update} ->
let%bind record = decompile_expression record in
let%bind update = decompile_expression update in
let Label path = path in
return @@ I.E_update {record;path=[I.Access_record path];update}
| O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = decompile_expression anno_expr in
let%bind type_annotation = decompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation}
match e.sugar with
Some e -> ok @@ e
| None ->
match e.content with
O.E_literal lit -> return @@ I.E_literal lit
| O.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list decompile_expression arguments in
return @@ I.E_constant {cons_name;arguments}
| O.E_variable name -> return @@ I.E_variable name
| O.E_application {lamb; args} ->
let%bind lamb = decompile_expression lamb in
let%bind args = decompile_expression args in
return @@ I.E_application {lamb; args}
| O.E_lambda lambda ->
let%bind lambda = decompile_lambda lambda in
return @@ I.E_lambda lambda
| O.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = decompile_type_expression fun_type in
let%bind lambda = decompile_lambda lambda in
return @@ I.E_recursive {fun_name;fun_type;lambda}
| O.E_let_in {let_binder;inline=false;rhs=expr1;let_result=expr2} when let_binder = (Var.of_name "_", Some (O.t_unit ())) ->
let%bind expr1 = decompile_expression expr1 in
let%bind expr2 = decompile_expression expr2 in
return @@ I.E_sequence {expr1;expr2}
| O.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option decompile_type_expression ty_opt in
let%bind rhs = decompile_expression rhs in
let%bind let_result = decompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
| O.E_raw_code {language;code} ->
let%bind code = decompile_expression code in
return @@ I.E_raw_code {language;code}
| O.E_constructor {constructor;element} ->
let%bind element = decompile_expression element in
return @@ I.E_constructor {constructor;element}
| O.E_matching {matchee; cases} ->
let%bind matchee = decompile_expression matchee in
let%bind cases = decompile_matching cases in
return @@ I.E_matching {matchee;cases}
| O.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v = decompile_expression v in
ok @@ (k,v)
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} ->
let%bind record = decompile_expression record in
let Label path = path in
return @@ I.E_accessor {record;path=[I.Access_record path]}
| O.E_record_update {record;path;update} ->
let%bind record = decompile_expression record in
let%bind update = decompile_expression update in
let Label path = path in
return @@ I.E_update {record;path=[I.Access_record path];update}
| O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = decompile_expression anno_expr in
let%bind type_annotation = decompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation}
and decompile_lambda : O.lambda -> (I.lambda, desugaring_error) result =
fun {binder;input_type;output_type;result}->
@ -134,7 +140,7 @@ and decompile_matching : O.matching_expr -> (I.matching_expr, desugaring_error)
let decompile_declaration : O.declaration Location.wrap -> _ result = fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in
match declaration with
| O.Declaration_constant (n, te_opt, inline, expr) ->
| O.Declaration_constant (n, te_opt, {inline}, expr) ->
let%bind expr = decompile_expression expr in
let%bind te_opt = bind_map_option decompile_type_expression te_opt in
return @@ I.Declaration_constant (n, te_opt, inline, expr)

17
src/passes/08-self_ast_core/helpers.ml
View File

@ -3,7 +3,6 @@ open Trace
open Stage_common.Helpers
include Stage_common.PP
include Stage_common.Types.Ast_generic_type(Ast_core_parameter)
let bind_map_cmap f map = bind_cmap (
CMap.map
@ -23,7 +22,7 @@ type ('a,'err) folder = 'a -> expression -> ('a, 'err) result
let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a,'err) result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
match e.content with
| E_literal _ | E_variable _ | E_raw_code _ -> ok init'
| E_constant {arguments=lst} -> (
let%bind res = bind_fold_list self init' lst in
@ -98,8 +97,8 @@ type 'err abs_mapper =
let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
match e'.expression_content with
let return content = ok { e' with content } in
match e'.content with
| E_ascription ascr -> (
let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'}
@ -151,11 +150,11 @@ let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) re
| E_literal _ | E_variable _ | E_raw_code _ as e' -> return e'
and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression , 'err) result =
fun f ({type_content ; location ; type_meta} as te) ->
fun f ({content ; sugar; location } as te) ->
let self = map_type_expression f in
let%bind te' = f te in
let return type_content = ok { type_content; location ; type_meta } in
match type_content with
let return content = ok @@ ({ content; sugar; location}: type_expression) in
match content with
| T_sum temap ->
let%bind temap' = bind_map_cmap self temap in
return @@ (T_sum temap')
@ -212,8 +211,8 @@ let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
else
let return expression_content = { e' with expression_content } in
match e'.expression_content with
let return content = { e' with content } in
match e'.content with
| E_ascription ascr -> (
let%bind (res,e') = self init' ascr.anno_expr in
ok (res, return @@ E_ascription {ascr with anno_expr=e'})

8
src/passes/09-typing/08-typer-new/typer.ml
View File

@ -24,7 +24,7 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
ok (env', state , None)
| Declaration_constant (binder , tv_opt , inline, expression) -> (
| Declaration_constant (binder , tv_opt , attr, expression) -> (
(*
Determine the type of the expression and add it to the environment
*)
@ -33,7 +33,7 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st
trace (constant_declaration_tracer binder expression tv'_opt) @@
type_expression env state expression in
let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline=attr.inline} ))
)
and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result =
@ -111,7 +111,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
*)
and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
match t.type_content with
match t.content with
| T_arrow {type1;type2} ->
let%bind type1 = evaluate_type e type1 in
let%bind type2 = evaluate_type e type2 in
@ -210,7 +210,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
trace (expression_tracer ae) @@
match ae.expression_content with
match ae.content with
(* TODO: this file should take care only of the order in which program fragments
are translated by Wrap.xyz

2
src/passes/09-typing/08-typer-new/wrap.ml
View File

@ -62,7 +62,7 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun
p_constant csttag (List.map type_expression_to_type_value args)
let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te ->
match te.type_content with
match te.content with
| T_sum kvmap ->
let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
let tlist = List.map (fun ({ctor_type;_}:I.ctor_content) -> ctor_type) (I.CMap.to_list kvmap) in

20
src/passes/09-typing/08-typer-old/typer.ml
View File

@ -290,13 +290,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state)
let%bind tv = evaluate_type env type_expr in
let env' = Environment.add_type (type_binder) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } ))
| Declaration_constant (binder , tv_opt , inline, expression) -> (
| Declaration_constant (binder , tv_opt , attr, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr =
trace (constant_declaration_error_tracer binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline=attr.inline}))
)
and type_match : (environment -> I.expression -> (O.expression , typer_error) result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr, typer_error) result =
@ -349,7 +349,7 @@ and type_match : (environment -> I.expression -> (O.expression , typer_error) re
and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
match t.type_content with
match t.content with
| T_arrow {type1;type2} ->
let%bind type1 = evaluate_type e type1 in
let%bind type2 = evaluate_type e type2 in
@ -456,7 +456,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let location = ae.location in
ok @@ make_e ~location expr tv in
trace (expression_tracer ae) @@
match ae.expression_content with
match ae.content with
(* Basic *)
| E_variable name ->
let%bind tv' =
@ -561,7 +561,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (E_lambda lambda ) lambda_type
| E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ;
arguments=[
( { expression_content = (I.E_lambda { binder = lname ;
( { content = (I.E_lambda { binder = lname ;
input_type = None ;
output_type = None ;
result }) ;
@ -589,7 +589,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (E_constant {cons_name=opname';arguments=lst'}) tv
| E_constant {cons_name=C_FOLD_WHILE as opname;
arguments = [
( { expression_content = (I.E_lambda { binder = lname ;
( { content = (I.E_lambda { binder = lname ;
input_type = None ;
output_type = None ;
result }) ;
@ -701,7 +701,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
| E_raw_code {language;code} ->
let%bind (code,type_expression) = trace_option (expected_ascription code) @@
I.get_e_ascription code.expression_content in
I.get_e_ascription code.content in
let%bind code = type_expression' e code in
let%bind type_expression = evaluate_type e type_expression in
let code = {code with type_expression} in
@ -740,9 +740,9 @@ and type_lambda e {
match input_type with
| Some ty -> ok ty
| None -> (
match result.expression_content with
match result.content with
| I.E_let_in li -> (
match li.rhs.expression_content with
match li.rhs.content with
| I.E_variable name when name = (binder) -> (
match snd li.let_binder with
| Some ty -> ok ty
@ -849,7 +849,7 @@ let rec untype_expression (e:O.expression) : (I.expression , typer_error) result
| E_recursive {fun_name;fun_type; lambda} ->
let%bind fun_type = untype_type_expression fun_type in
let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in
let lambda = match unty_expr.expression_content with I.E_lambda l -> l | _ -> failwith "impossible case" in
let lambda = match unty_expr.content with I.E_lambda l -> l | _ -> failwith "impossible case" in
return @@ e_recursive fun_name fun_type lambda
and untype_matching : (O.expression -> (I.expression , typer_error) result) -> O.matching_expr -> (I.matching_expr , typer_error) result = fun f m ->

2
src/passes/10-self_ast_typed/helpers.ml
View File

@ -256,7 +256,7 @@ type contract_type = {
let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program ->
let aux declt = match Location.unwrap declt with
| Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
if String.equal (Var.to_name binder) main_fname
if Var.equal binder @@ Var.of_name main_fname
then Some p
else None
| Declaration_type _ -> None

214
src/passes/predefined/predefined.ml
View File

@ -47,6 +47,23 @@ module Tree_abstraction = struct
| "timestamp" -> Some TC_timestamp
| _ -> None
let type_constant_to_string tc =
match tc with
TC_chain_id -> "chain_id"
| TC_unit -> "unit"
| TC_string -> "string"
| TC_bytes -> "bytes"
| TC_nat -> "nat"
| TC_int -> "int"
| TC_mutez -> "tez"
| TC_operation -> "operation"
| TC_address -> "address"
| TC_key -> "key"
| TC_key_hash -> "key_hash"
| TC_signature -> "signature"
| TC_timestamp -> "timestamp"
| TC_void -> "void"
let type_operators s =
match s with
"list" -> Some (TC_list)
@ -61,6 +78,23 @@ module Tree_abstraction = struct
| "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb)
| _ -> None
let type_operator_to_string s =
match s with
TC_list -> "list"
| TC_option -> "option"
| TC_set -> "set"
| TC_map -> "map"
| TC_big_map -> "big_map"
| TC_contract -> "contract"
| TC_michelson_pair -> "michelson_pair"
| TC_michelson_or -> "michelson_or"
| TC_michelson_pair_right_comb -> "michelson_pair_right_comb"
| TC_michelson_pair_left_comb -> "michelson_pair_left_comb"
| TC_michelson_or_right_comb -> "michelson_or_right_comb"
| TC_michelson_or_left_comb -> "michelson_or_left_comb"
| TC_map_or_big_map -> "map_or_big_map"
let pseudo_modules = function
| "Tezos.chain_id" -> Some C_CHAIN_ID
| "Tezos.balance" -> Some C_BALANCE
@ -165,6 +199,113 @@ module Tree_abstraction = struct
| _ -> None
let pseudo_module_to_string = function
| C_CHAIN_ID -> "Tezos.chain_id"
| C_BALANCE -> "Tezos.balance"
| C_NOW -> "Tezos.now"
| C_AMOUNT -> "Tezos.amount"
| C_SENDER -> "Tezos.sender"
| C_ADDRESS -> "Tezos.address"
| C_SELF -> "Tezos.self"
| C_SELF_ADDRESS -> "Tezos.self_address"
| C_IMPLICIT_ACCOUNT -> "Tezos.implicit_account"
| C_SOURCE -> "Tezos.source"
| C_FAILWITH -> "Tezos.failwith"
| C_CREATE_CONTRACT -> "Tezos.create_contract"
| C_CALL -> "Tezos.transaction"
| C_SET_DELEGATE -> "Tezos.set_delegate"
| C_CONTRACT_OPT -> "Tezos.get_contract_opt"
| C_CONTRACT_ENTRYPOINT_OPT -> "Tezos.get_entrypoint_opt"
| C_CONTRACT -> "Tezos.get_contract"
| C_CONTRACT_ENTRYPOINT -> "Tezos.get_entrypoint"
(* Crypto module *)
| C_CHECK_SIGNATURE -> "Crypto.check"
| C_HASH_KEY -> "Crypto.hash_key"
| C_BLAKE2b -> "Crypto.blake2b"
| C_SHA256 -> "Crypto.sha256"
| C_SHA512 -> "Crypto.sha512"
(* Bytes module *)
| C_BYTES_PACK -> "Bytes.pack"
| C_BYTES_UNPACK -> "Bytes.unpack"
| C_SIZE -> "Bytes.length"
| C_CONCAT -> "Bytes.concat"
| C_SLICE -> "Bytes.sub"
(* List module *)
(* | C_SIZE -> "List.size" *)
| C_LIST_ITER -> "List.iter"
| C_LIST_MAP -> "List.map"
| C_LIST_FOLD -> "List.fold"
(* Set module *)
| C_SET_EMPTY -> "Set.empty"
| C_SET_LITERAL -> "Set.literal"
(* | C_SIZE -> "Set.cardinal"*)
| C_SET_MEM -> "Set.mem"
| C_SET_ADD -> "Set.add"
| C_SET_REMOVE -> "Set.remove"
| C_SET_ITER -> "Set.iter"
| C_SET_FOLD -> "Set.fold"
(* Map module *)
| C_MAP_FIND_OPT -> "Map.find_opt"
| C_MAP_UPDATE -> "Map.update"
| C_MAP_ITER -> "Map.iter"
| C_MAP_MAP -> "Map.map"
| C_MAP_FOLD -> "Map.fold"
| C_MAP_MEM -> "Map.mem"
(* | C_SIZE -> "Map.size" *)
| C_MAP_ADD -> "Map.add"
| C_MAP_REMOVE -> "Map.remove"
| C_MAP_EMPTY -> "Map.empty"
| C_MAP_LITERAL -> "Map.literal"
(* Big_map module *)
| C_MAP_FIND -> "Big_map.find"
(* | C_MAP_FIND_OPT -> "Big_map.find_opt"
| C_MAP_UPDATE -> "Big_map.update" *)
| C_BIG_MAP_LITERAL -> "Big_map.literal"
| C_BIG_MAP_EMPTY -> "Big_map.empty"
(* | C_MAP_MEM -> "Big_map.mem"
| C_MAP_REMOVE -> "Big_map.remove"
| C_MAP_ADD -> "Big_map.add" *)
(* Bitwise module *)
| C_OR -> "Bitwise.or"
| C_AND -> "Bitwise.and"
| C_XOR -> "Bitwise.xor"
| C_LSL -> "Bitwise.shift_left"
| C_LSR -> "Bitwise.shift_right"
(* String module *)
(* | C_SIZE -> "String.length" (* will never trigger, rename size *)
| C_SLICE -> "String.sub"
| C_CONCAT -> "String.concat" *)
(* michelson pair/or type converter module *)
| C_CONVERT_TO_RIGHT_COMB -> "Layout.convert_to_right_comb"
| C_CONVERT_TO_LEFT_COMB -> "Layout.convert_to_left_comb"
| C_CONVERT_FROM_RIGHT_COMB -> "Layout.convert_from_right_comb"
| C_CONVERT_FROM_LEFT_COMB -> "Layout.convert_from_left_comb"
(* Not parsed *)
| C_SOME -> "Some"
| C_NONE -> "None"
| _ as c -> failwith @@ Format.asprintf "Constant not handled : %a" Stage_common.PP.constant c
module Pascaligo = struct
let constants = function
(* Tezos module (ex-Michelson) *)
@ -283,8 +424,46 @@ module Tree_abstraction = struct
| _ as c -> pseudo_modules c
let constant_to_string = function
(* Tezos module (ex-Michelson) *)
| C_FAILWITH -> "failwith"
| C_IS_NAT -> "is_nat"
| C_INT -> "int"
| C_ABS -> "abs"
| C_EDIV -> "ediv"
| C_UNIT -> "unit"
| C_NEG -> "NEG"
| C_ADD -> "ADD"
| C_SUB -> "SUB"
| C_MUL -> "TIMES"
| C_DIV -> "DIV"
| C_MOD -> "MOD"
| C_EQ -> "EQ"
| C_NOT -> "NOT"
| C_AND -> "AND"
| C_OR -> "OR"
| C_GT -> "GT"
| C_GE -> "GE"
| C_LT -> "LT"
| C_LE -> "LE"
| C_CONS -> "CONS"
| C_NEQ -> "NEQ"
(*-> Others *)
| C_ASSERTION -> "assert"
| C_CONVERT_TO_RIGHT_COMB -> "Layout.convert_to_right_comb"
| C_CONVERT_TO_LEFT_COMB -> "Layout.convert_to_left_comb"
| _ as c -> pseudo_module_to_string c
let type_constants = type_constants
let type_operators = type_operators
let type_constant_to_string = type_constant_to_string
let type_operator_to_string = type_operator_to_string
end
module Cameligo = struct
@ -370,8 +549,43 @@ module Tree_abstraction = struct
| _ as c -> pseudo_modules c
let constant_to_string = function
(* Tezos (ex-Michelson, ex-Current, ex-Operation) *)
| C_FAILWITH -> "failwith"
| C_IS_NAT -> "is_nat"
| C_INT -> "int"
| C_ABS -> "abs"
| C_EDIV -> "ediv"
| C_UNIT -> "unit"
| C_NEG -> "NEG"
| C_ADD -> "ADD"
| C_SUB -> "SUB"
| C_MUL -> "TIMES"
| C_DIV -> "DIV"
| C_MOD -> "MOD"
| C_EQ -> "EQ"
| C_NOT -> "NOT"
| C_AND -> "AND"
| C_OR -> "OR"
| C_GT -> "GT"
| C_GE -> "GE"
| C_LT -> "LT"
| C_LE -> "LE"
| C_CONS -> "CONS"
| C_NEQ -> "NEQ"
(* Others *)
| C_ASSERTION -> "assert"
| _ as c -> pseudo_module_to_string c
let type_constants = type_constants
let type_operators = type_operators
let type_constant_to_string = type_constant_to_string
let type_operator_to_string = type_operator_to_string
end
end

8
src/passes/predefined/predefined.mli
View File

@ -3,15 +3,21 @@ module Tree_abstraction : sig
open Ast_imperative
module Pascaligo : sig
val constants : string -> constant' option
val constants : string -> constant' option
val type_constants : string -> type_constant option
val type_operators : string -> type_operator option
val constant_to_string : constant' -> string
val type_constant_to_string : type_constant -> string
val type_operator_to_string : type_operator -> string
end
module Cameligo : sig
val constants : string -> constant' option
val type_constants : string -> type_constant option
val type_operators : string -> type_operator option
val constant_to_string : constant' -> string
val type_constant_to_string : type_constant -> string
val type_operator_to_string : type_operator -> string
end
end

7
src/stages/1-cst/cameligo/CST.ml
View File

@ -251,13 +251,13 @@ and expr =
and annot_expr = expr * colon * type_expr
and 'a injection = {
compound : compound;
compound : compound option;
elements : ('a, semi) sepseq;
terminator : semi option
}
and 'a ne_injection = {
compound : compound;
compound : compound option;
ne_elements : ('a, semi) nsepseq;
terminator : semi option
}
@ -395,8 +395,7 @@ and cond_expr = {
test : expr;
kwd_then : kwd_then;
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
ifnot : (kwd_else * expr) option;
}
(* Code injection. Note how the field [language] wraps a region in

50
src/stages/1-cst/cameligo/ParserLog.ml
View File

@ -63,6 +63,11 @@ let print_sepseq :
None -> ()
| Some seq -> print_nsepseq state sep print seq
let print_option : state -> (state -> 'a -> unit ) -> 'a option -> unit =
fun state print -> function
None -> ()
| Some opt -> print state opt
let print_csv state print {value; _} =
print_nsepseq state "," print value
@ -74,7 +79,7 @@ let print_token state region lexeme =
let print_var state {region; value} =
let line =
sprintf "%s: Ident %s\n"
(compact state region) value
(compact state region)value
in Buffer.add_string state#buffer line
let print_constr state {region; value} =
@ -244,14 +249,18 @@ and print_ne_injection :
print_close_compound state compound
and print_open_compound state = function
BeginEnd (kwd_begin,_) -> print_token state kwd_begin "begin"
| Braces (lbrace,_) -> print_token state lbrace "{"
| Brackets (lbracket,_) -> print_token state lbracket "["
None -> ()
| Some compound -> match compound with
BeginEnd (kwd_begin,_) -> print_token state kwd_begin "begin"
| Braces (lbrace,_) -> print_token state lbrace "{"
| Brackets (lbracket,_) -> print_token state lbracket "["
and print_close_compound state = function
BeginEnd (_,kwd_end) -> print_token state kwd_end "end"
| Braces (_,rbrace) -> print_token state rbrace "}"
| Brackets (_,rbracket) -> print_token state rbracket "]"
None -> ()
| Some compound -> match compound with
BeginEnd (_,kwd_end) -> print_token state kwd_end "end"
| Braces (_,rbrace) -> print_token state rbrace "}"
| Brackets (_,rbracket) -> print_token state rbracket "]"
and print_terminator state = function
Some semi -> print_token state semi ";"
@ -584,15 +593,18 @@ and print_fun_expr state {value; _} =
and print_conditional state {value; _} =
let {kwd_if; test; kwd_then;
ifso; kwd_else; ifnot} = value in
print_token state ghost "(";
print_token state kwd_if "if";
print_expr state test;
print_token state kwd_then "then";
print_expr state ifso;
print_token state kwd_else "else";
print_expr state ifnot;
print_token state ghost ")"
ifso; ifnot} = value in
print_token state ghost "(";
print_token state kwd_if "if";
print_expr state test;
print_token state kwd_then "then";
print_expr state ifso;
print_option state
(fun state (kwd_else,ifnot) ->
print_token state kwd_else "else";
print_expr state ifnot;
) ifnot;
print_token state ghost ")"
(* Conversion to string *)
@ -1114,10 +1126,12 @@ and pp_cond_expr state (cond: cond_expr) =
let state = state#pad 3 1 in
pp_node state "<true>";
pp_expr (state#pad 1 0) cond.ifso in
let () =
let () = match cond.ifnot with
Some (_, ifnot) ->
let state = state#pad 3 2 in
pp_node state "<false>";
pp_expr (state#pad 1 0) cond.ifnot
pp_expr (state#pad 1 0) ifnot
| None -> ()
in ()
and pp_case :

17
src/stages/1-cst/pascaligo/CST.ml
View File

@ -219,12 +219,17 @@ and fun_decl = {
param : parameters;
ret_type : (colon * type_expr) option;
kwd_is : kwd_is;
block_with : (block reg * kwd_with) option;
return : expr;
terminator : semi option;
attributes : attr_decl option
}
and block_with = {
block : block reg;
kwd_with : kwd_with;
expr : expr;
}
and parameters = (param_decl, semi) nsepseq par reg
and param_decl =
@ -382,15 +387,13 @@ and 'a case_clause = {
and assignment = {
lhs : lhs;
assign : assign;
rhs : rhs
rhs : expr;
}
and lhs =
Path of path
| MapPath of map_lookup reg
and rhs = expr
and loop =
While of while_loop reg
| For of for_loop
@ -465,6 +468,7 @@ and expr =
| EPar of expr par reg
| EFun of fun_expr reg
| ECodeInj of code_inj reg
| EBlock of block_with reg
and annot_expr = expr * colon * type_expr
@ -691,7 +695,8 @@ let rec expr_to_region = function
| ECond {region; _}
| EPar {region; _}
| EFun {region; _}
| ECodeInj {region; _} -> region
| ECodeInj {region; _}
| EBlock {region; _} -> region
and tuple_expr_to_region {region; _} = region
@ -809,8 +814,6 @@ let lhs_to_region : lhs -> Region.t = function
Path path -> path_to_region path
| MapPath {region; _} -> region
let rhs_to_region = expr_to_region
let selection_to_region = function
FieldName {region; _}
| Component {region; _} -> region

44
src/stages/1-cst/pascaligo/ParserLog.ml
View File

@ -218,18 +218,13 @@ and print_type_tuple state {value; _} =
and print_fun_decl state {value; _} =
let {kwd_function; fun_name; param;
ret_type; kwd_is; block_with;
ret_type; kwd_is;
return; terminator; _} = value in
print_token state kwd_function "function";
print_var state fun_name;
print_parameters state param;
print_option state print_colon_type_expr ret_type;
print_token state kwd_is "is";
(match block_with with
None -> ()
| Some (block, kwd_with) ->
print_block state block;
print_token state kwd_with "with");
print_expr state return;
print_terminator state terminator;
@ -252,6 +247,12 @@ and print_code_inj state {value; _} =
print_expr state code;
print_token state rbracket "]"
and print_block_expr state {value; _} =
let {block;kwd_with;expr} = value in
print_block state block;
print_token state kwd_with "with";
print_expr state expr;
and print_parameters state {value; _} =
let {lpar; inside; rpar} = value in
print_token state lpar "(";
@ -475,6 +476,7 @@ and print_expr state = function
| EPar e -> print_par_expr state e
| EFun e -> print_fun_expr state e
| ECodeInj e -> print_code_inj state e
| EBlock e -> print_block_expr state e
and print_annot_expr state node =
let {inside; _} : annot_expr par = node in
@ -919,11 +921,11 @@ and pp_attr_decl state = pp_ne_injection pp_string state
and pp_fun_decl state decl =
let arity, start =
match decl.kwd_recursive with
None -> 5,0
None -> 4,0
| Some _ ->
let state = state#pad 6 0 in
let state = state#pad 5 0 in
let () = pp_node state "recursive"
in 6,1 in
in 5,1 in
let () =
let state = state#pad arity start in
pp_ident state decl.fun_name in
@ -937,14 +939,6 @@ and pp_fun_decl state decl =
print_option (state#pad 1 0) pp_type_expr @@ Option.map snd decl.ret_type in
let () =
let state = state#pad arity (start + 3) in
pp_node state "<body>";
let statements =
match decl.block_with with
Some (block,_) -> block.value.statements
| None -> Instr (Skip Region.ghost), [] in
pp_statements state statements in
let () =
let state = state#pad arity (start + 4) in
pp_node state "<return>";
pp_expr (state#pad 1 0) decl.return
in ()
@ -1039,6 +1033,19 @@ and pp_code_inj state rc =
pp_expr (state#pad 1 0) rc.code
in ()
and pp_block_expr state (bw : block_with) =
let {block;expr;_}:CST.block_with = bw in
let () =
let state = state#pad 2 0 in
pp_node state "<block>";
pp_statements state block.value.statements
in
let () =
let state = state#pad 2 1 in
pp_node state "<expr>";
pp_expr (state#pad 1 0) expr in
()
and pp_parameters state {value; _} =
let params = Utils.nsepseq_to_list value.inside in
let arity = List.length params in
@ -1521,6 +1528,9 @@ and pp_expr state = function
| ECodeInj {value; region} ->
pp_loc_node state "ECodeInj" region;
pp_code_inj state value;
| EBlock {value; region} ->
pp_loc_node state "EBlock" region;
pp_block_expr state value;
and pp_list_expr state = function
ECons {value; region} ->

1
src/stages/1-cst/pascaligo/ParserLog.mli
View File

@ -19,6 +19,7 @@ val print_path : state -> CST.path -> unit
val print_pattern : state -> CST.pattern -> unit
val print_instruction : state -> CST.instruction -> unit
val print_expr : state -> CST.expr -> unit
val print_statements : state -> CST.statements -> unit
(** {1 Printing tokens from the CST in a string} *)

2
src/stages/2-ast_imperative/types.ml
View File

@ -135,7 +135,7 @@ and matching =
and ascription = {anno_expr: expression; type_annotation: type_expression}
and conditional = {
condition : expression ;
condition : expression ;
then_clause : expression ;
else_clause : expression ;
}

90
src/stages/4-ast_core/PP.ml
View File

@ -2,16 +2,96 @@
open Types
open Format
open PP_helpers
module Helpers = Stage_common.Helpers
include Stage_common.PP
include Ast_PP_type(Ast_core_parameter)
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, {ctor_type;_}) = fprintf ppf "@[<h>%a -> %a@]" constructor k value ctor_type in
fprintf ppf "%a" (list_sep new_pp sep) lst
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, {field_type;_}) = fprintf ppf "@[<h>%a -> %a@]" label k value field_type in
fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep value sep ppf m =
assert (Helpers.is_tuple_lmap m);
let lst = Helpers.tuple_of_record m in
let new_pp ppf (_, {field_type;_}) = fprintf ppf "%a" value field_type in
fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep_expr value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep_expr value sep ppf m =
assert (Helpers.is_tuple_lmap m);
let lst = Helpers.tuple_of_record m in
let new_pp ppf (_,v) = fprintf ppf "%a" value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
(* Prints records which only contain the consecutive fields
0..(cardinal-1) as tuples *)
let tuple_or_record_sep_t value format_record sep_record format_tuple sep_tuple ppf m =
if Helpers.is_tuple_lmap m then
fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m
else
fprintf ppf format_record (record_sep value (tag sep_record)) m
let tuple_or_record_sep_expr value format_record sep_record format_tuple sep_tuple ppf m =
if Helpers.is_tuple_lmap m then
fprintf ppf format_tuple (tuple_sep_expr value (tag sep_tuple)) m
else
fprintf ppf format_record (record_sep_expr value (tag sep_record)) m
let tuple_or_record_sep_expr value = tuple_or_record_sep_expr value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep_t value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
let rec type_content : formatter -> type_expression -> unit =
fun ppf te ->
match te.content with
| T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d type_expression) m
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type type_expression) m
| T_arrow a -> fprintf ppf "%a -> %a" type_expression a.type1 type_expression a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator type_expression ppf to_
and type_expression ppf (te : type_expression) : unit =
fprintf ppf "%a" type_content te
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
fun f ppf to_ ->
let s = match to_ with
TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst
| TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst
| TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst
| TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst
| TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst
| TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst
| TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst
| TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst
| TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst
| TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst
| TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst
in
fprintf ppf "(type_operator: %s)" s
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
let rec expression ppf (e : expression) =
expression_content ppf e.expression_content
expression_content ppf e.content
and expression_content ppf (ec : expression_content) =
match ec with
| E_literal l ->
@ -109,10 +189,10 @@ let declaration ppf (d : declaration) =
match d with
| Declaration_type (type_name, te) ->
fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te
| Declaration_constant (name, ty_opt, i, expr) ->
| Declaration_constant (name, ty_opt, attr, expr) ->
fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression
expr
option_inline i
option_inline attr.inline
let program ppf (p : program) =
fprintf ppf "@[<v>%a@]"

155
src/stages/4-ast_core/combinators.ml
View File

@ -3,109 +3,108 @@ module Option = Simple_utils.Option
module SMap = Map.String
let make_t ?(loc = Location.generated) type_content = {type_content; location=loc; type_meta = ()}
let make_t ?(loc = Location.generated) ?sugar content = ({content; sugar; location=loc}: type_expression)
let tuple_to_record lst =
let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in
let (_, lst ) = List.fold_left aux (0,[]) lst in
lst
let t_bool ?loc () : type_expression = make_t ?loc @@ T_variable (Stage_common.Constant.t_bool)
let t_string ?loc () : type_expression = make_t ?loc @@ T_constant (TC_string)
let t_bytes ?loc () : type_expression = make_t ?loc @@ T_constant (TC_bytes)
let t_int ?loc () : type_expression = make_t ?loc @@ T_constant (TC_int)
let t_operation ?loc () : type_expression = make_t ?loc @@ T_constant (TC_operation)
let t_nat ?loc () : type_expression = make_t ?loc @@ T_constant (TC_nat)
let t_tez ?loc () : type_expression = make_t ?loc @@ T_constant (TC_mutez)
let t_unit ?loc () : type_expression = make_t ?loc @@ T_constant (TC_unit)
let t_address ?loc () : type_expression = make_t ?loc @@ T_constant (TC_address)
let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_signature)
let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key)
let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list, [t])
let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
let t_record_ez ?loc lst =
let t_bool ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_variable (Stage_common.Constant.t_bool)
let t_string ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_string)
let t_bytes ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_bytes)
let t_int ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_int)
let t_operation ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_operation)
let t_nat ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_nat)
let t_tez ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_mutez)
let t_unit ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_unit)
let t_address ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_address)
let t_signature ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_signature)
let t_key ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_key)
let t_key_hash ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_key_hash)
let t_timestamp ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_timestamp)
let t_option ?loc ?sugar o : type_expression = make_t ?loc ?sugar @@ T_operator (TC_option, [o])
let t_list ?loc ?sugar t : type_expression = make_t ?loc ?sugar @@ T_operator (TC_list, [t])
let t_variable ?loc ?sugar n : type_expression = make_t ?loc ?sugar @@ T_variable (Var.of_name n)
let t_record_ez ?loc ?sugar lst =
let lst = List.map (fun (k, v) -> (Label k, v)) lst in
let m = LMap.of_list lst in
make_t ?loc @@ T_record m
let t_record ?loc m : type_expression =
make_t ?loc ?sugar @@ T_record m
let t_record ?loc ?sugar m : type_expression =
let lst = Map.String.to_kv_list m in
t_record_ez ?loc lst
t_record_ez ?loc ?sugar lst
let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [("0",a) ; ("1",b)]
let t_tuple ?loc lst : type_expression = t_record_ez ?loc (tuple_to_record lst)
let t_pair ?loc ?sugar (a , b) : type_expression = t_record_ez ?loc ?sugar [("0",a) ; ("1",b)]
let t_tuple ?loc ?sugar lst : type_expression = t_record_ez ?loc ?sugar (tuple_to_record lst)
let ez_t_sum ?loc (lst:(string * ctor_content) list) : type_expression =
let ez_t_sum ?loc ?sugar (lst:(string * ctor_content) list) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux CMap.empty lst in
make_t ?loc @@ T_sum map
let t_sum ?loc m : type_expression =
make_t ?loc ?sugar @@ T_sum map
let t_sum ?loc ?sugar m : type_expression =
let lst = Map.String.to_kv_list m in
ez_t_sum ?loc lst
ez_t_sum ?loc ?sugar lst
let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2}
let t_function ?loc ?sugar type1 type2 : type_expression = make_t ?loc ?sugar @@ T_arrow {type1; type2}
let t_operator ?loc ?sugar op lst : type_expression = make_t ?loc ?sugar @@ T_operator (op, lst)
let t_map ?loc ?sugar key value : type_expression = make_t ?loc ?sugar @@ T_operator (TC_map, [key; value])
let t_big_map ?loc ?sugar key value : type_expression = make_t ?loc ?sugar @@ T_operator (TC_big_map, [key; value])
let t_set ?loc ?sugar key : type_expression = make_t ?loc ?sugar @@ T_operator (TC_set, [key])
let t_contract ?loc ?sugar contract : type_expression = make_t ?loc ?sugar @@ T_operator (TC_contract, [contract])
let t_operator ?loc op lst : type_expression = make_t ?loc @@ T_operator (op, lst)
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map, [key; value])
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
let make_e ?(loc = Location.generated) ?sugar content = {content; sugar; location=loc }
let make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc }
let e_var ?loc (n: string) : expression = make_e ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = make_e ?loc @@ E_literal l
let e_unit ?loc () : expression = make_e ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_e ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_e ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_e ?loc @@ E_literal (Literal_timestamp n)
let e_string ?loc s : expression = make_e ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_e ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_e ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s)
let e_var ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_variable (Var.of_name n)
let e_literal ?loc ?sugar l : expression = make_e ?loc ?sugar @@ E_literal l
let e_unit ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_literal (Literal_unit)
let e_int ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_int n)
let e_nat ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_nat n)
let e_timestamp ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_timestamp n)
let e_string ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_string s)
let e_address ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_address s)
let e_mutez ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_mutez s)
let e_signature ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_signature s)
let e_key ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_key s)
let e_key_hash ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_chain_id s)
let e'_bytes b : expression_content =
let bytes = Hex.to_bytes (`Hex b) in
E_literal (Literal_bytes bytes)
let e_bytes_hex ?loc b : expression =
let e_bytes_hex ?loc ?sugar b : expression =
let e' = e'_bytes b in
make_e ?loc e'
let e_bytes_raw ?loc (b: bytes) : expression =
make_e ?loc @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc (s: string) : expression =
make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_some ?loc s : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_e ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_e ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
make_e ?loc ?sugar e'
let e_bytes_raw ?loc ?sugar (b: bytes) : expression =
make_e ?loc ?sugar @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc ?sugar (s: string) : expression =
make_e ?loc ?sugar @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_some ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc ?sugar sl sr : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc ?sugar k v old : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_variable ?loc v = make_e ?loc @@ E_variable v
let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
let e_lambda ?loc binder input_type output_type result = make_e ?loc @@ E_lambda {binder; input_type; output_type; result ; }
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code}
let e_constant ?loc ?sugar name lst = make_e ?loc ?sugar @@ E_constant {cons_name=name ; arguments = lst}
let e_variable ?loc ?sugar v = make_e ?loc ?sugar @@ E_variable v
let e_application ?loc ?sugar a b = make_e ?loc ?sugar @@ E_application {lamb=a ; args=b}
let e_lambda ?loc ?sugar binder input_type output_type result = make_e ?loc ?sugar @@ E_lambda {binder; input_type; output_type; result ; }
let e_recursive ?loc ?sugar fun_name fun_type lambda = make_e ?loc ?sugar @@ E_recursive {fun_name; fun_type; lambda}
let e_let_in ?loc ?sugar (binder, ascr) inline rhs let_result = make_e ?loc ?sugar @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
let e_raw_code ?loc ?sugar language code = make_e ?loc ?sugar @@ E_raw_code {language; code}
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_constructor ?loc ?sugar s a : expression = make_e ?loc ?sugar @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc ?sugar a b : expression = make_e ?loc ?sugar @@ E_matching {matchee=a;cases=b}
let e_record ?loc map = make_e ?loc @@ E_record map
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = b}
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
let e_record ?loc ?sugar map = make_e ?loc ?sugar @@ E_record map
let e_record_accessor ?loc ?sugar a b = make_e ?loc ?sugar @@ E_record_accessor {record = a; path = b}
let e_record_update ?loc ?sugar record path update = make_e ?loc ?sugar @@ E_record_update {record; path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_annotation ?loc ?sugar anno_expr ty = make_e ?loc ?sugar @@ E_ascription {anno_expr; type_annotation = ty}
let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit ())
let e_bool ?loc ?sugar b : expression = e_constructor ?loc ?sugar (string_of_bool b) (e_unit ())
let make_option_typed ?loc e t_opt =
let make_option_typed ?loc ?sugar e t_opt =
match t_opt with
| None -> e
| Some t -> e_annotation ?loc e t
| Some t -> e_annotation ?loc ?sugar e t
let e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in
@ -139,7 +138,7 @@ let get_e_list = fun t ->
let rec aux t =
match t with
E_constant {cons_name=C_CONS;arguments=[key;lst]} ->
let lst = aux lst.expression_content in
let lst = aux lst.content in
(Some key)::(lst)
| E_constant {cons_name=C_LIST_EMPTY;arguments=[]} ->
[]
@ -161,7 +160,7 @@ let get_e_ascription = fun a ->
(* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) option = fun e ->
match e.expression_content with
match e.content with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
@ -173,13 +172,13 @@ let extract_pair : expression -> (expression * expression) option = fun e ->
| _ -> None
let extract_record : expression -> (label * expression) list option = fun e ->
match e.expression_content with
match e.content with
| E_record lst -> Some (LMap.to_kv_list lst)
| _ -> None
let extract_map : expression -> (expression * expression) list option = fun e ->
let rec aux e =
match e.expression_content with
match e.content with
E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} ->
let map = aux map in
(Some (k,v))::map

132
src/stages/4-ast_core/combinators.mli
View File

@ -1,86 +1,86 @@
open Types
val make_t : ?loc:Location.t -> type_content -> type_expression
val t_bool : ?loc:Location.t -> unit -> type_expression
val t_string : ?loc:Location.t -> unit -> type_expression
val t_bytes : ?loc:Location.t -> unit -> type_expression
val t_int : ?loc:Location.t -> unit -> type_expression
val t_operation : ?loc:Location.t -> unit -> type_expression
val t_nat : ?loc:Location.t -> unit -> type_expression
val t_tez : ?loc:Location.t -> unit -> type_expression
val t_unit : ?loc:Location.t -> unit -> type_expression
val t_address : ?loc:Location.t -> unit -> type_expression
val t_key : ?loc:Location.t -> unit -> type_expression
val t_key_hash : ?loc:Location.t -> unit -> type_expression
val t_timestamp : ?loc:Location.t -> unit -> type_expression
val t_signature : ?loc:Location.t -> unit -> type_expression
val make_t : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_content -> type_expression
val t_bool : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_string : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_bytes : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_int : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_operation : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_nat : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_tez : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_unit : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_address : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_key : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_key_hash : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_timestamp : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
val t_signature : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
(*
val t_option : type_expression -> type_expression
*)
val t_list : ?loc:Location.t -> type_expression -> type_expression
val t_variable : ?loc:Location.t -> string -> type_expression
val t_list : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression
val t_variable : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> string -> type_expression
(*
val t_record : te_map -> type_expression
*)
val t_pair : ?loc:Location.t -> ( field_content * field_content ) -> type_expression
val t_tuple : ?loc:Location.t -> field_content list -> type_expression
val t_pair : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> ( field_content * field_content ) -> type_expression
val t_tuple : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> field_content list -> type_expression
val t_record : ?loc:Location.t -> field_content Map.String.t -> type_expression
val t_record_ez : ?loc:Location.t -> (string * field_content) list -> type_expression
val t_record : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> field_content Map.String.t -> type_expression
val t_record_ez : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> (string * field_content) list -> type_expression
val t_sum : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression
val t_sum : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> Types.ctor_content Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> ( string * Types.ctor_content ) list -> type_expression
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_function : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_contract : ?loc:Location.t -> type_expression -> type_expression
val t_set : ?loc:Location.t -> type_expression -> type_expression
val t_operator : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_operator -> type_expression list -> type_expression
val t_map : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression
val t_big_map : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression
val t_contract : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression
val t_set : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression
val make_e : ?loc:Location.t -> expression_content -> expression
val e_var : ?loc:Location.t -> string -> expression
val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> expression
val e_int : ?loc:Location.t -> Z.t -> expression
val e_nat : ?loc:Location.t -> Z.t -> expression
val e_timestamp : ?loc:Location.t -> Z.t -> expression
val e_bool : ?loc:Location.t -> bool -> expression
val e_string : ?loc:Location.t -> ligo_string -> expression
val e_address : ?loc:Location.t -> string -> expression
val e_signature : ?loc:Location.t -> string -> expression
val e_key : ?loc:Location.t -> string -> expression
val e_key_hash : ?loc:Location.t -> string -> expression
val e_chain_id : ?loc:Location.t -> string -> expression
val e_mutez : ?loc:Location.t -> Z.t -> expression
val e'_bytes : string -> expression_content
val e_bytes_hex : ?loc:Location.t -> string -> expression
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
val e_bytes_string : ?loc:Location.t -> string -> expression
val make_e : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_content -> expression
val e_var : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_literal : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> literal -> expression
val e_unit : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> unit -> expression
val e_int : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
val e_nat : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
val e_timestamp : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
val e_bool : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> bool -> expression
val e_string : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> ligo_string -> expression
val e_address : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_signature : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_key : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_key_hash : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_chain_id : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_mutez : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
val e'_bytes : string -> expression_content
val e_bytes_hex : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_bytes_raw : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> bytes -> expression
val e_bytes_string : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
val e_some : ?loc:Location.t -> expression -> expression
val e_none : ?loc:Location.t -> unit -> expression
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
val e_raw_code : ?loc:Location.t -> string -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_some : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression
val e_none : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> unit -> expression
val e_string_cat : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression
val e_map_add : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -> expression
val e_matching : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> matching_expr -> expression
val e_record_accessor : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> label -> expression
val e_variable : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> expression
val e_let_in : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
val e_raw_code : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -> expression
val e_annotation : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> constant' -> expression list -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val make_option_typed : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> type_expression option -> expression
val e_typed_none : ?loc:Location.t -> type_expression -> expression
val e_typed_none : ?loc:Location.t -> type_expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
val e_record : ?loc:Location.t -> expr label_map-> expression
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
val e_lambda : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> type_expression -> lambda -> expression
val e_record : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expr label_map-> expression
val e_record_update : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> label -> expression -> expression
val assert_e_record_accessor : expression_content -> unit option

1
src/stages/4-ast_core/dune
View File

@ -5,6 +5,7 @@
simple-utils
tezos-utils
stage_common
ast_sugar
)
(preprocess
(pps ppx_let bisect_ppx --conditional)

2
src/stages/4-ast_core/misc.ml
View File

@ -97,7 +97,7 @@ let assert_literal_eq (a, b : literal * literal) : unit option =
| Literal_chain_id _, _ -> None
let rec assert_value_eq (a, b: (expression * expression )) : unit option =
match (a.expression_content , b.expression_content) with
match (a.content , b.content) with
| E_literal a , E_literal b ->
assert_literal_eq (a, b)
| E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (

39
src/stages/4-ast_core/types.ml
View File

@ -2,15 +2,11 @@
module Location = Simple_utils.Location
module Ast_core_parameter = struct
type type_meta = unit
end
include Stage_common.Types
include Ast_generic_type (Ast_core_parameter)
type inline = bool
type attribute = {
inline: bool
}
type program = declaration Location.wrap list
and declaration =
| Declaration_type of (type_variable * type_expression)
@ -20,10 +16,35 @@ and declaration =
* an optional type annotation
* a boolean indicating whether it should be inlined
* an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
| Declaration_constant of (expression_variable * type_expression option * attribute * expression)
(* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t}
and type_content =
| T_sum of ctor_content constructor_map
| T_record of field_content label_map
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of (type_operator * type_expression list)
and arrow = {type1: type_expression; type2: type_expression}
and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int}
and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int}
and type_expression = {
content : type_content;
sugar : Ast_sugar.type_expression option;
location : Location.t;
}
and expression = {
content : expression_content;
sugar : Ast_sugar.expression option;
location : Location.t
}
and expression_content =
(* Base *)

1
src/stages/common/types.ml
View File

@ -52,7 +52,6 @@ end
module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
open PARAMETER
type michelson_annotation = string
type type_content =
| T_sum of ctor_content constructor_map

2
src/stages/ligo_interpreter/PP.ml
View File

@ -34,7 +34,7 @@ let rec pp_value : value -> string = function
let pp_env : env -> unit = fun env ->
let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in
let () = Env.iter (fun var v ->
Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v))
Format.printf "\t%a -> %s\n" Var.pp var (pp_value v))
env in
let () = Format.printf "\n}\n" in
()

6
src/stages/typesystem/misc.ml
View File

@ -96,9 +96,9 @@ module Substitution = struct
| Ast_core.T_constant constant ->
ok @@ Ast_core.T_constant constant
and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {type_content;location;type_meta} ->
let%bind type_content = s_abstr_type_content ~substs type_content in
ok @@ Ast_core.{type_content;location;type_meta}
and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {content;sugar;location} ->
let%bind content = s_abstr_type_content ~substs content in
ok @@ (Ast_core.{content;sugar;location} : Ast_core.type_expression)
and s_type_expression : (T.type_expression,_) w = fun ~substs { type_content; location; type_meta } ->
let%bind type_content = s_type_content ~substs type_content in

4
src/test/coase_tests.ml
View File

@ -221,10 +221,10 @@ let sell () =
in
let make_expecter : int -> Ast_core.expression -> (unit,_) result = fun n result ->
let%bind (ops , storage) = trace_option (test_internal __LOC__) @@
Ast_core.get_e_pair result.expression_content in
Ast_core.get_e_pair result.content in
let%bind () =
let%bind lst = trace_option (test_internal __LOC__) @@
Ast_core.get_e_list ops.expression_content in
Ast_core.get_e_list ops.content in
Assert.assert_list_size (test_internal __LOC__) lst 1 in
let expected_storage =
let cards = List.hds @@ cards_ez first_owner n in

6
src/test/contracts/expected/FA1.2.ligo.expected
View File

@ -31,10 +31,8 @@ type getBalance is
type getTotalSupply is record [callback : contract (nat)]
type action is
Transfer of transfer
| Approve of approve
| GetAllowance of getAllowance
| GetBalance of getBalance
Transfer of transfer | Approve of approve
| GetAllowance of getAllowance | GetBalance of getBalance
| GetTotalSupply of getTotalSupply
function transfer (const p : transfer; const s : storage)

122
src/test/contracts/expected/FA1.2.mligo.expected
View File

@ -24,10 +24,8 @@ type getBalance = {owner : address; callback : nat contract}
type getTotalSupply = {callback : nat contract}
type action =
Transfer of transfer
| Approve of approve
| GetAllowance of getAllowance
| GetBalance of getBalance
Transfer of transfer | Approve of approve
| GetAllowance of getAllowance | GetBalance of getBalance
| GetTotalSupply of getTotalSupply
let transfer (p, s : transfer * storage)
@ -42,42 +40,40 @@ let transfer (p, s : transfer * storage)
s.allowances
with
Some value -> value
| None -> 0n
in if (authorized_value < p.value)
then (failwith "Not Enough Allowance" : allowances)
else
Big_map.update
(Tezos.sender, p.address_from)
(Some (abs (authorized_value - p.value)))
s.allowances
in let sender_balance =
match Big_map.find_opt p.address_from s.tokens with
Some value -> value
| None -> 0n
in if (sender_balance < p.value)
then
(failwith "Not Enough Balance"
: operation list * storage)
else
let new_tokens =
Big_map.update
p.address_from
(Some (abs (sender_balance - p.value)))
s.tokens
in let receiver_balance =
match Big_map.find_opt p.address_to s.tokens
with
Some value -> value
| None -> 0n
in let new_tokens =
Big_map.update
p.address_to
(Some (receiver_balance + p.value))
new_tokens
in ([] : operation list),
{s with
tokens = new_tokens;
allowances = new_allowances}
| None -> 0n in
if (authorized_value < p.value)
then (failwith "Not Enough Allowance" : allowances)
else
Big_map.update
(Tezos.sender, p.address_from)
(Some (abs (authorized_value - p.value)))
s.allowances in
let sender_balance =
match Big_map.find_opt p.address_from s.tokens with
Some value -> value
| None -> 0n in
if (sender_balance < p.value)
then
(failwith "Not Enough Balance"
: operation list * storage)
else
let new_tokens =
Big_map.update
p.address_from
(Some (abs (sender_balance - p.value)))
s.tokens in
let receiver_balance =
match Big_map.find_opt p.address_to s.tokens with
Some value -> value
| None -> 0n in
let new_tokens =
Big_map.update
p.address_to
(Some (receiver_balance + p.value))
new_tokens in
([] : operation list),
{s with
tokens = new_tokens; allowances = new_allowances}
let approve (p, s : approve * storage)
: operation list * storage =
@ -87,20 +83,20 @@ let approve (p, s : approve * storage)
s.allowances
with
Some value -> value
| None -> 0n
in if previous_value > 0n && p.value > 0n
then
(failwith "Unsafe Allowance Change"
: operation list * storage)
else
let new_allowances =
Big_map.update
(p.spender, Tezos.sender)
(Some (p.value))
s.allowances
in ([] : operation list),
{s with
allowances = new_allowances}
| None -> 0n in
if previous_value > 0n && p.value > 0n
then
(failwith "Unsafe Allowance Change"
: operation list * storage)
else
let new_allowances =
Big_map.update
(p.spender, Tezos.sender)
(Some (p.value))
s.allowances in
([] : operation list),
{s with
allowances = new_allowances}
let getAllowance (p, s : getAllowance * storage)
: operation list * storage =
@ -108,24 +104,24 @@ let getAllowance (p, s : getAllowance * storage)
match Big_map.find_opt (p.owner, p.spender) s.allowances
with
Some value -> value
| None -> 0n
in let op = Tezos.transaction value 0mutez p.callback
in ([op], s)
| None -> 0n in
let op = Tezos.transaction value 0mutez p.callback in
([op], s)
let getBalance (p, s : getBalance * storage)
: operation list * storage =
let value =
match Big_map.find_opt p.owner s.tokens with
Some value -> value
| None -> 0n
in let op = Tezos.transaction value 0mutez p.callback
in ([op], s)
| None -> 0n in
let op = Tezos.transaction value 0mutez p.callback in
([op], s)
let getTotalSupply (p, s : getTotalSupply * storage)
: operation list * storage =
let total = s.total_amount
in let op = Tezos.transaction total 0mutez p.callback
in ([op], s)
let total = s.total_amount in
let op = Tezos.transaction total 0mutez p.callback in
([op], s)
let main (a, s : action * storage) =
match a with

4
src/test/contracts/expected/address.mligo.expected
View File

@ -1,3 +1,3 @@
let main (p : key_hash) =
let c : unit contract = Tezos.implicit_account p
in Tezos.address c
let c : unit contract = Tezos.implicit_account p in
Tezos.address c

4
src/test/contracts/expected/amount_lambda.mligo.expected
View File

@ -1,6 +1,6 @@
let f1 (x : unit) : unit -> tez =
let amt : tez = Current.amount
in fun (x : unit) -> amt
let amt : tez = Current.amount in
fun (x : unit) -> amt
let f2 (x : unit) : unit -> tez =
fun (x : unit) -> Current.amount

4
src/test/contracts/expected/assert.mligo.expected
View File

@ -1,3 +1,3 @@
let main (p, s : bool * unit) =
let u : unit = assert p
in ([] : operation list), s
let u : unit = assert p in
([] : operation list), s

8
src/test/contracts/expected/attributes.mligo.expected
View File

@ -1,8 +1,8 @@
let x = 1 [@@inline]
let foo (a : int) : int =
(let test = 2 + a [@@inline]
in test) [@@inline]
(let test = 2 + a [@@inline] in
test) [@@inline]
let y = 1 [@@inline][@@other]
@ -10,5 +10,5 @@ let bar (b : int) : int =
let test = fun (z : int) -> 2 + b + z
[@@inline]
[@@foo]
[@@bar]
in test b
[@@bar] in
test b

4
src/test/contracts/expected/big_map.mligo.expected
View File

@ -18,5 +18,5 @@ let map1 : foo = Big_map.literal [(23, 0); (42, 0)]
let map1 : foo = Big_map.literal [(23, 0); (42, 0)]
let mutimaps (m : foo) (n : foo) : foo =
let bar : foo = Big_map.update 42 (Some 0) m
in Big_map.update 42 (get bar) n
let bar : foo = Big_map.update 42 (Some 0) m in
Big_map.update 42 (get bar) n

12
src/test/contracts/expected/bytes_unpack.mligo.expected
View File

@ -1,11 +1,11 @@
let id_string (p : string) : string option =
let packed : bytes = Bytes.pack p
in (Bytes.unpack packed : string option)
let packed : bytes = Bytes.pack p in
(Bytes.unpack packed : string option)
let id_int (p : int) : int option =
let packed : bytes = Bytes.pack p
in (Bytes.unpack packed : int option)
let packed : bytes = Bytes.pack p in
(Bytes.unpack packed : int option)
let id_address (p : address) : address option =
let packed : bytes = Bytes.pack p
in (Bytes.unpack packed : address option)
let packed : bytes = Bytes.pack p in
(Bytes.unpack packed : address option)

8
src/test/contracts/expected/closure.mligo.expected
View File

@ -1,5 +1,5 @@
let test (k : int) : int =
let j : int = k + 5
in let close : int -> int = fun (i : int) -> i + j
in let j : int = 20
in close 20
let j : int = k + 5 in
let close : int -> int = fun (i : int) -> i + j in
let j : int = 20 in
close 20

16
src/test/contracts/expected/condition-shadowing.mligo.expected
View File

@ -1,9 +1,9 @@
let main (i : int) =
let result = 0
in if i = 2
then
let result = 42
in result
else
let result = 0
in result
let result = 0 in
if i = 2
then
let result = 42 in
result
else
let result = 0 in
result

4
src/test/contracts/expected/create_contract.mligo.expected
View File

@ -7,5 +7,5 @@ let main (action, store : string * string) : return =
(([] : operation list), "one"))
(None : key_hash option)
300000000mutez
"un"
in ([toto.0], store)
"un" in
([toto.0], store)

6
src/test/contracts/expected/double_michelson_or.mligo.expected
View File

@ -5,6 +5,6 @@ type foobar = (int, "baz", int, "fooo") michelson_or
type return = operation list * storage
let main (action, store : unit * storage) : return =
let foo = (M_right ("one") : storage)
in let bar = (M_right 1 : foobar)
in (([] : operation list), (foo : storage))
let foo = (M_right ("one") : storage) in
let bar = (M_right 1 : foobar) in
(([] : operation list), (foo : storage))

4
src/test/contracts/expected/fibo.mligo.expected
View File

@ -9,5 +9,5 @@ let main (p, store : unit * storage)
f (y, x))
(fun (x : int) (y : int) -> x + y)
0
1
in ([] : operation list), store
1 in
([] : operation list), store

4
src/test/contracts/expected/fibo2.mligo.expected
View File

@ -6,5 +6,5 @@ let main (p, store : unit * storage)
(fun (f : int -> int) (z : int) (y : int) -> f y)
(fun (x : int) -> x)
0
1
in ([] : operation list), store
1 in
([] : operation list), store

4
src/test/contracts/expected/fibo3.mligo.expected
View File

@ -8,5 +8,5 @@ let main (p, s : unit * storage) : operation list * storage =
f y (x + y))
(fun (x : int) (y : int) -> x + y)
0
1
in ([] : operation list), store
1 in
([] : operation list), store

10
src/test/contracts/expected/guess_string.mligo.expected
View File

@ -10,8 +10,8 @@ let attempt (p, store : param * storage) : return =
: unit contract option)
with
Some contract -> contract
| None -> (failwith "No contract" : unit contract)
in let transfer : operation =
Tezos.transaction (unit, contract, 10000000mutez)
in let store : storage = {challenge = p.new_challenge}
in ([] : operation list), store
| None -> (failwith "No contract" : unit contract) in
let transfer : operation =
Tezos.transaction (unit, contract, 10000000mutez) in
let store : storage = {challenge = p.new_challenge} in
([] : operation list), store

6
src/test/contracts/expected/id.ligo.expected
View File

@ -23,10 +23,8 @@ type update_details is
]
type action is
Buy of buy
| Update_owner of update_owner
| Update_details of update_details
| Skip of unit
Buy of buy | Update_owner of update_owner
| Update_details of update_details | Skip of unit
type storage is
record [

3
src/test/contracts/expected/multisig-v2.ligo.expected
View File

@ -34,8 +34,7 @@ type default_pt is unit
type return is list (operation) * storage
type parameter is
Send of send_pt
| Withdraw of withdraw_pt
Send of send_pt | Withdraw of withdraw_pt
| Default of default_pt
function send (const param : send_pt; const s : storage)

3
src/test/contracts/expected/time-lock.ligo.expected
View File

@ -9,8 +9,7 @@ type call_pt is message_t
type contract_return_t is list (operation) * storage_t
type entry_point_t is
Call of call_pt
| Default of default_pt
Call of call_pt | Default of default_pt
function call (const p : call_pt; const s : storage_t)
: contract_return_t is

4
src/test/integration_tests.ml
View File

@ -2096,9 +2096,9 @@ let get_contract_ligo () : (unit, _) result =
let%bind () =
let make_input = fun _n -> e_unit () in
let make_expected : int -> Ast_core.expression -> (unit, _) result = fun _n result ->
let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.expression_content in
let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.content in
let%bind () =
let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.expression_content in
let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.content in
Assert.assert_list_size (test_internal __LOC__) lst 1 in
let expected_storage = Ast_core.e_unit () in
trace_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (expected_storage , storage)

4
src/test/test_helpers.ml
View File

@ -112,7 +112,7 @@ let run_typed_program_with_imperative_input ?options
(input: Ast_imperative.expression) : (Ast_core.expression, _) result =
let%bind michelson_program = typed_program_with_imperative_input_to_michelson (program , state) entry_point input in
let%bind michelson_output = Ligo.Run.Of_michelson.run_no_failwith ?options michelson_program.expr michelson_program.expr_ty in
let%bind res = Uncompile.uncompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in
let%bind res = Decompile.Of_michelson.decompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in
match res with
| Runned_result.Success exp -> ok exp
| Runned_result.Fail _ -> fail test_not_expected_to_fail
@ -155,7 +155,7 @@ let expect_evaluate (program, _state) entry_point expecter =
let%bind (exp,_) = trace_option unknown @@ Mini_c.get_entry mini_c entry_point in
let%bind michelson_value = Ligo.Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind res_michelson = Ligo.Run.Of_michelson.run_no_failwith michelson_value.expr michelson_value.expr_ty in
let%bind res = Uncompile.uncompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in
let%bind res = Decompile.Of_michelson.decompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in
let%bind res' = match res with
| Runned_result.Success exp -> ok exp
| Runned_result.Fail _ -> fail test_not_expected_to_fail in

4
src/test/time_lock_repeat_tests.ml
View File

@ -54,7 +54,7 @@ let early_call () =
expect_string_failwith ~options (program, state) "main"
(e_pair (e_unit ()) init_storage) exp_failwith
let fake_uncompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]"
let fake_decompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]"
(* Test that when we use the contract the next use time advances by correct interval *)
let interval_advance () =
@ -64,7 +64,7 @@ let interval_advance () =
let init_storage = storage lock_time 86400 empty_message in
(* It takes a second for Tezos.now to be called, awful hack *)
let%bind new_timestamp = mk_time "2000-01-02T10:10:11Z" in
let new_storage_fake = storage new_timestamp 86400 fake_uncompiled_empty_message in
let new_storage_fake = storage new_timestamp 86400 fake_decompiled_empty_message in
let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in
expect_eq ~options (program, state) "main"

4
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -345,6 +345,10 @@ let trace_assert_fail_option error = function
[let%bind lst' = bind_map_list f lst]. Same thing with folds.
*)
let bind_compose f g x =
let%bind y = g x in
f y
let bind_map_option f = function
None -> ok None
| Some s -> f s >>? fun x -> ok (Some x)

1
vendors/ligo-utils/simple-utils/x_list.ml vendored
View File

@ -216,5 +216,6 @@ module Ne = struct
match f hd with
| Some x -> Some x
| None -> find_map f tl
let append : 'a t -> 'a t -> 'a t = fun (hd, tl) (hd', tl') -> hd, List.append tl @@ hd' :: tl'
end