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

Merge branch 'ast/ast_imperative+sugar' into 'dev'

Browse Source 
Adding two new stages 'Ast_imperative' and 'Ast_complex' to improve architecture

See merge request ligolang/ligo!501
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-03-18 18:08:58 +00:00
commit 926a83f7df
151 changed files with 3754 additions and 785 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gitlab-pages/docs/contributors/big-picture/front-end.md
View File

@ -10,6 +10,6 @@ Its files are in `parser/parser_name`.
## Concrete Syntax Tree ## Concrete Syntax Tree
The CST is the aforementioned structured representation of the program. Is is structurally very close to the source code, and is mostly an intermediary there because manipulating string is not practical. The CST is the aforementioned structured representation of the program. Is is structurally very close to the source code, and is mostly an intermediary there because manipulating string is not practical.
Its files are in `parser/parser_name`. Its files are in `parser/parser_name`.
## Simplifier ## Sugar_to_core
A Simplifier is a function that takes a CST and outputs the corresponding Common AST. This is the actual bridge between a given syntax and LIGO. A Sugar_to_core is a function that takes a CST and outputs the corresponding Common AST. This is the actual bridge between a given syntax and LIGO.
Its files are in `simplify/parser_name`. Its files are in `simplify/parser_name`.

2
gitlab-pages/docs/contributors/big-picture/middle-end.md
View File

@ -6,7 +6,7 @@ title: Middle End
The Middle-End is the core of LIGO. It is also composed of three parts. The Middle-End is the core of LIGO. It is also composed of three parts.
## Common AST ## Common AST
The Common AST is the closest thing to what could be called “LIGO lang”. As such, it should be as simple as possible. Collapsing particular cases in more general constructs is encouraged. Documenting it is crucial for people who’ll write new parsers or editor support for Front-end related things. The Common AST is the closest thing to what could be called “LIGO lang”. As such, it should be as simple as possible. Collapsing particular cases in more general constructs is encouraged. Documenting it is crucial for people who’ll write new parsers or editor support for Front-end related things.
Its files are in `ast_simplified/`, of interest is the definition of the AST itself in `ast_simplified/types.ml`. Its files are in `ast_core/`, of interest is the definition of the AST itself in `ast_core/types.ml`.
## Type Checker ## Type Checker
The Type Checker, among other things, checks that a given AST is valid with regard to type-safety. It also annotates expressions with their types, free-variables and local environments. The Type Checker, among other things, checks that a given AST is valid with regard to type-safety. It also annotates expressions with their types, free-variables and local environments.
As time passes, we want to make the type-system stronger, to encode arbitrarily complex properties in an extensible manner. As time passes, we want to make the type-system stronger, to encode arbitrarily complex properties in an extensible manner.

2
gitlab-pages/docs/contributors/ligo_test_guide.md
View File

@ -102,7 +102,7 @@ What's going on is similar to the last program: `expect_eq_evaluate` runs a prog
For example, once the program stops running the value of `address` is `"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"`. The *comparison*, however, is made to a constructed expression. For example, once the program stops running the value of `address` is `"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"`. The *comparison*, however, is made to a constructed expression.
Remember that we're testing from OCaml, but the program is written and evaluated as LIGO. In order to provide a proper comparison, we convert our expected test values into LIGO expressions and data. Constructors such as `e_list` and `e_address` provide a bridge between LIGO and OCaml. Their definitions can be found in files such as [src/stages/ast_simplified/combinators.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/stages/ast_simplified/combinators.ml), or using [Merlin's definition point finder](https://github.com/ocaml/merlin/wiki). These same functions are used during the simplification stage of LIGO compilation, so becoming familiar with them will help prepare you to work on the [front end](contributors/big-picture/front-end/). Remember that we're testing from OCaml, but the program is written and evaluated as LIGO. In order to provide a proper comparison, we convert our expected test values into LIGO expressions and data. Constructors such as `e_list` and `e_address` provide a bridge between LIGO and OCaml. Their definitions can be found in files such as [src/stages/ast_core/combinators.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/stages/ast_core/combinators.ml), or using [Merlin's definition point finder](https://github.com/ocaml/merlin/wiki). These same functions are used during the simplification stage of LIGO compilation, so becoming familiar with them will help prepare you to work on the [front end](contributors/big-picture/front-end/).
## How To Write A Test For LIGO ## How To Write A Test For LIGO

94
src/bin/cli.ml
View File

@ -140,8 +140,7 @@ module Run = Ligo.Run.Of_michelson
let compile_file = let compile_file =
let f source_file entry_point syntax display_format disable_typecheck michelson_format = let f source_file entry_point syntax display_format disable_typecheck michelson_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed,_ = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in
let%bind mini_c = Compile.Of_typed.compile typed in let%bind mini_c = Compile.Of_typed.compile typed in
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
let%bind contract = Compile.Of_michelson.build_contract ~disable_typecheck michelson in let%bind contract = Compile.Of_michelson.build_contract ~disable_typecheck michelson in
@ -168,8 +167,8 @@ let print_cst =
let print_ast = let print_ast =
let f source_file syntax display_format = ( let f source_file syntax display_format = (
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind core = Compile.Utils.to_core source_file syntax in
ok @@ Format.asprintf "%a\n" Compile.Of_simplified.pretty_print simplified ok @@ Format.asprintf "%a\n" Compile.Of_core.pretty_print core
) )
in in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
@ -180,8 +179,7 @@ let print_ast =
let print_typed_ast = let print_typed_ast =
let f source_file syntax display_format = ( let f source_file syntax display_format = (
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind typed,_ = Compile.Of_simplified.compile Env simplified in
ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed
) )
in in
@ -193,8 +191,7 @@ let print_typed_ast =
let print_mini_c = let print_mini_c =
let f source_file syntax display_format = ( let f source_file syntax display_format = (
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind typed,_ = Compile.Of_simplified.compile Env simplified in
let%bind mini_c = Compile.Of_typed.compile typed in let%bind mini_c = Compile.Of_typed.compile typed in
ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c
) )
@ -207,11 +204,7 @@ let print_mini_c =
let measure_contract = let measure_contract =
let f source_file entry_point syntax display_format = let f source_file entry_point syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind contract = Compile.Utils.compile_file source_file syntax entry_point in
let%bind typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in
let%bind mini_c = Compile.Of_typed.compile typed in
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
let%bind contract = Compile.Of_michelson.build_contract michelson in
let open Tezos_utils in let open Tezos_utils in
ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract) ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract)
in in
@ -224,8 +217,7 @@ let measure_contract =
let compile_parameter = let compile_parameter =
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment typed_prg in
@ -233,9 +225,7 @@ let compile_parameter =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state in
let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in
let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in
let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in
let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
let%bind () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in let%bind () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
@ -255,16 +245,13 @@ let interpret =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind (decl_list,state,env) = match init_file with let%bind (decl_list,state,env) = match init_file with
| Some init_file -> | Some init_file ->
let%bind simplified = Compile.Of_source.compile init_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment typed_prg in
ok (mini_c_prg,state,env) ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Ast_typed.Environment.full_empty) in | None -> ok ([],Typer.Solver.initial_state,Ast_typed.Environment.full_empty) in
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) init_file in let%bind (typed_exp,_) = Compile.Utils.type_expression init_file syntax expression env state in
let%bind simplified_exp = Compile.Of_source.compile_expression v_syntax expression in
let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in
let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in
let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in 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 options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
@ -274,8 +261,8 @@ let interpret =
let%bind failstring = Run.failwith_to_string fail_res in let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring ok @@ Format.asprintf "%s" failstring
| Success value' -> | Success value' ->
let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_expression value' in let%bind core_output = Uncompile.uncompile_expression typed_exp.type_expression value' in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in in
let term = let term =
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
@ -286,8 +273,7 @@ let interpret =
let temp_ligo_interpreter = let temp_ligo_interpreter =
let f source_file syntax display_format = let f source_file syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind typed,_ = Compile.Of_simplified.compile Env simplified in
let%bind res = Compile.Of_typed.some_interpret typed in let%bind res = Compile.Of_typed.some_interpret typed in
ok @@ Format.asprintf "%s\n" res ok @@ Format.asprintf "%s\n" res
in in
@ -300,8 +286,7 @@ let temp_ligo_interpreter =
let compile_storage = let compile_storage =
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment typed_prg in
@ -309,9 +294,7 @@ let compile_storage =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state in
let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in
let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in
let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in
let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
let%bind () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in let%bind () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
@ -329,8 +312,7 @@ let compile_storage =
let dry_run = let dry_run =
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
@ -338,11 +320,7 @@ let dry_run =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind compiled_params = Compile.Utils.compile_storage storage input source_file syntax env state mini_c_prg in
let%bind simplified = Compile.Of_source.compile_contract_input storage input v_syntax in
let%bind typed,_ = Compile.Of_simplified.compile_expression ~env ~state simplified in
let%bind mini_c = Compile.Of_typed.compile_expression typed in
let%bind compiled_params = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c in
let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
@ -352,8 +330,8 @@ let dry_run =
let%bind failstring = Run.failwith_to_string fail_res in let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring ok @@ Format.asprintf "%s" failstring
| Success michelson_output -> | Success michelson_output ->
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in in
let term = 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 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
@ -364,16 +342,17 @@ let dry_run =
let run_function = let run_function =
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in
let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified_prg in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind simplified_param = Compile.Of_source.compile_expression v_syntax parameter in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
let%bind app = Compile.Of_simplified.apply entry_point simplified_param in let%bind imperative_param = Compile.Of_source.compile_expression v_syntax parameter in
let%bind (typed_app,_) = Compile.Of_simplified.compile_expression ~env ~state app in let%bind sugar_param = Compile.Of_imperative.compile_expression imperative_param in
let%bind core_param = Compile.Of_sugar.compile_expression sugar_param in
let%bind app = Compile.Of_core.apply entry_point core_param in
let%bind (typed_app,_) = Compile.Of_core.compile_expression ~env ~state app in
let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
@ -384,8 +363,8 @@ let run_function =
let%bind failstring = Run.failwith_to_string fail_res in let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring ok @@ Format.asprintf "%s" failstring
| Success michelson_output -> | Success michelson_output ->
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@ -396,15 +375,14 @@ let run_function =
let evaluate_value = let evaluate_value =
let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
let%bind typed_prg,_ = Compile.Of_simplified.compile Env simplified in
let%bind mini_c = Compile.Of_typed.compile typed_prg in let%bind mini_c = Compile.Of_typed.compile typed_prg in
let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in let%bind (exp,_) = 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 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 options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in let%bind core_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@ -415,13 +393,9 @@ let evaluate_value =
let compile_expression = let compile_expression =
let f expression syntax display_format michelson_format = let f expression syntax display_format michelson_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (None) in
let env = Ast_typed.Environment.full_empty in let env = Ast_typed.Environment.full_empty in
let state = Typer.Solver.initial_state in let state = Typer.Solver.initial_state in
let%bind simplified = Compile.Of_source.compile_expression v_syntax expression in let%bind compiled_exp = Compile.Utils.compile_expression None syntax expression env state in
let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified in
let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in
let%bind compiled_exp = Compile.Of_mini_c.compile_expression mini_c_exp in
let%bind value = Run.evaluate_expression compiled_exp.expr compiled_exp.expr_ty in let%bind value = Run.evaluate_expression compiled_exp.expr compiled_exp.expr_ty in
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
in in
@ -442,8 +416,8 @@ let dump_changelog =
let list_declarations = let list_declarations =
let f source_file syntax = let f source_file syntax =
toplevel ~display_format:(`Human_readable) @@ toplevel ~display_format:(`Human_readable) @@
let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind core_prg = Compile.Utils.to_core source_file syntax in
let json_decl = List.map (fun decl -> `String decl) @@ Compile.Of_simplified.list_declarations simplified_prg in let json_decl = List.map (fun decl -> `String decl) @@ Compile.Of_core.list_declarations core_prg in
ok @@ J.to_string @@ `Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ] ok @@ J.to_string @@ `Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ]
in in
let term = let term =

4
src/bin/expect_tests/contract_tests.ml
View File

@ -1174,7 +1174,7 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#812 = #P in let p = rhs#812.0 in let s = rhs#812.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#654 = #P in let p = rhs#654.0 in let s = rhs#654.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -1187,7 +1187,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#815 = #P in let p = rhs#815.0 in let s = rhs#815.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#657 = #P in let p = rhs#657.0 in let s = rhs#657.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can

14
src/main/compile/dune
View File

@ -5,14 +5,20 @@
simple-utils simple-utils
tezos-utils tezos-utils
parser parser
simplify concrete_to_imperative
interpreter ast_imperative
ast_simplified self_ast_imperative
self_ast_simplified imperative_to_sugar
ast_sugar
self_ast_sugar
sugar_to_core
ast_core
self_ast_core
typer_new typer_new
typer typer
ast_typed ast_typed
self_ast_typed self_ast_typed
interpreter
transpiler transpiler
mini_c mini_c
self_mini_c self_mini_c

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

@ -23,55 +23,55 @@ let parsify_pascaligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.Pascaligo.parse_file source in Parser.Pascaligo.parse_file source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying") @@ trace (simple_error "abstracting") @@
Simplify.Pascaligo.simpl_program raw Concrete_to_imperative.Pascaligo.compile_program raw
in ok simplified in ok imperative
let parsify_expression_pascaligo source = let parsify_expression_pascaligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing expression") @@ trace (simple_error "parsing expression") @@
Parser.Pascaligo.parse_expression source in Parser.Pascaligo.parse_expression source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying expression") @@ trace (simple_error "abstracting expression") @@
Simplify.Pascaligo.simpl_expression raw Concrete_to_imperative.Pascaligo.compile_expression raw
in ok simplified in ok imperative
let parsify_cameligo source = let parsify_cameligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.Cameligo.parse_file source in Parser.Cameligo.parse_file source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying") @@ trace (simple_error "abstracting") @@
Simplify.Cameligo.simpl_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok simplified in ok imperative
let parsify_expression_cameligo source = let parsify_expression_cameligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing expression") @@ trace (simple_error "parsing expression") @@
Parser.Cameligo.parse_expression source in Parser.Cameligo.parse_expression source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying expression") @@ trace (simple_error "abstracting expression") @@
Simplify.Cameligo.simpl_expression raw Concrete_to_imperative.Cameligo.compile_expression raw
in ok simplified in ok imperative
let parsify_reasonligo source = let parsify_reasonligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.Reasonligo.parse_file source in Parser.Reasonligo.parse_file source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying") @@ trace (simple_error "abstracting") @@
Simplify.Cameligo.simpl_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok simplified in ok imperative
let parsify_expression_reasonligo source = let parsify_expression_reasonligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing expression") @@ trace (simple_error "parsing expression") @@
Parser.Reasonligo.parse_expression source in Parser.Reasonligo.parse_expression source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying expression") @@ trace (simple_error "abstracting expression") @@
Simplify.Cameligo.simpl_expression raw Concrete_to_imperative.Cameligo.compile_expression raw
in ok simplified in ok imperative
let parsify syntax source = let parsify syntax source =
let%bind parsify = let%bind parsify =
@ -80,7 +80,7 @@ let parsify syntax source =
| CameLIGO -> ok parsify_cameligo | CameLIGO -> ok parsify_cameligo
| ReasonLIGO -> ok parsify_reasonligo in | ReasonLIGO -> ok parsify_reasonligo in
let%bind parsified = parsify source in let%bind parsified = parsify source in
let%bind applied = Self_ast_simplified.all_program parsified let%bind applied = Self_ast_imperative.all_program parsified
in ok applied in ok applied
let parsify_expression syntax source = let parsify_expression syntax source =
@ -89,35 +89,35 @@ let parsify_expression syntax source =
| CameLIGO -> ok parsify_expression_cameligo | CameLIGO -> ok parsify_expression_cameligo
| ReasonLIGO -> ok parsify_expression_reasonligo in | ReasonLIGO -> ok parsify_expression_reasonligo in
let%bind parsified = parsify source in let%bind parsified = parsify source in
let%bind applied = Self_ast_simplified.all_expression parsified let%bind applied = Self_ast_imperative.all_expression parsified
in ok applied in ok applied
let parsify_string_reasonligo source = let parsify_string_reasonligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.Reasonligo.parse_string source in Parser.Reasonligo.parse_string source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying") @@ trace (simple_error "abstracting") @@
Simplify.Cameligo.simpl_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok simplified in ok imperative
let parsify_string_pascaligo source = let parsify_string_pascaligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.Pascaligo.parse_string source in Parser.Pascaligo.parse_string source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying") @@ trace (simple_error "abstracting") @@
Simplify.Pascaligo.simpl_program raw Concrete_to_imperative.Pascaligo.compile_program raw
in ok simplified in ok imperative
let parsify_string_cameligo source = let parsify_string_cameligo source =
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.Cameligo.parse_string source in Parser.Cameligo.parse_string source in
let%bind simplified = let%bind imperative =
trace (simple_error "simplifying") @@ trace (simple_error "abstracting") @@
Simplify.Cameligo.simpl_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok simplified in ok imperative
let parsify_string syntax source = let parsify_string syntax source =
let%bind parsify = let%bind parsify =
@ -126,7 +126,7 @@ let parsify_string syntax source =
| CameLIGO -> ok parsify_string_cameligo | CameLIGO -> ok parsify_string_cameligo
| ReasonLIGO -> ok parsify_string_reasonligo in | ReasonLIGO -> ok parsify_string_reasonligo in
let%bind parsified = parsify source in let%bind parsified = parsify source in
let%bind applied = Self_ast_simplified.all_program parsified let%bind applied = Self_ast_imperative.all_program parsified
in ok applied in ok applied
let pretty_print_pascaligo source = let pretty_print_pascaligo source =

24
src/main/compile/of_simplified.ml → src/main/compile/of_core.ml
View File

@ -4,7 +4,7 @@ type form =
| Contract of string | Contract of string
| Env | Env
let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result = let compile (cform: form) (program : Ast_core.program) : (Ast_typed.program * Typer.Solver.state) result =
let%bind (prog_typed , state) = Typer.type_program program in let%bind (prog_typed , state) = Typer.type_program program in
let () = Typer.Solver.discard_state state in let () = Typer.Solver.discard_state state in
let%bind applied = Self_ast_typed.all_program prog_typed in let%bind applied = Self_ast_typed.all_program prog_typed in
@ -13,31 +13,31 @@ let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.progra
| Env -> ok applied in | Env -> ok applied in
ok @@ (applied', state) ok @@ (applied', state)
let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (e : Ast_core.expression)
: (Ast_typed.expression * Typer.Solver.state) result = : (Ast_typed.expression * Typer.Solver.state) result =
let%bind (ae_typed,state) = Typer.type_expression_subst env state ae in let%bind (ae_typed,state) = Typer.type_expression_subst env state e in
let () = Typer.Solver.discard_state state in let () = Typer.Solver.discard_state state in
let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in
ok @@ (ae_typed',state) ok @@ (ae_typed',state)
let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result = let apply (entry_point : string) (param : Ast_core.expression) : Ast_core.expression result =
let name = Var.of_name entry_point in let name = Var.of_name entry_point in
let entry_point_var : Ast_simplified.expression = let entry_point_var : Ast_core.expression =
{ expression_content = Ast_simplified.E_variable name ; { expression_content = Ast_core.E_variable name ;
location = Virtual "generated entry-point variable" } in location = Virtual "generated entry-point variable" } in
let applied : Ast_simplified.expression = let applied : Ast_core.expression =
{ expression_content = Ast_simplified.E_application {expr1=entry_point_var; expr2=param} ; { expression_content = Ast_core.E_application {lamb=entry_point_var; args=param} ;
location = Virtual "generated application" } in location = Virtual "generated application" } in
ok applied ok applied
let pretty_print formatter (program : Ast_simplified.program) = let pretty_print formatter (program : Ast_core.program) =
Ast_simplified.PP.program formatter program Ast_core.PP.program formatter program
let list_declarations (program : Ast_simplified.program) : string list = let list_declarations (program : Ast_core.program) : string list =
List.fold_left List.fold_left
(fun prev el -> (fun prev el ->
let open Location in let open Location in
let open Ast_simplified in let open Ast_core in
match el.wrap_content with match el.wrap_content with
| Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev | Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev
| _ -> prev) | _ -> prev)

25
src/main/compile/of_imperative.ml Normal file
View File

@ -0,0 +1,25 @@
open Trace
open Ast_imperative
open Imperative_to_sugar
type form =
| Contract of string
| Env
let compile (program : program) : Ast_sugar.program result =
compile_program program
let compile_expression (e : expression) : Ast_sugar.expression result =
compile_expression e
let pretty_print formatter (program : program) =
PP.program formatter program
let list_declarations (program : program) : string list =
List.fold_left
(fun prev el ->
let open Location in
match el.wrap_content with
| Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev
| _ -> prev)
[] program

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

@ -1,23 +1,23 @@
open Trace open Trace
open Helpers open Helpers
let compile (source_filename:string) syntax : Ast_simplified.program result = let compile (source_filename:string) syntax : Ast_imperative.program result =
let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind syntax = syntax_to_variant syntax (Some source_filename) in
let%bind simplified = parsify syntax source_filename in let%bind abstract = parsify syntax source_filename in
ok simplified ok abstract
let compile_string (source:string) syntax : Ast_simplified.program result = let compile_string (source:string) syntax : Ast_imperative.program result =
let%bind simplified = parsify_string syntax source in let%bind abstract = parsify_string syntax source in
ok simplified ok abstract
let compile_expression : v_syntax -> string -> Ast_simplified.expression result = let compile_expression : v_syntax -> string -> Ast_imperative.expression result =
fun syntax exp -> fun syntax exp ->
parsify_expression syntax exp parsify_expression syntax exp
let compile_contract_input : string -> string -> v_syntax -> Ast_simplified.expression result = let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expression result =
fun storage parameter syntax -> fun storage parameter syntax ->
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
ok @@ Ast_simplified.e_pair storage parameter ok @@ Ast_imperative.e_pair storage parameter
let pretty_print source_filename syntax = let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename Helpers.pretty_print syntax source_filename

25
src/main/compile/of_sugar.ml Normal file
View File

@ -0,0 +1,25 @@
open Trace
open Ast_sugar
open Sugar_to_core
type form =
| Contract of string
| Env
let compile (program : program) : Ast_core.program result =
compile_program program
let compile_expression (e : expression) : Ast_core.expression result =
compile_expression e
let pretty_print formatter (program : program) =
PP.program formatter program
let list_declarations (program : program) : string list =
List.fold_left
(fun prev el ->
let open Location in
match el.wrap_content with
| Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev
| _ -> prev)
[] program

65
src/main/compile/utils.ml Normal file
View File

@ -0,0 +1,65 @@
open Trace
let to_imperatve f stx =
let%bind imperative = Of_source.compile f (Syntax_name stx) in
ok @@ imperative
let to_sugar f stx =
let%bind imperative = to_imperatve f stx in
let%bind sugar = Of_imperative.compile imperative in
ok @@ sugar
let to_core f stx =
let%bind sugar = to_sugar f stx in
let%bind core = Of_sugar.compile sugar in
ok @@ core
let type_file f stx env =
let%bind core = to_core f stx in
let%bind typed,state = Of_core.compile env core in
ok @@ (typed,state)
let to_mini_c f stx env =
let%bind typed, _ = type_file f stx env in
let%bind mini_c = Of_typed.compile typed in
ok @@ mini_c
let compile_file f stx ep =
let%bind typed, _ = type_file f stx @@ Contract ep in
let%bind mini_c = Of_typed.compile typed in
let%bind michelson = Of_mini_c.aggregate_and_compile_contract mini_c ep in
let%bind contract = Of_michelson.build_contract michelson in
ok @@ contract
let type_expression source_file syntax expression env state =
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) source_file in
let%bind imperative_exp = Of_source.compile_expression v_syntax expression in
let%bind sugar_exp = Of_imperative.compile_expression imperative_exp in
let%bind core_exp = Of_sugar.compile_expression sugar_exp in
let%bind (typed_exp,state) = Of_core.compile_expression ~env ~state core_exp in
ok @@ (typed_exp,state)
let expression_to_mini_c source_file syntax expression env state =
let%bind (typed_exp,_) = type_expression source_file syntax expression env state in
let%bind mini_c_exp = Of_typed.compile_expression typed_exp in
ok @@ mini_c_exp
let compile_expression source_file syntax expression env state =
let%bind mini_c_exp = expression_to_mini_c source_file syntax expression env state in
let%bind compiled = Of_mini_c.compile_expression mini_c_exp in
ok @@ compiled
let compile_and_aggregate_expression source_file syntax expression env state mini_c_prg =
let%bind mini_c_exp = expression_to_mini_c source_file syntax expression env state in
let%bind compiled = Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_exp in
ok @@ compiled
let compile_storage storage input source_file syntax env state mini_c_prg =
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
let%bind imperative = Of_source.compile_contract_input storage input v_syntax in
let%bind sugar = Of_imperative.compile_expression imperative in
let%bind core = Of_sugar.compile_expression sugar in
let%bind typed,_ = Of_core.compile_expression ~env ~state core in
let%bind mini_c = Of_typed.compile_expression typed in
let%bind compiled = Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c in
ok @@ compiled

6
src/main/run/dune
View File

@ -5,8 +5,10 @@
simple-utils simple-utils
tezos-utils tezos-utils
parser parser
simplify concrete_to_imperative
ast_simplified self_ast_imperative
sugar_to_core
ast_core
typer_new typer_new
typer typer
ast_typed ast_typed

2
src/main/uncompile/dune
View File

@ -4,6 +4,8 @@
(libraries (libraries
simple-utils simple-utils
compiler compiler
imperative_to_sugar
sugar_to_core
typer_new typer_new
typer typer
ast_typed ast_typed

3
src/main/uncompile/uncompile.ml
View File

@ -10,7 +10,8 @@ let uncompile_value func_or_expr program entry ex_ty_value =
ok output_type in ok output_type in
let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = Transpiler.untranspile mini_c output_type in let%bind typed = Transpiler.untranspile mini_c output_type in
Typer.untype_expression typed let%bind core = Typer.untype_expression typed in
ok @@ core
let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let uncompile_typed_program_entry_expression_result program entry ex_ty_value =
uncompile_value Expression program entry ex_ty_value uncompile_value Expression program entry ex_ty_value

0
src/passes/6-interpreter/dune → src/passes/10-interpreter/dune
View File

2
src/passes/6-interpreter/interpreter.ml → src/passes/10-interpreter/interpreter.ml
View File

@ -270,7 +270,7 @@ and eval_literal : Ast_typed.literal -> value result = function
and eval : Ast_typed.expression -> env -> value result and eval : Ast_typed.expression -> env -> value result
= fun term env -> = fun term env ->
match term.expression_content with match term.expression_content with
| E_application ({expr1 = f; expr2 = args}) -> ( | E_application ({lamb = f; args}) -> (
let%bind f' = eval f env in let%bind f' = eval f env in
let%bind args' = eval args env in let%bind args' = eval args env in
match f' with match f' with

0
src/passes/6-interpreter/interpreter.mli → src/passes/10-interpreter/interpreter.mli
View File

0
src/passes/6-transpiler/dune → src/passes/10-transpiler/dune
View File

0
src/passes/6-transpiler/helpers.ml → src/passes/10-transpiler/helpers.ml
View File

12
src/passes/6-transpiler/transpiler.ml → src/passes/10-transpiler/transpiler.ml
View File

@ -253,9 +253,9 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind tv = transpile_environment_element_type ele in let%bind tv = transpile_environment_element_type ele in
return ~tv @@ E_variable (name) return ~tv @@ E_variable (name)
) )
| E_application {expr1;expr2} -> | E_application {lamb; args} ->
let%bind a = transpile_annotated_expression expr1 in let%bind a = transpile_annotated_expression lamb in
let%bind b = transpile_annotated_expression expr2 in let%bind b = transpile_annotated_expression args in
return @@ E_application (a, b) return @@ E_application (a, b)
| E_constructor {constructor;element} -> ( | E_constructor {constructor;element} -> (
let%bind param' = transpile_annotated_expression element in let%bind param' = transpile_annotated_expression element in
@ -550,10 +550,10 @@ and transpile_recursive {fun_name; fun_type; lambda} =
E_matching m -> E_matching m ->
let%bind ty = transpile_type e.type_expression in let%bind ty = transpile_type e.type_expression in
matching fun_name loop_type shadowed m ty | matching fun_name loop_type shadowed m ty |
E_application {expr1;expr2} -> ( E_application {lamb;args} -> (
match expr1.expression_content,shadowed with match lamb.expression_content,shadowed with
E_variable name, false when Var.equal fun_name name -> E_variable name, false when Var.equal fun_name name ->
let%bind expr = transpile_annotated_expression expr2 in let%bind expr = transpile_annotated_expression args in
ok @@ Expression.make (E_constant {cons_name=C_LOOP_CONTINUE;arguments=[expr]}) loop_type | ok @@ Expression.make (E_constant {cons_name=C_LOOP_CONTINUE;arguments=[expr]}) loop_type |
_ -> _ ->
let%bind expr = transpile_annotated_expression e in let%bind expr = transpile_annotated_expression e in

0
src/passes/6-transpiler/transpiler.mli → src/passes/10-transpiler/transpiler.mli
View File

0
src/passes/6-transpiler/untranspiler.ml → src/passes/10-transpiler/untranspiler.ml
View File

0
src/passes/7-self_mini_c/dune → src/passes/11-self_mini_c/dune
View File

0
src/passes/7-self_mini_c/helpers.ml → src/passes/11-self_mini_c/helpers.ml
View File

0
src/passes/7-self_mini_c/michelson_restrictions.ml → src/passes/11-self_mini_c/michelson_restrictions.ml
View File

0
src/passes/7-self_mini_c/self_mini_c.ml → src/passes/11-self_mini_c/self_mini_c.ml
View File

0
src/passes/7-self_mini_c/subst.ml → src/passes/11-self_mini_c/subst.ml
View File

0
src/passes/8-compiler/compiler.ml → src/passes/12-compiler/compiler.ml
View File

0
src/passes/8-compiler/compiler_environment.ml → src/passes/12-compiler/compiler_environment.ml
View File

0
src/passes/8-compiler/compiler_environment.mli → src/passes/12-compiler/compiler_environment.mli
View File

0
src/passes/8-compiler/compiler_program.ml → src/passes/12-compiler/compiler_program.ml
View File

0
src/passes/8-compiler/compiler_program.mli → src/passes/12-compiler/compiler_program.mli
View File

0
src/passes/8-compiler/compiler_type.ml → src/passes/12-compiler/compiler_type.ml
View File

0
src/passes/8-compiler/compiler_type.mli → src/passes/12-compiler/compiler_type.mli
View File

0
src/passes/8-compiler/dune → src/passes/12-compiler/dune
View File

0
src/passes/8-compiler/uncompiler.ml → src/passes/12-compiler/uncompiler.ml
View File

0
src/passes/8-compiler/uncompiler.mli → src/passes/12-compiler/uncompiler.mli
View File

0
src/passes/9-self_michelson/dune → src/passes/13-self_michelson/dune
View File

0
src/passes/9-self_michelson/helpers.ml → src/passes/13-self_michelson/helpers.ml
View File

0
src/passes/3-self_ast_simplified/main.ml → src/passes/13-self_michelson/main.ml
View File

0
src/passes/9-self_michelson/self_michelson.ml → src/passes/13-self_michelson/self_michelson.ml
View File

199
src/passes/2-simplify/cameligo.ml → src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -1,7 +1,7 @@
[@@@warning "-45"] [@@@warning "-45"]
open Trace open Trace
open Ast_simplified open Ast_imperative
module Raw = Parser.Cameligo.AST module Raw = Parser.Cameligo.AST
module SMap = Map.String module SMap = Map.String
@ -114,8 +114,8 @@ module Errors = struct
] in ] in
error ~data title message error ~data title message
let simplifying_expr t = let abstracting_expr t =
let title () = "Simplifying expression" in let title () = "abstracting expression" in
let message () = "" in let message () = "" in
let data = [ let data = [
("expression" , ("expression" ,
@ -156,7 +156,7 @@ end
open Errors open Errors
open Operators.Simplify.Cameligo open Operators.Concrete_to_imperative.Cameligo
let r_split = Location.r_split let r_split = Location.r_split
@ -205,7 +205,7 @@ let rec typed_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern ->
| Raw.PTyped pt -> | Raw.PTyped pt ->
let (p,t) = pt.value.pattern,pt.value.type_expr in let (p,t) = pt.value.pattern,pt.value.type_expr in
let%bind p = tuple_pattern_to_vars p in let%bind p = tuple_pattern_to_vars p in
let%bind t = simpl_type_expression t in let%bind t = compile_type_expression t in
ok @@ (p,t) ok @@ (p,t)
| other -> (fail @@ wrong_pattern "parenthetical or type annotation" other) | other -> (fail @@ wrong_pattern "parenthetical or type annotation" other)
@ -213,10 +213,10 @@ and unpar_pattern : Raw.pattern -> Raw.pattern = function
| PPar p -> unpar_pattern p.value.inside | PPar p -> unpar_pattern p.value.inside
| _ as p -> p | _ as p -> p
and simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> and compile_type_expression : Raw.type_expr -> type_expression result = fun te ->
trace (simple_info "simplifying this type expression...") @@ trace (simple_info "abstracting this type expression...") @@
match te with match te with
TPar x -> simpl_type_expression x.value.inside TPar x -> compile_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
match type_constants v.value with match type_constants v.value with
| Ok (s,_) -> ok @@ make_t @@ T_constant s | Ok (s,_) -> ok @@ make_t @@ T_constant s
@ -225,8 +225,8 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
| TFun x -> ( | TFun x -> (
let%bind (type1 , type2) = let%bind (type1 , type2) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
let%bind a = simpl_type_expression a in let%bind a = compile_type_expression a in
let%bind b = simpl_type_expression b in let%bind b = compile_type_expression b in
ok (a , b) ok (a , b)
in in
ok @@ make_t @@ T_arrow {type1;type2} ok @@ make_t @@ T_arrow {type1;type2}
@ -234,18 +234,18 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
| TApp x -> ( | TApp x -> (
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_map_list simpl_type_expression lst in let%bind lst' = bind_map_list compile_type_expression lst in
let%bind cst = let%bind cst =
trace (unknown_predefined_type name) @@ trace (unknown_predefined_type name) @@
type_operators name.value in type_operators name.value in
t_operator cst lst' t_operator cst lst'
) )
| TProd p -> ( | TProd p -> (
let%bind tpl = simpl_list_type_expression @@ npseq_to_list p.value in let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in
ok tpl ok tpl
) )
| TRecord r -> | TRecord r ->
let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in let aux = fun (x, y) -> let%bind y = compile_type_expression y in ok (x, y) in
let apply (x:Raw.field_decl Raw.reg) = let apply (x:Raw.field_decl Raw.reg) =
(x.value.field_name.value, x.value.field_type) in (x.value.field_name.value, x.value.field_type) in
let%bind lst = let%bind lst =
@ -262,7 +262,7 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
None -> [] None -> []
| Some (_, TProd product) -> npseq_to_list product.value | Some (_, TProd product) -> npseq_to_list product.value
| Some (_, t_expr) -> [t_expr] in | Some (_, t_expr) -> [t_expr] in
let%bind te = simpl_list_type_expression @@ args in let%bind te = compile_list_type_expression @@ args in
ok (v.value.constr.value, te) in ok (v.value.constr.value, te) in
let%bind lst = bind_list let%bind lst = bind_list
@@ List.map aux @@ List.map aux
@ -270,18 +270,18 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t @@ T_sum m ok @@ make_t @@ T_sum m
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result = and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with match lst with
| [] -> ok @@ t_unit | [] -> ok @@ t_unit
| [hd] -> simpl_type_expression hd | [hd] -> compile_type_expression hd
| lst -> | lst ->
let%bind lst = bind_map_list simpl_type_expression lst in let%bind lst = bind_map_list compile_type_expression lst in
ok @@ t_tuple lst ok @@ t_tuple lst
let rec simpl_expression : let rec compile_expression :
Raw.expr -> expr result = fun t -> Raw.expr -> expr result = fun t ->
let return x = ok x in let return x = ok x in
let simpl_projection = fun (p:Raw.projection Region.reg) -> let compile_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in let (p , loc) = r_split p in
let var = let var =
let name = Var.of_name p.struct_name.value in let name = Var.of_name p.struct_name.value in
@ -296,7 +296,7 @@ let rec simpl_expression :
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
return @@ List.fold_left (e_accessor ~loc ) var path' return @@ List.fold_left (e_accessor ~loc ) var path'
in in
let simpl_path : Raw.path -> string * label list = fun p -> let compile_path : Raw.path -> string * label list = fun p ->
match p with match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
@ -313,9 +313,9 @@ let rec simpl_expression :
(var , path') (var , path')
) )
in in
let simpl_update = fun (u:Raw.update Region.reg) -> let compile_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in let (u, loc) = r_split u in
let (name, path) = simpl_path u.record in let (name, path) = compile_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> e_variable (Var.of_name name)
| _ -> | _ ->
@ -325,7 +325,7 @@ let rec simpl_expression :
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in let (f,_) = r_split f in
let%bind expr = simpl_expression f.field_expr in let%bind expr = compile_expression f.field_expr in
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
in in
bind_map_list aux @@ npseq_to_list updates bind_map_list aux @@ npseq_to_list updates
@ -342,7 +342,7 @@ let rec simpl_expression :
bind_fold_list aux record updates' bind_fold_list aux record updates'
in in
trace (simplifying_expr t) @@ trace (abstracting_expr t) @@
match t with match t with
Raw.ELetIn e -> Raw.ELetIn e ->
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
@ -352,20 +352,20 @@ let rec simpl_expression :
| (p, []) -> | (p, []) ->
let%bind variables = tuple_pattern_to_typed_vars p in let%bind variables = tuple_pattern_to_typed_vars p in
let%bind ty_opt = let%bind ty_opt =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in bind_map_option (fun (_,te) -> compile_type_expression te) lhs_type in
let%bind rhs = simpl_expression let_rhs 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 = let rhs',rhs_b_expr =
match ty_opt with match ty_opt with
None -> rhs, e_variable rhs_b None -> rhs, e_variable rhs_b
| Some ty -> (e_annotation rhs ty), e_annotation (e_variable rhs_b) ty in | Some ty -> (e_annotation rhs ty), e_annotation (e_variable rhs_b) ty in
let%bind body = simpl_expression body in let%bind body = compile_expression body in
let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) =
let variable, ty_opt = ty_var in let variable, ty_opt = ty_var in
let var_expr = Var.of_name variable.value in let var_expr = Var.of_name variable.value in
let%bind ty_expr_opt = let%bind ty_expr_opt =
match ty_opt with match ty_opt with
| Some ty -> bind_map_option simpl_type_expression (Some ty) | Some ty -> bind_map_option compile_type_expression (Some ty)
| None -> ok None | None -> ok None
in ok (var_expr, ty_expr_opt) in ok (var_expr, ty_expr_opt)
in in
@ -397,7 +397,7 @@ let rec simpl_expression :
| None -> (match let_rhs with | None -> (match let_rhs with
| EFun {value={binders;lhs_type}} -> | EFun {value={binders;lhs_type}} ->
let f_args = nseq_to_list (binders) in let f_args = nseq_to_list (binders) in
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in
let aux acc ty = Option.map (t_function (snd ty)) acc in let aux acc ty = Option.map (t_function (snd ty)) acc in
ok @@ (List.fold_right' aux lhs_type' ty) ok @@ (List.fold_right' aux lhs_type' ty)
@ -444,8 +444,8 @@ let rec simpl_expression :
end end
| Raw.EAnnot a -> | Raw.EAnnot a ->
let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in
let%bind expr' = simpl_expression expr in let%bind expr' = compile_expression expr in
let%bind type_expr' = simpl_type_expression type_expr in let%bind type_expr' = compile_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
| EVar c -> | EVar c ->
let (c',loc) = r_split c in let (c',loc) = r_split c in
@ -454,7 +454,7 @@ let rec simpl_expression :
| Ok (s,_) -> return @@ e_constant s []) | Ok (s,_) -> return @@ e_constant s [])
| ECall x -> ( | ECall x -> (
let ((e1 , e2) , loc) = r_split x in let ((e1 , e2) , loc) = r_split x in
let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in let%bind args = bind_map_list compile_expression (nseq_to_list e2) in
let rec chain_application (f: expression) (args: expression list) = let rec chain_application (f: expression) (args: expression list) =
match args with match args with
| hd :: tl -> chain_application (e_application ~loc f hd) tl | hd :: tl -> chain_application (e_application ~loc f hd) tl
@ -468,29 +468,29 @@ let rec simpl_expression :
| Ok (s, _) -> return @@ e_constant ~loc s args | Ok (s, _) -> return @@ e_constant ~loc s args
) )
| e1 -> | e1 ->
let%bind e1' = simpl_expression e1 in let%bind e1' = compile_expression e1 in
return @@ chain_application e1' args return @@ chain_application e1' args
) )
| EPar x -> simpl_expression x.value.inside | EPar x -> compile_expression x.value.inside
| EUnit reg -> | EUnit reg ->
let (_ , loc) = r_split reg in let (_ , loc) = r_split reg in
return @@ e_literal ~loc Literal_unit return @@ e_literal ~loc Literal_unit
| EBytes x -> | EBytes x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x)) return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x))
| ETuple tpl -> simpl_tuple_expression @@ (npseq_to_list tpl.value) | ETuple tpl -> compile_tuple_expression @@ (npseq_to_list tpl.value)
| ERecord r -> | ERecord r ->
let (r , loc) = r_split r in let (r , loc) = r_split r in
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.ne_elements in @@ npseq_to_list r.ne_elements in
return @@ e_record_ez ~loc fields return @@ e_record_ez ~loc fields
| EProj p -> simpl_projection p | EProj p -> compile_projection p
| EUpdate u -> simpl_update u | EUpdate u -> compile_update u
| EConstr (ESomeApp a) -> | EConstr (ESomeApp a) ->
let (_, args), loc = r_split a in let (_, args), loc = r_split a in
let%bind arg = simpl_expression args in let%bind arg = compile_expression args in
return @@ e_constant ~loc C_SOME [arg] return @@ e_constant ~loc C_SOME [arg]
| EConstr (ENone reg) -> | EConstr (ENone reg) ->
let loc = Location.lift reg in let loc = Location.lift reg in
@ -502,18 +502,18 @@ let rec simpl_expression :
match args with match args with
None -> [] None -> []
| Some arg -> [arg] in | Some arg -> [arg] in
let%bind arg = simpl_tuple_expression @@ args let%bind arg = compile_tuple_expression @@ args
in return @@ e_constructor ~loc c_name arg in return @@ e_constructor ~loc c_name arg
| EArith (Add c) -> | EArith (Add c) ->
simpl_binop "ADD" c compile_binop "ADD" c
| EArith (Sub c) -> | EArith (Sub c) ->
simpl_binop "SUB" c compile_binop "SUB" c
| EArith (Mult c) -> | EArith (Mult c) ->
simpl_binop "TIMES" c compile_binop "TIMES" c
| EArith (Div c) -> | EArith (Div c) ->
simpl_binop "DIV" c compile_binop "DIV" c
| EArith (Mod c) -> | EArith (Mod c) ->
simpl_binop "MOD" c compile_binop "MOD" c
| EArith (Int n) -> ( | EArith (Int n) -> (
let (n , loc) = r_split n in let (n , loc) = r_split n in
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
@ -529,7 +529,7 @@ let rec simpl_expression :
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_mutez n) return @@ e_literal ~loc (Literal_mutez n)
) )
| EArith (Neg e) -> simpl_unop "NEG" e | EArith (Neg e) -> compile_unop "NEG" e
| EString (String s) -> ( | EString (String s) -> (
let (s , loc) = r_split s in let (s , loc) = r_split s in
let s' = let s' =
@ -540,24 +540,24 @@ let rec simpl_expression :
) )
| EString (Cat c) -> | EString (Cat c) ->
let (c, loc) = r_split c in let (c, loc) = r_split c in
let%bind string_left = simpl_expression c.arg1 in let%bind string_left = compile_expression c.arg1 in
let%bind string_right = simpl_expression c.arg2 in let%bind string_right = compile_expression c.arg2 in
return @@ e_string_cat ~loc string_left string_right return @@ e_string_cat ~loc string_left string_right
| ELogic l -> simpl_logic_expression l | ELogic l -> compile_logic_expression l
| EList l -> simpl_list_expression l | EList l -> compile_list_expression l
| ECase c -> ( | ECase c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr in let%bind e = compile_expression c.expr in
let%bind lst = let%bind lst =
let aux (x : Raw.expr Raw.case_clause) = let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = simpl_expression x.rhs in let%bind expr = compile_expression x.rhs in
ok (x.pattern, expr) in ok (x.pattern, expr) in
bind_list bind_list
@@ List.map aux @@ List.map aux
@@ List.map get_value @@ List.map get_value
@@ npseq_to_list c.cases.value in @@ npseq_to_list c.cases.value in
let default_action () = let default_action () =
let%bind cases = simpl_cases lst in let%bind cases = compile_cases lst in
return @@ e_matching ~loc e cases in return @@ e_matching ~loc e cases in
(* Hack to take care of patterns introduced by `parser/cameligo/Parser.mly` in "norm_fun_expr". TODO: Still needed? *) (* Hack to take care of patterns introduced by `parser/cameligo/Parser.mly` in "norm_fun_expr". TODO: Still needed? *)
match lst with match lst with
@ -571,7 +571,7 @@ let rec simpl_expression :
match x'.pattern with match x'.pattern with
| Raw.PVar y -> | Raw.PVar y ->
let var_name = Var.of_name y.value in let var_name = Var.of_name y.value in
let%bind type_expr = simpl_type_expression x'.type_expr in let%bind type_expr = compile_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) false false e rhs return @@ e_let_in (var_name , Some type_expr) false false e rhs
| _ -> default_action () | _ -> default_action ()
) )
@ -581,29 +581,29 @@ let rec simpl_expression :
) )
| _ -> default_action () | _ -> default_action ()
) )
| EFun lamb -> simpl_fun lamb | EFun lamb -> compile_fun lamb
| ESeq s -> ( | ESeq s -> (
let (s , loc) = r_split s in let (s , loc) = r_split s in
let items : Raw.expr list = pseq_to_list s.elements in let items : Raw.expr list = pseq_to_list s.elements in
(match items with (match items with
[] -> return @@ e_skip ~loc () [] -> return @@ e_skip ~loc ()
| expr::more -> | expr::more ->
let expr' = simpl_expression expr in let expr' = compile_expression expr in
let apply (e1: Raw.expr) (e2: expression Trace.result) = let apply (e1: Raw.expr) (e2: expression Trace.result) =
let%bind a = simpl_expression e1 in let%bind a = compile_expression e1 in
let%bind e2' = e2 in let%bind e2' = e2 in
return @@ e_sequence a e2' return @@ e_sequence a e2'
in List.fold_right apply more expr') in List.fold_right apply more expr')
) )
| ECond c -> ( | ECond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = simpl_expression c.ifso in let%bind match_true = compile_expression c.ifso in
let%bind match_false = simpl_expression c.ifnot in let%bind match_false = compile_expression c.ifnot in
return @@ e_matching ~loc expr (Match_bool {match_true; match_false}) return @@ e_matching ~loc expr (Match_bool {match_true; match_false})
) )
and simpl_fun lamb' : expr result = and compile_fun lamb' : expr result =
let return x = ok x in let return x = ok x in
let (lamb , loc) = r_split lamb' in let (lamb , loc) = r_split lamb' in
let%bind params' = let%bind params' =
@ -649,7 +649,7 @@ and simpl_fun lamb' : expr result =
| _ , None -> | _ , None ->
fail @@ untyped_fun_param var fail @@ untyped_fun_param var
| _ , Some ty -> ( | _ , Some ty -> (
let%bind ty' = simpl_type_expression ty in let%bind ty' = compile_type_expression ty in
ok (var , ty') ok (var , ty')
) )
in in
@ -700,8 +700,8 @@ and simpl_fun lamb' : expr result =
in in
let%bind (body , body_type) = expr_to_typed_expr body in let%bind (body , body_type) = expr_to_typed_expr body in
let%bind output_type = let%bind output_type =
bind_map_option simpl_type_expression body_type in bind_map_option compile_type_expression body_type in
let%bind body = simpl_expression body in let%bind body = compile_expression body in
let rec layer_arguments (arguments: (Raw.variable * type_expression) list) = let rec layer_arguments (arguments: (Raw.variable * type_expression) list) =
match arguments with match arguments with
| hd :: tl -> | hd :: tl ->
@ -714,7 +714,7 @@ and simpl_fun lamb' : expr result =
return @@ ret_lamb return @@ ret_lamb
and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ make_option_typed x te_annot in
match t with match t with
| BoolExpr (False reg) -> ( | BoolExpr (False reg) -> (
@ -726,61 +726,61 @@ and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
return @@ e_literal ~loc (Literal_bool true) return @@ e_literal ~loc (Literal_bool true)
) )
| BoolExpr (Or b) -> | BoolExpr (Or b) ->
simpl_binop "OR" b compile_binop "OR" b
| BoolExpr (And b) -> | BoolExpr (And b) ->
simpl_binop "AND" b compile_binop "AND" b
| BoolExpr (Not b) -> | BoolExpr (Not b) ->
simpl_unop "NOT" b compile_unop "NOT" b
| CompExpr (Lt c) -> | CompExpr (Lt c) ->
simpl_binop "LT" c compile_binop "LT" c
| CompExpr (Gt c) -> | CompExpr (Gt c) ->
simpl_binop "GT" c compile_binop "GT" c
| CompExpr (Leq c) -> | CompExpr (Leq c) ->
simpl_binop "LE" c compile_binop "LE" c
| CompExpr (Geq c) -> | CompExpr (Geq c) ->
simpl_binop "GE" c compile_binop "GE" c
| CompExpr (Equal c) -> | CompExpr (Equal c) ->
simpl_binop "EQ" c compile_binop "EQ" c
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
simpl_binop "NEQ" c compile_binop "NEQ" c
and simpl_list_expression (t:Raw.list_expr) : expression result = and compile_list_expression (t:Raw.list_expr) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
match t with match t with
ECons c -> simpl_binop "CONS" c ECons c -> compile_binop "CONS" c
| EListComp lst -> ( | EListComp lst -> (
let (lst , loc) = r_split lst in let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list simpl_expression @@ bind_map_list compile_expression @@
pseq_to_list lst.elements in pseq_to_list lst.elements in
return @@ e_list ~loc lst' return @@ e_list ~loc lst'
) )
and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
let (args , loc) = r_split t in let (args , loc) = r_split t in
let%bind a = simpl_expression args.arg1 in let%bind a = compile_expression args.arg1 in
let%bind b = simpl_expression args.arg2 in let%bind b = compile_expression args.arg2 in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ] return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in let%bind a = compile_expression t.arg in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ] return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
match lst with match lst with
| [] -> return @@ e_literal ?loc Literal_unit | [] -> return @@ e_literal ?loc Literal_unit
| [hd] -> simpl_expression hd | [hd] -> compile_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map simpl_expression lst in let%bind lst = bind_list @@ List.map compile_expression lst in
return @@ e_tuple ?loc lst return @@ e_tuple ?loc lst
and simpl_declaration : Raw.declaration -> declaration Location.wrap list result = and compile_declaration : Raw.declaration -> declaration Location.wrap list result =
fun t -> fun t ->
let open! Raw in let open! Raw in
let loc : 'a . 'a Raw.reg -> _ -> _ = let loc : 'a . 'a Raw.reg -> _ -> _ =
@ -788,7 +788,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
match t with match t with
| TypeDecl x -> | TypeDecl x ->
let {name;type_expr} : Raw.type_decl = x.value in let {name;type_expr} : Raw.type_decl = x.value in
let%bind type_expression = simpl_type_expression type_expr in let%bind type_expression = compile_type_expression type_expr in
ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)] ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)]
| Let x -> ( | Let x -> (
let (_, recursive, let_binding, attributes), _ = r_split x in let (_, recursive, let_binding, attributes), _ = r_split x in
@ -798,17 +798,16 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let (hd, _) = binders in let (hd, _) = binders in
match hd with match hd with
| PTuple pt -> | PTuple pt ->
let process_variable (var_pair: pattern * Raw.expr) : let process_variable (var_pair: pattern * Raw.expr) =
Ast_simplified.declaration Location.wrap result =
(let (par_var, rhs_expr) = var_pair in (let (par_var, rhs_expr) = var_pair in
let%bind (v, v_type) = pattern_to_typed_var par_var in let%bind (v, v_type) = pattern_to_typed_var par_var in
let%bind v_type_expression = let%bind v_type_expression =
match v_type with match v_type with
| Some v_type -> ok (to_option (simpl_type_expression v_type)) | Some v_type -> ok (to_option (compile_type_expression v_type))
| None -> ok None | None -> ok None
in in
let%bind simpl_rhs_expr = simpl_expression rhs_expr in let%bind compile_rhs_expr = compile_expression rhs_expr in
ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, simpl_rhs_expr) ) ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, compile_rhs_expr) )
in let%bind variables = ok @@ npseq_to_list pt.value in let%bind variables = ok @@ npseq_to_list pt.value
in let%bind expr_bind_lst = in let%bind expr_bind_lst =
match let_rhs with match let_rhs with
@ -840,7 +839,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
gen_access_tuple name ~i: (i + 1) ~accesses gen_access_tuple name ~i: (i + 1) ~accesses
in ok (gen_access_tuple name) in ok (gen_access_tuple name)
(* TODO: Improve this error message *) (* TODO: Improve this error message *)
| other -> fail @@ simplifying_expr other | other -> fail @@ abstracting_expr other
in let%bind decls = in let%bind decls =
(* TODO: Rewrite the gen_access_tuple so there's no List.rev *) (* TODO: Rewrite the gen_access_tuple so there's no List.rev *)
bind_map_list process_variable (List.combine variables (List.rev expr_bind_lst)) bind_map_list process_variable (List.combine variables (List.rev expr_bind_lst))
@ -848,7 +847,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
| PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } -> | PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } ->
(* Extract parenthetical multi-bind *) (* Extract parenthetical multi-bind *)
let (wild, recursive, _, attributes) = fst @@ r_split x in let (wild, recursive, _, attributes) = fst @@ r_split x in
simpl_declaration compile_declaration
(Let { (Let {
region = x.region; region = x.region;
value = (wild, recursive, {binders = (pt, []); value = (wild, recursive, {binders = (pt, []);
@ -863,7 +862,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind var = pattern_to_var hd in let%bind var = pattern_to_var hd in
ok (var , tl) ok (var , tl)
in in
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in
let%bind let_rhs,lhs_type = match args with let%bind let_rhs,lhs_type = match args with
| [] -> ok (let_rhs, lhs_type') | [] -> ok (let_rhs, lhs_type')
| param1::others -> | param1::others ->
@ -879,12 +878,12 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let aux acc ty = Option.map (t_function (snd ty)) acc in let aux acc ty = Option.map (t_function (snd ty)) acc in
ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty) ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty)
in in
let%bind rhs' = simpl_expression let_rhs in let%bind rhs' = compile_expression let_rhs in
let%bind lhs_type = match lhs_type with let%bind lhs_type = match lhs_type with
| None -> (match let_rhs with | None -> (match let_rhs with
| EFun {value={binders;lhs_type}} -> | EFun {value={binders;lhs_type}} ->
let f_args = nseq_to_list (binders) in let f_args = nseq_to_list (binders) in
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in
let aux acc ty = Option.map (t_function (snd ty)) acc in let aux acc ty = Option.map (t_function (snd ty)) acc in
ok @@ (List.fold_right' aux lhs_type' ty) ok @@ (List.fold_right' aux lhs_type' ty)
@ -907,7 +906,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))] ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
) )
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result = and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result =
fun t -> fun t ->
let open Raw in let open Raw in
let rec get_var (t:Raw.pattern) = let rec get_var (t:Raw.pattern) =
@ -1027,6 +1026,6 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content
| _ -> simple_fail "bad option pattern" | _ -> simple_fail "bad option pattern"
in bind_or (as_option () , as_variant ()) in bind_or (as_option () , as_variant ())
let simpl_program : Raw.ast -> program result = fun t -> let compile_program : Raw.ast -> program result = fun t ->
let%bind decls = bind_map_list simpl_declaration @@ nseq_to_list t.decl in let%bind decls = bind_map_list compile_declaration @@ nseq_to_list t.decl in
ok @@ List.concat @@ decls ok @@ List.concat @@ decls

29
src/passes/2-simplify/cameligo.mli → src/passes/2-concrete_to_imperative/cameligo.mli
View File

@ -1,8 +1,7 @@
[@@@warning "-45"] [@@@warning "-45"]
open Trace open Trace
open Ast_imperative
open Ast_simplified
module Raw = Parser.Cameligo.AST module Raw = Parser.Cameligo.AST
module SMap = Map.String module SMap = Map.String
@ -29,7 +28,7 @@ module Errors : sig
val unsupported_tuple_pattern : Raw.pattern -> unit -> error val unsupported_tuple_pattern : Raw.pattern -> unit -> error
val unsupported_cst_constr : Raw.pattern -> unit -> error val unsupported_cst_constr : Raw.pattern -> unit -> error
val unsupported_non_var_pattern : Raw.pattern -> unit -> error val unsupported_non_var_pattern : Raw.pattern -> unit -> error
val simplifying_expr : Raw.expr -> unit -> error val abstracting_expr : Raw.expr -> unit -> error
val only_constructors : Raw.pattern -> unit -> error val only_constructors : Raw.pattern -> unit -> error
val unsupported_sugared_lists : Raw.wild -> unit -> error val unsupported_sugared_lists : Raw.wild -> unit -> error
val bad_set_definition : unit -> error val bad_set_definition : unit -> error
@ -46,18 +45,18 @@ val pattern_to_var : Raw.pattern -> Raw.variable result
val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result
val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result
val patterns_to_var : Raw.pattern list -> Raw.variable result val patterns_to_var : Raw.pattern list -> Raw.variable result
val simpl_type_expression : Raw.type_expr -> type_expression result val compile_type_expression : Raw.type_expr -> type_expression result
val simpl_list_type_expression : Raw.type_expr list -> type_expression result val compile_list_type_expression : Raw.type_expr list -> type_expression result
*) *)
val simpl_expression : Raw.expr -> expr result val compile_expression : Raw.expr -> expr result
(* (*
val simpl_fun : Raw.fun_expr Raw.reg -> expr result val compile_fun : Raw.fun_expr Raw.reg -> expr result
val simpl_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result val compile_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result
val simpl_list_expression : Raw.list_expr -> expression result val compile_list_expression : Raw.list_expr -> expression result
val simpl_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result val compile_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result
val simpl_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result val compile_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result
val simpl_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result val compile_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result
val simpl_declaration : Raw.declaration -> declaration Location.wrap result val compile_declaration : Raw.declaration -> declaration Location.wrap result
val simpl_cases : (Raw.pattern * 'a) list -> 'a matching result val compile_cases : (Raw.pattern * 'a) list -> 'a matching result
*) *)
val simpl_program : Raw.ast -> program result val compile_program : Raw.ast -> program result

4
src/passes/2-simplify/camligo.ml.old → src/passes/2-concrete_to_imperative/camligo.ml.old
View File

@ -1,7 +1,7 @@
open Trace open Trace
open Function open Function
module I = Parser.Cameligo.Ast module I = Parser.Cameligo.Ast
module O = Ast_simplified module O = Ast_core
open O.Combinators open O.Combinators
let unwrap : type a . a Location.wrap -> a = Location.unwrap let unwrap : type a . a Location.wrap -> a = Location.unwrap
@ -252,7 +252,7 @@ and expression_main : I.expression_main Location.wrap -> O.expression result = f
let%bind (a' , b') = bind_map_pair expression_main ab in let%bind (a' , b') = bind_map_pair expression_main ab in
return @@ e_binop name a' b' in return @@ e_binop name a' b' in
let error_main = let error_main =
let title () = "simplifying main_expression" in let title () = "abstracting main_expression" in
let content () = Format.asprintf "%a" I.pp_expression_main (unwrap em) in let content () = Format.asprintf "%a" I.pp_expression_main (unwrap em) in
error title content error title content
in in

0
src/passes/2-simplify/simplify.ml → src/passes/2-concrete_to_imperative/concrete_to_imperative.ml
View File

10
src/passes/2-simplify/dune → src/passes/2-concrete_to_imperative/dune
View File

@ -1,14 +1,14 @@
(library (library
(name simplify) (name concrete_to_imperative)
(public_name ligo.simplify) (public_name ligo.concrete_to_imperative)
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
parser parser
ast_simplified ast_imperative
self_ast_simplified self_ast_imperative
operators) operators)
(modules cameligo pascaligo simplify) (modules cameligo pascaligo concrete_to_imperative)
(preprocess (preprocess
(pps (pps
ppx_let ppx_let

360
src/passes/2-simplify/pascaligo.ml → src/passes/2-concrete_to_imperative/pascaligo.ml
View File

@ -1,5 +1,5 @@
open Trace open Trace
open Ast_simplified open Ast_imperative
module Raw = Parser.Pascaligo.AST module Raw = Parser.Pascaligo.AST
module SMap = Map.String module SMap = Map.String
@ -15,7 +15,7 @@ let pseq_to_list = function
let get_value : 'a Raw.reg -> 'a = fun x -> x.value let get_value : 'a Raw.reg -> 'a = fun x -> x.value
and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
let%bind captured_names = Self_ast_simplified.fold_map_expression let%bind captured_names = Self_ast_imperative.fold_map_expression
(* TODO : these should use Variables sets *) (* TODO : these should use Variables sets *)
(fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
match ass_exp.expression_content with match ass_exp.expression_content with
@ -47,7 +47,7 @@ and repair_mutable_variable_in_matching (for_body : expression) (element_names :
ok @@ captured_names ok @@ captured_names
and repair_mutable_variable_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = and repair_mutable_variable_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
let%bind captured_names = Self_ast_simplified.fold_map_expression let%bind captured_names = Self_ast_imperative.fold_map_expression
(* TODO : these should use Variables sets *) (* TODO : these should use Variables sets *)
(fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
match ass_exp.expression_content with match ass_exp.expression_content with
@ -186,7 +186,7 @@ module Errors = struct
(* Logging *) (* Logging *)
let simplifying_instruction t = let abstracting_instruction t =
let title () = "\nSimplifiying instruction" in let title () = "\nSimplifiying instruction" in
let message () = "" in let message () = "" in
(** TODO: The labelled arguments should be flowing from the CLI. *) (** TODO: The labelled arguments should be flowing from the CLI. *)
@ -199,14 +199,14 @@ module Errors = struct
end end
open Errors open Errors
open Operators.Simplify.Pascaligo open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split let r_split = Location.r_split
(* Statements can't be simplified in isolation. [a ; b ; c] can get (* Statements can't be simplified in isolation. [a ; b ; c] can get
simplified either as [let x = expr in (b ; c)] if [a] is a [const x simplified either as [let x = expr in (b ; c)] if [a] is a [const x
= expr] declaration or as [sequence(a, sequence(b, c))] for = expr] declaration or as [sequence(a, sequence(b, c))] for
everything else. Because of this, simplifying sequences depend on everything else. Because of this, abstracting sequences depend on
their contents. To avoid peeking in their contents, we instead their contents. To avoid peeking in their contents, we instead
simplify sequences elements as functions from their next elements simplify sequences elements as functions from their next elements
to the actual result. to the actual result.
@ -229,9 +229,9 @@ let return_statement expr = ok @@ fun expr'_opt ->
| Some expr' -> ok @@ e_sequence expr expr' | Some expr' -> ok @@ e_sequence expr expr'
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
match t with match t with
TPar x -> simpl_type_expression x.value.inside TPar x -> compile_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
match type_constants v.value with match type_constants v.value with
| Ok (s,_) -> ok @@ make_t @@ T_constant s | Ok (s,_) -> ok @@ make_t @@ T_constant s
@ -240,25 +240,25 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
| TFun x -> ( | TFun x -> (
let%bind (a , b) = let%bind (a , b) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
bind_map_pair simpl_type_expression (a , b) in bind_map_pair compile_type_expression (a , b) in
ok @@ make_t @@ T_arrow {type1=a;type2=b} ok @@ make_t @@ T_arrow {type1=a;type2=b}
) )
| TApp x -> | TApp x ->
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
let%bind lst = let%bind lst =
bind_list @@ List.map simpl_type_expression lst in (** TODO: fix constant and operator*) bind_list @@ List.map compile_type_expression lst in (** TODO: fix constant and operator*)
let%bind cst = let%bind cst =
trace (unknown_predefined_type name) @@ trace (unknown_predefined_type name) @@
type_operators name.value in type_operators name.value in
t_operator cst lst t_operator cst lst
| TProd p -> | TProd p ->
let%bind tpl = simpl_list_type_expression let%bind tpl = compile_list_type_expression
@@ npseq_to_list p.value in @@ npseq_to_list p.value in
ok tpl ok tpl
| TRecord r -> | TRecord r ->
let aux = fun (x, y) -> let aux = fun (x, y) ->
let%bind y = simpl_type_expression y in let%bind y = compile_type_expression y in
ok (x, y) ok (x, y)
in in
let apply = let apply =
@ -276,7 +276,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
None -> [] None -> []
| Some (_, TProd product) -> npseq_to_list product.value | Some (_, TProd product) -> npseq_to_list product.value
| Some (_, t_expr) -> [t_expr] in | Some (_, t_expr) -> [t_expr] in
let%bind te = simpl_list_type_expression @@ args in let%bind te = compile_list_type_expression @@ args in
ok (v.value.constr.value, te) ok (v.value.constr.value, te)
in in
let%bind lst = bind_list let%bind lst = bind_list
@ -285,15 +285,15 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t @@ T_sum m ok @@ make_t @@ T_sum m
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result = and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with match lst with
| [] -> ok @@ t_unit | [] -> ok @@ t_unit
| [hd] -> simpl_type_expression hd | [hd] -> compile_type_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map simpl_type_expression lst in let%bind lst = bind_list @@ List.map compile_type_expression lst in
ok @@ t_tuple lst ok @@ t_tuple lst
let simpl_projection : Raw.projection Region.reg -> _ = fun p -> let compile_projection : Raw.projection Region.reg -> _ = fun p ->
let (p' , loc) = r_split p in let (p' , loc) = r_split p in
let var = let var =
let name = Var.of_name p'.struct_name.value in let name = Var.of_name p'.struct_name.value in
@ -309,13 +309,13 @@ let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
ok @@ List.fold_left (e_accessor ~loc) var path' ok @@ List.fold_left (e_accessor ~loc) var path'
let rec simpl_expression (t:Raw.expr) : expr result = let rec compile_expression (t:Raw.expr) : expr result =
let return x = ok x in let return x = ok x in
match t with match t with
| EAnnot a -> ( | EAnnot a -> (
let ((expr , type_expr) , loc) = r_split a in let ((expr , type_expr) , loc) = r_split a in
let%bind expr' = simpl_expression expr in let%bind expr' = compile_expression expr in
let%bind type_expr' = simpl_type_expression type_expr in let%bind type_expr' = compile_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
) )
| EVar c -> ( | EVar c -> (
@ -333,19 +333,19 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let (f_name , f_loc) = r_split name in let (f_name , f_loc) = r_split name in
match constants f_name with match constants f_name with
| Error _ -> | Error _ ->
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Ok (s,_) -> | Ok (s,_) ->
let%bind lst = bind_map_list simpl_expression args' in let%bind lst = bind_map_list compile_expression args' in
return @@ e_constant ~loc s lst return @@ e_constant ~loc s lst
) )
| f -> ( | f -> (
let%bind f' = simpl_expression f in let%bind f' = compile_expression f in
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return @@ e_application ~loc f' arg return @@ e_application ~loc f' arg
) )
) )
| EPar x -> simpl_expression x.value.inside | EPar x -> compile_expression x.value.inside
| EUnit reg -> | EUnit reg ->
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_literal ~loc Literal_unit return @@ e_literal ~loc Literal_unit
@ -354,16 +354,16 @@ let rec simpl_expression (t:Raw.expr) : expr result =
return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x')) return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x'))
| ETuple tpl -> | ETuple tpl ->
let (tpl' , loc) = r_split tpl in let (tpl' , loc) = r_split tpl in
simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside compile_tuple_expression ~loc @@ npseq_to_list tpl'.inside
| ERecord r -> | ERecord r ->
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.value.ne_elements in @@ npseq_to_list r.value.ne_elements in
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = SMap.add k v prev in
return @@ e_record (List.fold_left aux SMap.empty fields) return @@ e_record (List.fold_left aux SMap.empty fields)
| EProj p -> simpl_projection p | EProj p -> compile_projection p
| EUpdate u -> simpl_update u | EUpdate u -> compile_update u
| EConstr (ConstrApp c) -> ( | EConstr (ConstrApp c) -> (
let ((c, args) , loc) = r_split c in let ((c, args) , loc) = r_split c in
match args with match args with
@ -372,7 +372,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
| Some args -> | Some args ->
let args, args_loc = r_split args in let args, args_loc = r_split args in
let%bind arg = let%bind arg =
simpl_tuple_expression ~loc:args_loc compile_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in @@ npseq_to_list args.inside in
return @@ e_constructor ~loc c.value arg return @@ e_constructor ~loc c.value arg
) )
@ -380,7 +380,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let ((_, args) , loc) = r_split a in let ((_, args) , loc) = r_split a in
let (args , args_loc) = r_split args in let (args , args_loc) = r_split args in
let%bind arg = let%bind arg =
simpl_tuple_expression ~loc:args_loc compile_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in @@ npseq_to_list args.inside in
return @@ e_constant ~loc C_SOME [arg] return @@ e_constant ~loc C_SOME [arg]
| EConstr (NoneExpr reg) -> ( | EConstr (NoneExpr reg) -> (
@ -388,15 +388,15 @@ let rec simpl_expression (t:Raw.expr) : expr result =
return @@ e_none ~loc () return @@ e_none ~loc ()
) )
| EArith (Add c) -> | EArith (Add c) ->
simpl_binop "ADD" c compile_binop "ADD" c
| EArith (Sub c) -> | EArith (Sub c) ->
simpl_binop "SUB" c compile_binop "SUB" c
| EArith (Mult c) -> | EArith (Mult c) ->
simpl_binop "TIMES" c compile_binop "TIMES" c
| EArith (Div c) -> | EArith (Div c) ->
simpl_binop "DIV" c compile_binop "DIV" c
| EArith (Mod c) -> | EArith (Mod c) ->
simpl_binop "MOD" c compile_binop "MOD" c
| EArith (Int n) -> ( | EArith (Int n) -> (
let (n , loc) = r_split n in let (n , loc) = r_split n in
let n = Z.to_int @@ snd n in let n = Z.to_int @@ snd n in
@ -412,7 +412,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_mutez n) return @@ e_literal ~loc (Literal_mutez n)
) )
| EArith (Neg e) -> simpl_unop "NEG" e | EArith (Neg e) -> compile_unop "NEG" e
| EString (String s) -> | EString (String s) ->
let (s , loc) = r_split s in let (s , loc) = r_split s in
let s' = let s' =
@ -422,17 +422,17 @@ let rec simpl_expression (t:Raw.expr) : expr result =
return @@ e_literal ~loc (Literal_string s') return @@ e_literal ~loc (Literal_string s')
| EString (Cat bo) -> | EString (Cat bo) ->
let (bo , loc) = r_split bo in let (bo , loc) = r_split bo in
let%bind sl = simpl_expression bo.arg1 in let%bind sl = compile_expression bo.arg1 in
let%bind sr = simpl_expression bo.arg2 in let%bind sr = compile_expression bo.arg2 in
return @@ e_string_cat ~loc sl sr return @@ e_string_cat ~loc sl sr
| ELogic l -> simpl_logic_expression l | ELogic l -> compile_logic_expression l
| EList l -> simpl_list_expression l | EList l -> compile_list_expression l
| ESet s -> simpl_set_expression s | ESet s -> compile_set_expression s
| ECond c -> | ECond c ->
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = simpl_expression c.ifso in let%bind match_true = compile_expression c.ifso in
let%bind match_false = simpl_expression c.ifnot in let%bind match_false = compile_expression c.ifnot in
let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in
let env = Var.fresh () in let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in
@ -440,16 +440,16 @@ let rec simpl_expression (t:Raw.expr) : expr result =
| ECase c -> ( | ECase c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr in let%bind e = compile_expression c.expr in
let%bind lst = let%bind lst =
let aux (x : Raw.expr Raw.case_clause) = let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = simpl_expression x.rhs in let%bind expr = compile_expression x.rhs in
ok (x.pattern, expr) in ok (x.pattern, expr) in
bind_list bind_list
@@ List.map aux @@ List.map aux
@@ List.map get_value @@ List.map get_value
@@ npseq_to_list c.cases.value in @@ npseq_to_list c.cases.value in
let%bind cases = simpl_cases lst in let%bind cases = compile_cases lst in
let match_expr = e_matching ~loc e cases in let match_expr = e_matching ~loc e cases in
let env = Var.fresh () in let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in
@ -461,8 +461,8 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let lst = List.map get_value @@ pseq_to_list mi.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = let aux : Raw.binding -> (expression * expression) result =
fun b -> fun b ->
let%bind src = simpl_expression b.source in let%bind src = compile_expression b.source in
let%bind dst = simpl_expression b.image in let%bind dst = compile_expression b.image in
ok (src, dst) in ok (src, dst) in
bind_map_list aux lst in bind_map_list aux lst in
return @@ e_map ~loc lst return @@ e_map ~loc lst
@ -473,8 +473,8 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let lst = List.map get_value @@ pseq_to_list mi.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = let aux : Raw.binding -> (expression * expression) result =
fun b -> fun b ->
let%bind src = simpl_expression b.source in let%bind src = compile_expression b.source in
let%bind dst = simpl_expression b.image in let%bind dst = compile_expression b.image in
ok (src, dst) in ok (src, dst) in
bind_map_list aux lst in bind_map_list aux lst in
return @@ e_big_map ~loc lst return @@ e_big_map ~loc lst
@ -486,20 +486,20 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let (v , loc) = r_split v in let (v , loc) = r_split v in
return @@ e_variable ~loc (Var.of_name v) return @@ e_variable ~loc (Var.of_name v)
) )
| Path p -> simpl_projection p | Path p -> compile_projection p
in in
let%bind index = simpl_expression lu.index.value.inside in let%bind index = compile_expression lu.index.value.inside in
return @@ e_look_up ~loc path index return @@ e_look_up ~loc path index
) )
| EFun f -> | EFun f ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
let%bind (_ty_opt, f') = simpl_fun_expression ~loc f let%bind (_ty_opt, f') = compile_fun_expression ~loc f
in return @@ f' in return @@ f'
and simpl_update = fun (u:Raw.update Region.reg) -> and compile_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in let (u, loc) = r_split u in
let (name, path) = simpl_path u.record in let (name, path) = compile_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> e_variable (Var.of_name name)
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in | _ -> e_accessor_list (e_variable (Var.of_name name)) path in
@ -507,7 +507,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in let (f,_) = r_split f in
let%bind expr = simpl_expression f.field_expr in let%bind expr = compile_expression f.field_expr in
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
in in
bind_map_list aux @@ npseq_to_list updates bind_map_list aux @@ npseq_to_list updates
@ -523,7 +523,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
aux ur path in aux ur path in
bind_fold_list aux record updates' bind_fold_list aux record updates'
and simpl_logic_expression (t:Raw.logic_expr) : expression result = and compile_logic_expression (t:Raw.logic_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
| BoolExpr (False reg) -> ( | BoolExpr (False reg) -> (
@ -535,92 +535,92 @@ and simpl_logic_expression (t:Raw.logic_expr) : expression result =
return @@ e_literal ~loc (Literal_bool true) return @@ e_literal ~loc (Literal_bool true)
) )
| BoolExpr (Or b) -> | BoolExpr (Or b) ->
simpl_binop "OR" b compile_binop "OR" b
| BoolExpr (And b) -> | BoolExpr (And b) ->
simpl_binop "AND" b compile_binop "AND" b
| BoolExpr (Not b) -> | BoolExpr (Not b) ->
simpl_unop "NOT" b compile_unop "NOT" b
| CompExpr (Lt c) -> | CompExpr (Lt c) ->
simpl_binop "LT" c compile_binop "LT" c
| CompExpr (Gt c) -> | CompExpr (Gt c) ->
simpl_binop "GT" c compile_binop "GT" c
| CompExpr (Leq c) -> | CompExpr (Leq c) ->
simpl_binop "LE" c compile_binop "LE" c
| CompExpr (Geq c) -> | CompExpr (Geq c) ->
simpl_binop "GE" c compile_binop "GE" c
| CompExpr (Equal c) -> | CompExpr (Equal c) ->
simpl_binop "EQ" c compile_binop "EQ" c
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
simpl_binop "NEQ" c compile_binop "NEQ" c
and simpl_list_expression (t:Raw.list_expr) : expression result = and compile_list_expression (t:Raw.list_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
ECons c -> ECons c ->
simpl_binop "CONS" c compile_binop "CONS" c
| EListComp lst -> | EListComp lst ->
let (lst , loc) = r_split lst in let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list simpl_expression @@ bind_map_list compile_expression @@
pseq_to_list lst.elements in pseq_to_list lst.elements in
return @@ e_list ~loc lst' return @@ e_list ~loc lst'
| ENil reg -> | ENil reg ->
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_list ~loc [] return @@ e_list ~loc []
and simpl_set_expression (t:Raw.set_expr) : expression result = and compile_set_expression (t:Raw.set_expr) : expression result =
match t with match t with
| SetMem x -> ( | SetMem x -> (
let (x' , loc) = r_split x in let (x' , loc) = r_split x in
let%bind set' = simpl_expression x'.set in let%bind set' = compile_expression x'.set in
let%bind element' = simpl_expression x'.element in let%bind element' = compile_expression x'.element in
ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ] ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ]
) )
| SetInj x -> ( | SetInj x -> (
let (x' , loc) = r_split x in let (x' , loc) = r_split x in
let elements = pseq_to_list x'.elements in let elements = pseq_to_list x'.elements in
let%bind elements' = bind_map_list simpl_expression elements in let%bind elements' = bind_map_list compile_expression elements in
ok @@ e_set ~loc elements' ok @@ e_set ~loc elements'
) )
and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg1 in let%bind a = compile_expression t.arg1 in
let%bind b = simpl_expression t.arg2 in let%bind b = compile_expression t.arg2 in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ] return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in let%bind a = compile_expression t.arg in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ] return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let return x = ok x in let return x = ok x in
match lst with match lst with
| [] -> return @@ e_literal Literal_unit | [] -> return @@ e_literal Literal_unit
| [hd] -> simpl_expression hd | [hd] -> compile_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map simpl_expression lst let%bind lst = bind_list @@ List.map compile_expression lst
in return @@ e_tuple ?loc lst in return @@ e_tuple ?loc lst
and simpl_data_declaration : Raw.data_decl -> _ result = and compile_data_declaration : Raw.data_decl -> _ result =
fun t -> fun t ->
match t with match t with
| LocalVar x -> | LocalVar x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = simpl_type_expression x.var_type in let%bind t = compile_type_expression x.var_type in
let%bind expression = simpl_expression x.init in let%bind expression = compile_expression x.init in
return_let_in ~loc (Var.of_name name, Some t) false false expression return_let_in ~loc (Var.of_name name, Some t) false false expression
| LocalConst x -> | LocalConst x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = simpl_type_expression x.const_type in let%bind t = compile_type_expression x.const_type in
let%bind expression = simpl_expression x.init in let%bind expression = compile_expression x.init in
let inline = let inline =
match x.attributes with match x.attributes with
None -> false None -> false
@ -630,7 +630,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
in return_let_in ~loc (Var.of_name name, Some t) false inline expression in return_let_in ~loc (Var.of_name name, Some t) false inline expression
| LocalFun f -> | LocalFun f ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
let%bind (binder, expr) = simpl_fun_decl ~loc f in let%bind (binder, expr) = compile_fun_decl ~loc f in
let inline = let inline =
match f.attributes with match f.attributes with
None -> false None -> false
@ -639,22 +639,22 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
|> List.exists (fun Region.{value; _} -> value = "\"inline\"") |> List.exists (fun Region.{value; _} -> value = "\"inline\"")
in return_let_in ~loc binder false inline expr in return_let_in ~loc binder false inline expr
and simpl_param : and compile_param :
Raw.param_decl -> (string * type_expression) result = Raw.param_decl -> (string * type_expression) result =
fun t -> fun t ->
match t with match t with
| ParamConst c -> | ParamConst c ->
let c = c.value in let c = c.value in
let param_name = c.var.value in let param_name = c.var.value in
let%bind type_expression = simpl_type_expression c.param_type in let%bind type_expression = compile_type_expression c.param_type in
ok (param_name , type_expression) ok (param_name , type_expression)
| ParamVar v -> | ParamVar v ->
let c = v.value in let c = v.value in
let param_name = c.var.value in let param_name = c.var.value in
let%bind type_expression = simpl_type_expression c.param_type in let%bind type_expression = compile_type_expression c.param_type in
ok (param_name , type_expression) ok (param_name , type_expression)
and simpl_fun_decl : and compile_fun_decl :
loc:_ -> Raw.fun_decl -> loc:_ -> Raw.fun_decl ->
((expression_variable * type_expression option) * expression) result = ((expression_variable * type_expression option) * expression) result =
fun ~loc x -> fun ~loc x ->
@ -674,11 +674,11 @@ and simpl_fun_decl :
in in
(match param.value.inside with (match param.value.inside with
a, [] -> ( a, [] -> (
let%bind input = simpl_param a in let%bind input = compile_param a in
let (binder , input_type) = input in let (binder , input_type) = input in
let%bind instructions = simpl_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = simpl_expression return in let%bind result = compile_expression return in
let%bind output_type = simpl_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = instructions in let body = instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -699,7 +699,7 @@ and simpl_fun_decl :
let lst = npseq_to_list lst in let lst = npseq_to_list lst in
(* TODO wrong, should be fresh? *) (* TODO wrong, should be fresh? *)
let arguments_name = Var.of_name "arguments" in let arguments_name = Var.of_name "arguments" in
let%bind params = bind_map_list simpl_param lst in let%bind params = bind_map_list compile_param lst in
let (binder , input_type) = let (binder , input_type) =
let type_expression = t_tuple (List.map snd params) in let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in (arguments_name , type_expression) in
@ -712,9 +712,9 @@ and simpl_fun_decl :
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
let%bind instructions = simpl_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = simpl_expression return in let%bind result = compile_expression return in
let%bind output_type = simpl_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = tpl_declarations @ instructions in let body = tpl_declarations @ instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -732,7 +732,7 @@ and simpl_fun_decl :
) )
) )
and simpl_fun_expression : and compile_fun_expression :
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result = loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
fun ~loc x -> fun ~loc x ->
let open! Raw in let open! Raw in
@ -740,11 +740,12 @@ and simpl_fun_expression :
let statements = [] in let statements = [] in
(match param.value.inside with (match param.value.inside with
a, [] -> ( a, [] -> (
let%bind input = simpl_param a in let%bind input = compile_param a in
let (binder , input_type) = input in let (binder , input_type) = input in
let%bind instructions = simpl_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = simpl_expression return in let%bind result = compile_expression return in
let%bind output_type = simpl_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = instructions in let body = instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -762,7 +763,7 @@ and simpl_fun_expression :
let lst = npseq_to_list lst in let lst = npseq_to_list lst in
(* TODO wrong, should be fresh? *) (* TODO wrong, should be fresh? *)
let arguments_name = Var.of_name "arguments" in let arguments_name = Var.of_name "arguments" in
let%bind params = bind_map_list simpl_param lst in let%bind params = bind_map_list compile_param lst in
let (binder , input_type) = let (binder , input_type) =
let type_expression = t_tuple (List.map snd params) in let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in (arguments_name , type_expression) in
@ -774,9 +775,9 @@ and simpl_fun_expression :
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
let%bind instructions = simpl_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = simpl_expression return in let%bind result = compile_expression return in
let%bind output_type = simpl_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = tpl_declarations @ instructions in let body = tpl_declarations @ instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -791,7 +792,7 @@ and simpl_fun_expression :
) )
) )
and simpl_statement_list statements = and compile_statement_list statements =
let open Raw in let open Raw in
let rec hook acc = function let rec hook acc = function
[] -> acc [] -> acc
@ -813,9 +814,9 @@ and simpl_statement_list statements =
(* Detached attributes are erased. TODO: Warning. *) (* Detached attributes are erased. TODO: Warning. *)
hook acc statements hook acc statements
| Instr i :: statements -> | Instr i :: statements ->
hook (simpl_instruction i :: acc) statements hook (compile_instruction i :: acc) statements
| Data d :: statements -> | Data d :: statements ->
hook (simpl_data_declaration d :: acc) statements hook (compile_data_declaration d :: acc) statements
in bind_list @@ hook [] (List.rev statements) in bind_list @@ hook [] (List.rev statements)
and get_case_variables (t:Raw.pattern) : expression_variable list result = and get_case_variables (t:Raw.pattern) : expression_variable list result =
@ -847,7 +848,7 @@ and get_case_variables (t:Raw.pattern) : expression_variable list result =
| PVar v -> ok @@ [Var.of_name v.value] | PVar v -> ok @@ [Var.of_name v.value]
| p -> fail @@ unsupported_cst_constr p | p -> fail @@ unsupported_cst_constr p
and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result = and compile_single_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> fun t ->
match t with match t with
| ProcCall x -> ( | ProcCall x -> (
@ -859,15 +860,15 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let (f_name , f_loc) = r_split name in let (f_name , f_loc) = r_split name in
match constants f_name with match constants f_name with
| Error _ -> | Error _ ->
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Ok (s,_) -> | Ok (s,_) ->
let%bind lst = bind_map_list simpl_expression args' in let%bind lst = bind_map_list compile_expression args' in
return_statement @@ e_constant ~loc s lst return_statement @@ e_constant ~loc s lst
) )
| f -> ( | f -> (
let%bind f' = simpl_expression f in let%bind f' = compile_expression f in
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return_statement @@ e_application ~loc f' arg return_statement @@ e_application ~loc f' arg
) )
) )
@ -876,35 +877,35 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
return_statement @@ e_skip ~loc () return_statement @@ e_skip ~loc ()
) )
| Loop (While l) -> | Loop (While l) ->
simpl_while_loop l.value compile_while_loop l.value
| Loop (For (ForInt fi)) -> ( | Loop (For (ForInt fi)) -> (
let%bind loop = simpl_for_int fi.value in let%bind loop = compile_for_int fi.value in
ok loop ok loop
) )
| Loop (For (ForCollect fc)) -> | Loop (For (ForCollect fc)) ->
let%bind loop = simpl_for_collect fc.value in let%bind loop = compile_for_collect fc.value in
ok loop ok loop
| Cond c -> ( | Cond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = match c.ifso with let%bind match_true = match c.ifso with
ClauseInstr i -> ClauseInstr i ->
simpl_single_instruction i compile_single_instruction i
| ClauseBlock b -> | ClauseBlock b ->
match b with match b with
LongBlock {value; _} -> LongBlock {value; _} ->
simpl_block value compile_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in compile_statements @@ fst value.inside in
let%bind match_false = match c.ifnot with let%bind match_false = match c.ifnot with
ClauseInstr i -> ClauseInstr i ->
simpl_single_instruction i compile_single_instruction i
| ClauseBlock b -> | ClauseBlock b ->
match b with match b with
LongBlock {value; _} -> LongBlock {value; _} ->
simpl_block value compile_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in compile_statements @@ fst value.inside in
let env = Var.fresh () in let env = Var.fresh () in
let%bind match_true' = match_true None in let%bind match_true' = match_true None in
@ -928,10 +929,10 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| Assign a -> ( | Assign a -> (
let (a , loc) = r_split a in let (a , loc) = r_split a in
let%bind value_expr = simpl_expression a.rhs in let%bind value_expr = compile_expression a.rhs in
match a.lhs with match a.lhs with
| Path path -> ( | Path path -> (
let (name , path') = simpl_path path in let (name , path') = compile_path path in
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
return_let_in let_binder mut inline rhs return_let_in let_binder mut inline rhs
) )
@ -940,11 +941,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind (varname,map,path) = match v'.path with let%bind (varname,map,path) = match v'.path with
| Name name -> ok (name.value , e_variable (Var.of_name name.value), []) | Name name -> ok (name.value , e_variable (Var.of_name name.value), [])
| Path p -> | Path p ->
let (name,p') = simpl_path v'.path in let (name,p') = compile_path v'.path in
let%bind accessor = simpl_projection p in let%bind accessor = compile_projection p in
ok @@ (name , accessor , p') ok @@ (name , accessor , p')
in in
let%bind key_expr = simpl_expression v'.index.value.inside in let%bind key_expr = compile_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map in let expr' = e_map_add key_expr value_expr map in
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
return_let_in let_binder mut inline rhs return_let_in let_binder mut inline rhs
@ -952,20 +953,20 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| CaseInstr c -> ( | CaseInstr c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.expr in let%bind expr = compile_expression c.expr in
let env = Var.fresh () in let env = Var.fresh () in
let%bind (fv,cases) = let%bind (fv,cases) =
let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) = let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) =
let%bind case_clause = let%bind case_clause =
match x.value.rhs with match x.value.rhs with
ClauseInstr i -> ClauseInstr i ->
simpl_single_instruction i compile_single_instruction i
| ClauseBlock b -> | ClauseBlock b ->
match b with match b with
LongBlock {value; _} -> LongBlock {value; _} ->
simpl_block value compile_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in compile_statements @@ fst value.inside in
let%bind case_clause'= case_clause @@ None in let%bind case_clause'= case_clause @@ None in
let%bind case_clause = case_clause @@ Some(e_variable env) in let%bind case_clause = case_clause @@ Some(e_variable env) in
let%bind case_vars = get_case_variables x.value.pattern in let%bind case_vars = get_case_variables x.value.pattern in
@ -975,11 +976,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let free_vars = List.concat fv in let free_vars = List.concat fv in
if (List.length free_vars == 0) then ( if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
let%bind m = simpl_cases cases in let%bind m = compile_cases cases in
return_statement @@ e_matching ~loc expr m return_statement @@ e_matching ~loc expr m
) else ( ) else (
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
let%bind m = simpl_cases cases in let%bind m = compile_cases cases in
let match_expr = e_matching ~loc expr m in let match_expr = e_matching ~loc expr m in
let return_expr = fun expr -> let return_expr = fun expr ->
e_let_in (env,None) false false (store_mutable_variable free_vars) @@ e_let_in (env,None) false false (store_mutable_variable free_vars) @@
@ -1001,8 +1002,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
region=r.record_inj.region region=r.record_inj.region
} in } in
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
let%bind expr = simpl_update {value=u;region=reg} in let%bind expr = compile_update {value=u;region=reg} in
let (name , access_path) = simpl_path r.path in let (name , access_path) = compile_path r.path in
let loc = Some loc in let loc = Some loc in
let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in
return_let_in binder mut inline rhs return_let_in binder mut inline rhs
@ -1010,13 +1011,13 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| MapPatch patch -> ( | MapPatch patch -> (
let (map_p, loc) = r_split patch in let (map_p, loc) = r_split patch in
let (name, access_path) = simpl_path map_p.path in let (name, access_path) = compile_path map_p.path in
let%bind inj = bind_list let%bind inj = bind_list
@@ List.map (fun (x:Raw.binding Region.reg) -> @@ List.map (fun (x:Raw.binding Region.reg) ->
let x = x.value in let x = x.value in
let (key, value) = x.source, x.image in let (key, value) = x.source, x.image in
let%bind key' = simpl_expression key in let%bind key' = compile_expression key in
let%bind value' = simpl_expression value let%bind value' = compile_expression value
in ok @@ (key', value') in ok @@ (key', value')
) )
@@ npseq_to_list map_p.map_inj.value.ne_elements in @@ npseq_to_list map_p.map_inj.value.ne_elements in
@ -1033,10 +1034,10 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| SetPatch patch -> ( | SetPatch patch -> (
let (setp, loc) = r_split patch in let (setp, loc) = r_split patch in
let (name , access_path) = simpl_path setp.path in let (name , access_path) = compile_path setp.path in
let%bind inj = let%bind inj =
bind_list @@ bind_list @@
List.map simpl_expression @@ List.map compile_expression @@
npseq_to_list setp.set_inj.value.ne_elements in npseq_to_list setp.set_inj.value.ne_elements in
match inj with match inj with
| [] -> return_statement @@ e_skip ~loc () | [] -> return_statement @@ e_skip ~loc ()
@ -1053,11 +1054,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind (varname,map,path) = match v.map with let%bind (varname,map,path) = match v.map with
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , []) | Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
| Path p -> | Path p ->
let (name,p') = simpl_path v.map in let (name,p') = compile_path v.map in
let%bind accessor = simpl_projection p in let%bind accessor = compile_projection p in
ok @@ (name , accessor , p') ok @@ (name , accessor , p')
in in
let%bind key' = simpl_expression key in let%bind key' = compile_expression key in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs return_let_in binder mut inline rhs
@ -1067,17 +1068,17 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind (varname, set, path) = match set_rm.set with let%bind (varname, set, path) = match set_rm.set with
| Name v -> ok (v.value, e_variable (Var.of_name v.value), []) | Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
| Path path -> | Path path ->
let(name, p') = simpl_path set_rm.set in let(name, p') = compile_path set_rm.set in
let%bind accessor = simpl_projection path in let%bind accessor = compile_projection path in
ok @@ (name, accessor, p') ok @@ (name, accessor, p')
in in
let%bind removed' = simpl_expression set_rm.element in let%bind removed' = compile_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs return_let_in binder mut inline rhs
) )
and simpl_path : Raw.path -> string * string list = fun p -> and compile_path : Raw.path -> string * string list = fun p ->
match p with match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
@ -1094,7 +1095,7 @@ and simpl_path : Raw.path -> string * string list = fun p ->
(var , path') (var , path')
) )
and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun t -> and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
let open Raw in let open Raw in
let get_var (t:Raw.pattern) = let get_var (t:Raw.pattern) =
match t with match t with
@ -1185,13 +1186,13 @@ and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun
bind_map_list aux lst in bind_map_list aux lst in
ok @@ ez_match_variant constrs ok @@ ez_match_variant constrs
and simpl_instruction : Raw.instruction -> (_ -> expression result) result = and compile_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> trace (simplifying_instruction t) @@ simpl_single_instruction t fun t -> trace (abstracting_instruction t) @@ compile_single_instruction t
and simpl_statements : Raw.statements -> (_ -> expression result) result = and compile_statements : Raw.statements -> (_ -> expression result) result =
fun statements -> fun statements ->
let lst = npseq_to_list statements in let lst = npseq_to_list statements in
let%bind fs = simpl_statement_list lst in let%bind fs = compile_statement_list lst in
let aux : _ -> (expression option -> expression result) -> _ = let aux : _ -> (expression option -> expression result) -> _ =
fun prec cur -> fun prec cur ->
let%bind res = cur prec let%bind res = cur prec
@ -1200,19 +1201,19 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result =
let%bind ret = bind_fold_right_list aux expr' fs in let%bind ret = bind_fold_right_list aux expr' fs in
ok @@ Option.unopt_exn ret ok @@ Option.unopt_exn ret
and simpl_block : Raw.block -> (_ -> expression result) result = and compile_block : Raw.block -> (_ -> expression result) result =
fun t -> simpl_statements t.statements fun t -> compile_statements t.statements
and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl -> and compile_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl ->
let env_rec = Var.fresh () in let env_rec = Var.fresh () in
let binder = Var.fresh () in let binder = Var.fresh () in
let%bind cond = simpl_expression wl.cond in let%bind cond = compile_expression wl.cond in
let ctrl = let ctrl =
(e_variable binder) (e_variable binder)
in in
let%bind for_body = simpl_block wl.block.value in let%bind for_body = compile_block wl.block.value in
let%bind for_body = for_body @@ Some( ctrl ) in let%bind for_body = for_body @@ Some( ctrl ) in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in
@ -1237,15 +1238,15 @@ and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun w
restore_mutable_variable return_expr captured_name_list env_rec restore_mutable_variable return_expr captured_name_list env_rec
and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> and compile_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
let env_rec = Var.fresh () in let env_rec = Var.fresh () in
let binder = Var.fresh () in let binder = Var.fresh () in
let name = fi.assign.value.name.value in let name = fi.assign.value.name.value in
let it = Var.of_name name in let it = Var.of_name name in
let var = e_variable it in let var = e_variable it in
(*Make the cond and the step *) (*Make the cond and the step *)
let%bind value = simpl_expression fi.assign.value.expr in let%bind value = compile_expression fi.assign.value.expr in
let%bind bound = simpl_expression fi.bound in let%bind bound = compile_expression fi.bound in
let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
let step = e_int 1 in let step = e_int 1 in
let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in
@ -1255,7 +1256,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
continue_expr continue_expr
in in
(* Modify the body loop*) (* Modify the body loop*)
let%bind for_body = simpl_block fi.block.value in let%bind for_body = compile_block fi.block.value in
let%bind for_body = for_body @@ Some ctrl in let%bind for_body = for_body @@ Some ctrl in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in
@ -1285,19 +1286,19 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
in in
restore_mutable_variable return_expr captured_name_list env_rec restore_mutable_variable return_expr captured_name_list env_rec
and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> and compile_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
let binder = Var.of_name "arguments" in let binder = Var.of_name "arguments" in
let%bind element_names = ok @@ match fc.bind_to with let%bind element_names = ok @@ match fc.bind_to with
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [Var.of_name fc.var.value] in | None -> [Var.of_name fc.var.value] in
let env = Var.fresh () in let env = Var.fresh () in
let%bind for_body = simpl_block fc.block.value in let%bind for_body = compile_block fc.block.value in
let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in
let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in
let init_record = store_mutable_variable free_vars in let init_record = store_mutable_variable free_vars in
let%bind collect = simpl_expression fc.expr in let%bind collect = compile_expression fc.expr in
let aux name expr= let aux name expr=
e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr
in in
@ -1319,8 +1320,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
in in
restore_mutable_variable fold free_vars env restore_mutable_variable fold free_vars env
and simpl_declaration_list declarations : and compile_declaration_list declarations : declaration Location.wrap list result =
Ast_simplified.declaration Location.wrap list result =
let open Raw in let open Raw in
let rec hook acc = function let rec hook acc = function
[] -> acc [] -> acc
@ -1344,16 +1344,16 @@ and simpl_declaration_list declarations :
| TypeDecl decl :: declarations -> | TypeDecl decl :: declarations ->
let decl, loc = r_split decl in let decl, loc = r_split decl in
let {name; type_expr} : Raw.type_decl = decl in let {name; type_expr} : Raw.type_decl = decl in
let%bind type_expression = simpl_type_expression type_expr in let%bind type_expression = compile_type_expression type_expr in
let new_decl = let new_decl =
Declaration_type (Var.of_name name.value, type_expression) in Declaration_type (Var.of_name name.value, type_expression) in
let res = Location.wrap ~loc new_decl in let res = Location.wrap ~loc new_decl in
hook (bind_list_cons res acc) declarations hook (bind_list_cons res acc) declarations
| ConstDecl decl :: declarations -> | ConstDecl decl :: declarations ->
let simpl_const_decl = let compile_const_decl =
fun {name;const_type; init; attributes} -> fun {name;const_type; init; attributes} ->
let%bind expression = simpl_expression init in let%bind expression = compile_expression init in
let%bind t = simpl_type_expression const_type in let%bind t = compile_type_expression const_type in
let type_annotation = Some t in let type_annotation = Some t in
let inline = let inline =
match attributes with match attributes with
@ -1366,11 +1366,11 @@ and simpl_declaration_list declarations :
(Var.of_name name.value, type_annotation, inline, expression) (Var.of_name name.value, type_annotation, inline, expression)
in ok new_decl in in ok new_decl in
let%bind res = let%bind res =
bind_map_location simpl_const_decl (Location.lift_region decl) bind_map_location compile_const_decl (Location.lift_region decl)
in hook (bind_list_cons res acc) declarations in hook (bind_list_cons res acc) declarations
| FunDecl fun_decl :: declarations -> | FunDecl fun_decl :: declarations ->
let decl, loc = r_split fun_decl in let decl, loc = r_split fun_decl in
let%bind ((name, ty_opt), expr) = simpl_fun_decl ~loc decl in let%bind ((name, ty_opt), expr) = compile_fun_decl ~loc decl in
let inline = let inline =
match fun_decl.value.attributes with match fun_decl.value.attributes with
None -> false None -> false
@ -1383,5 +1383,5 @@ and simpl_declaration_list declarations :
hook (bind_list_cons res acc) declarations hook (bind_list_cons res acc) declarations
in hook (ok @@ []) (List.rev declarations) in hook (ok @@ []) (List.rev declarations)
let simpl_program : Raw.ast -> program result = let compile_program : Raw.ast -> program result =
fun t -> simpl_declaration_list @@ nseq_to_list t.decl fun t -> compile_declaration_list @@ nseq_to_list t.decl

15
src/passes/2-concrete_to_imperative/pascaligo.mli Normal file
View File

@ -0,0 +1,15 @@
(** Converts PascaLIGO programs to the Simplified Abstract Syntax Tree. *)
open Trace
open Ast_imperative
module Raw = Parser.Pascaligo.AST
module SMap = Map.String
(** Convert a concrete PascaLIGO expression AST to the imperative
expression AST used by the compiler. *)
val compile_expression : Raw.expr -> expr result
(** Convert a concrete PascaLIGO program AST to the miperative program
AST used by the compiler. *)
val compile_program : Raw.ast -> program result

15
src/passes/2-simplify/pascaligo.mli
View File

@ -1,15 +0,0 @@
(** Converts PascaLIGO programs to the Simplified Abstract Syntax Tree. *)
open Trace
open Ast_simplified
module Raw = Parser.Pascaligo.AST
module SMap = Map.String
(** Convert a concrete PascaLIGO expression AST to the simplified
expression AST used by the compiler. *)
val simpl_expression : Raw.expr -> expr result
(** Convert a concrete PascaLIGO program AST to the simplified program
AST used by the compiler. *)
val simpl_program : Raw.ast -> program result

6
src/passes/3-self_ast_simplified/dune → src/passes/3-self_ast_imperative/dune
View File

@ -1,9 +1,9 @@
(library (library
(name self_ast_simplified) (name self_ast_imperative)
(public_name ligo.self_ast_simplified) (public_name ligo.self_ast_imperative)
(libraries (libraries
simple-utils simple-utils
ast_simplified ast_imperative
proto-alpha-utils proto-alpha-utils
) )
(preprocess (preprocess

2
src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml → src/passes/3-self_ast_imperative/entrypoints_lenght_limit.ml
View File

@ -1,4 +1,4 @@
open Ast_simplified open Ast_imperative
open Trace open Trace
open Stage_common.Helpers open Stage_common.Helpers

33
src/passes/3-self_ast_simplified/helpers.ml → src/passes/3-self_ast_imperative/helpers.ml
View File

@ -1,4 +1,4 @@
open Ast_simplified open Ast_imperative
open Trace open Trace
open Stage_common.Helpers open Stage_common.Helpers
@ -19,8 +19,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
| E_look_up ab -> | E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
ok res ok res
| E_application {expr1;expr2} -> ( | E_application {lamb;args} -> (
let ab = (expr1,expr2) in let ab = (lamb,args) in
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
ok res ok res
) )
@ -59,6 +59,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
| E_recursive { lambda={result=e;_}; _} -> | E_recursive { lambda={result=e;_}; _} ->
let%bind res = self init' e in let%bind res = self init' e in
ok res ok res
| E_sequence {expr1;expr2} ->
let ab = (expr1,expr2) in
let%bind res = bind_fold_pair self init' ab in
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with match m with
@ -145,10 +150,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind e' = self c.element in let%bind e' = self c.element in
return @@ E_constructor {c with element = e'} return @@ E_constructor {c with element = e'}
) )
| E_application {expr1;expr2} -> ( | E_application {lamb;args} -> (
let ab = (expr1,expr2) in let ab = (lamb,args) in
let%bind (a,b) = bind_map_pair self ab in let%bind (lamb,args) = bind_map_pair self ab in
return @@ E_application {expr1=a;expr2=b} return @@ E_application {lamb;args}
) )
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
let%bind rhs = self rhs in let%bind rhs = self rhs in
@ -167,6 +172,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind args = bind_map_list self c.arguments in let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args} return @@ E_constant {c with arguments=args}
) )
| E_sequence {expr1;expr2} -> (
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
return @@ E_sequence {expr1;expr2}
)
| E_literal _ | E_variable _ | E_skip as e' -> return e' | E_literal _ | E_variable _ | E_skip as e' -> return e'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
@ -288,10 +297,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,e') = self init' c.element in let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'}) ok (res, return @@ E_constructor {c with element = e'})
) )
| E_application {expr1;expr2} -> ( | E_application {lamb;args} -> (
let ab = (expr1,expr2) in let ab = (lamb,args) in
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
ok (res, return @@ E_application {expr1=a;expr2=b}) ok (res, return @@ E_application {lamb=a;args=b})
) )
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
let%bind (res,rhs) = self init' rhs in let%bind (res,rhs) = self init' rhs in
@ -310,6 +319,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,args) = bind_fold_map_list self init' c.arguments in let%bind (res,args) = bind_fold_map_list self init' c.arguments in
ok (res, return @@ E_constant {c with arguments=args}) ok (res, return @@ E_constant {c with arguments=args})
) )
| E_sequence {expr1;expr2} -> (
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
ok (res, return @@ E_sequence {expr1;expr2})
)
| E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e')
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->

4
src/passes/3-self_ast_simplified/literals.ml → src/passes/3-self_ast_imperative/literals.ml
View File

@ -1,4 +1,4 @@
open Ast_simplified open Ast_imperative
open Trace open Trace
open Proto_alpha_utils open Proto_alpha_utils
@ -6,7 +6,7 @@ module Errors = struct
let bad_format e () = let bad_format e () =
let title = (thunk ("Badly formatted literal")) in let title = (thunk ("Badly formatted literal")) in
let message () = Format.asprintf "%a" Ast_simplified.PP.expression e in let message () = Format.asprintf "%a" PP.expression e in
let data = [ let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp e.location) ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
] in ] in

2
src/passes/3-self_ast_simplified/none_variant.ml → src/passes/3-self_ast_imperative/none_variant.ml
View File

@ -1,4 +1,4 @@
open Ast_simplified open Ast_imperative
open Trace open Trace
let peephole_expression : expression -> expression result = fun e -> let peephole_expression : expression -> expression result = fun e ->

0
src/passes/3-self_ast_simplified/self_ast_simplified.ml → src/passes/3-self_ast_imperative/self_ast_imperative.ml
View File

2
src/passes/3-self_ast_simplified/tezos_type_annotation.ml → src/passes/3-self_ast_imperative/tezos_type_annotation.ml
View File

@ -1,4 +1,4 @@
open Ast_simplified open Ast_imperative
open Trace open Trace
module Errors = struct module Errors = struct

14
src/passes/4-imperative_to_sugar/dune Normal file
View File

@ -0,0 +1,14 @@
(library
(name imperative_to_sugar)
(public_name ligo.imperative_to_sugar)
(libraries
simple-utils
ast_imperative
ast_sugar
proto-alpha-utils
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
)

363
src/passes/4-imperative_to_sugar/imperative_to_sugar.ml Normal file
View File

@ -0,0 +1,363 @@
module I = Ast_imperative
module O = Ast_sugar
open Trace
let rec compile_type_expression : I.type_expression -> O.type_expression result =
fun te ->
let return te = ok @@ O.make_t te in
match te.type_content with
| I.T_sum sum ->
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let%bind v = compile_type_expression v in
ok @@ (k,v)
) sum
in
return @@ O.T_sum (O.CMap.of_list sum)
| I.T_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v = compile_type_expression v in
ok @@ (k,v)
) record
in
return @@ O.T_record (O.LMap.of_list record)
| I.T_arrow {type1;type2} ->
let%bind type1 = compile_type_expression type1 in
let%bind type2 = compile_type_expression type2 in
return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator type_operator ->
let%bind type_operator = compile_type_operator type_operator in
return @@ T_operator type_operator
and compile_type_operator : I.type_operator -> O.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = compile_type_expression c in
ok @@ O.TC_contract c
| TC_option o ->
let%bind o = compile_type_expression o in
ok @@ O.TC_option o
| TC_list l ->
let%bind l = compile_type_expression l in
ok @@ O.TC_list l
| TC_set s ->
let%bind s = compile_type_expression s in
ok @@ O.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_map (k,v)
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_big_map (k,v)
| TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in
ok @@ O.TC_arrow (i,o)
let rec compile_expression : I.expression -> O.expression result =
fun e ->
let return expr = ok @@ O.make_expr ~loc:e.location expr in
match e.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
return @@ O.E_constant {cons_name;arguments}
| I.E_variable name -> return @@ O.E_variable name
| I.E_application {lamb;args} ->
let%bind lamb = compile_expression lamb in
let%bind args = compile_expression args in
return @@ O.E_application {lamb;args}
| I.E_lambda lambda ->
let%bind lambda = compile_lambda lambda in
return @@ O.E_lambda lambda
| I.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = compile_type_expression fun_type in
let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda}
| I.E_let_in {let_binder;mut=_;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind rhs = compile_expression rhs in
let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| I.E_constructor {constructor;element} ->
let%bind element = compile_expression element in
return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} ->
let%bind matchee = compile_expression matchee in
let%bind cases = compile_matching cases in
return @@ O.E_matching {matchee;cases}
| I.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v =compile_expression v in
ok @@ (k,v)
) record
in
return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {expr;label} ->
let%bind expr = compile_expression expr in
return @@ O.E_record_accessor {expr;label}
| I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in
let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update}
| I.E_map map ->
let%bind map = bind_map_list (
bind_map_pair compile_expression
) map
in
return @@ O.E_map map
| I.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair compile_expression
) big_map
in
return @@ O.E_big_map big_map
| I.E_list lst ->
let%bind lst = bind_map_list compile_expression lst in
return @@ O.E_list lst
| I.E_set set ->
let%bind set = bind_map_list compile_expression set in
return @@ O.E_set set
| I.E_look_up look_up ->
let%bind look_up = bind_map_pair compile_expression look_up in
return @@ O.E_look_up look_up
| I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = compile_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in
return @@ O.E_sequence {expr1; expr2}
| I.E_skip -> return @@ O.E_skip
and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option compile_type_expression input_type in
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 : I.matching_expr -> O.matching_expr result =
fun m ->
match m with
| I.Match_bool {match_true;match_false} ->
let%bind match_true = compile_expression match_true in
let%bind match_false = compile_expression match_false in
ok @@ O.Match_bool {match_true;match_false}
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr = compile_expression expr in
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| I.Match_option {match_none;match_some} ->
let%bind match_none = compile_expression match_none in
let (n,expr,tv) = match_some in
let%bind expr = compile_expression expr in
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
| I.Match_tuple ((lst,expr), tv) ->
let%bind expr = compile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = compile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ O.Match_variant (lst,tv)
let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in
match declaration with
| 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)
| I.Declaration_type (n, te) ->
let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te)
let compile_program : I.program -> O.program result =
fun p ->
bind_map_list compile_declaration p
(* uncompiling *)
let rec uncompile_type_expression : O.type_expression -> I.type_expression 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%bind v = uncompile_type_expression v 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%bind v = uncompile_type_expression v in
ok @@ (k,v)
) record
in
return @@ I.T_record (O.LMap.of_list record)
| O.T_arrow {type1;type2} ->
let%bind type1 = uncompile_type_expression type1 in
let%bind type2 = uncompile_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 ->
let%bind type_operator = uncompile_type_operator type_operator in
return @@ T_operator type_operator
and uncompile_type_operator : O.type_operator -> I.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_contract c
| TC_option o ->
let%bind o = uncompile_type_expression o in
ok @@ I.TC_option o
| TC_list l ->
let%bind l = uncompile_type_expression l in
ok @@ I.TC_list l
| TC_set s ->
let%bind s = uncompile_type_expression s in
ok @@ I.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_map (k,v)
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v)
| TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o)
let rec uncompile_expression : O.expression -> I.expression result =
fun e ->
let return expr = ok @@ I.make_expr ~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 uncompile_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 = uncompile_expression lamb in
let%bind args = uncompile_expression args in
return @@ I.E_application {lamb; args}
| O.E_lambda lambda ->
let%bind lambda = uncompile_lambda lambda in
return @@ I.E_lambda lambda
| O.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = uncompile_type_expression fun_type in
let%bind lambda = uncompile_lambda lambda in
return @@ I.E_recursive {fun_name;fun_type;lambda}
| O.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression rhs in
let%bind let_result = uncompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
| O.E_constructor {constructor;element} ->
let%bind element = uncompile_expression element in
return @@ I.E_constructor {constructor;element}
| O.E_matching {matchee; cases} ->
let%bind matchee = uncompile_expression matchee in
let%bind cases = uncompile_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 = uncompile_expression v in
ok @@ (k,v)
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {expr;label} ->
let%bind expr = uncompile_expression expr in
return @@ I.E_record_accessor {expr;label}
| O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in
return @@ I.E_record_update {record;path;update}
| O.E_map map ->
let%bind map = bind_map_list (
bind_map_pair uncompile_expression
) map
in
return @@ I.E_map map
| O.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair uncompile_expression
) big_map
in
return @@ I.E_big_map big_map
| O.E_list lst ->
let%bind lst = bind_map_list uncompile_expression lst in
return @@ I.E_list lst
| O.E_set set ->
let%bind set = bind_map_list uncompile_expression set in
return @@ I.E_set set
| O.E_look_up look_up ->
let%bind look_up = bind_map_pair uncompile_expression look_up in
return @@ I.E_look_up look_up
| O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation}
| O.E_sequence {expr1; expr2} ->
let%bind expr1 = uncompile_expression expr1 in
let%bind expr2 = uncompile_expression expr2 in
return @@ I.E_sequence {expr1; expr2}
| O.E_skip -> return @@ I.E_skip
and uncompile_lambda : O.lambda -> I.lambda result =
fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option uncompile_type_expression input_type in
let%bind output_type = bind_map_option uncompile_type_expression output_type in
let%bind result = uncompile_expression result in
ok @@ I.{binder;input_type;output_type;result}
and uncompile_matching : O.matching_expr -> I.matching_expr result =
fun m ->
match m with
| O.Match_bool {match_true;match_false} ->
let%bind match_true = uncompile_expression match_true in
let%bind match_false = uncompile_expression match_false in
ok @@ I.Match_bool {match_true;match_false}
| O.Match_list {match_nil;match_cons} ->
let%bind match_nil = uncompile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| O.Match_option {match_none;match_some} ->
let%bind match_none = uncompile_expression match_none in
let (n,expr,tv) = match_some in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
| O.Match_tuple ((lst,expr), tv) ->
let%bind expr = uncompile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| O.Match_variant (lst,tv) ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = uncompile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ I.Match_variant (lst,tv)

13
src/passes/5-self_ast_sugar/dune Normal file
View File

@ -0,0 +1,13 @@
(library
(name self_ast_sugar)
(public_name ligo.self_ast_sugar)
(libraries
simple-utils
ast_sugar
proto-alpha-utils
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
)

0
src/passes/5-self_ast_typed/main.ml
View File

14
src/passes/6-sugar_to_core/dune Normal file
View File

@ -0,0 +1,14 @@
(library
(name sugar_to_core)
(public_name ligo.sugar_to_core)
(libraries
simple-utils
ast_sugar
ast_core
proto-alpha-utils
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
)

363
src/passes/6-sugar_to_core/sugar_to_core.ml Normal file
View File

@ -0,0 +1,363 @@
module I = Ast_sugar
module O = Ast_core
open Trace
let rec idle_type_expression : I.type_expression -> O.type_expression result =
fun te ->
let return te = ok @@ O.make_t te in
match te.type_content with
| I.T_sum sum ->
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let%bind v = idle_type_expression v in
ok @@ (k,v)
) sum
in
return @@ O.T_sum (O.CMap.of_list sum)
| I.T_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v = idle_type_expression v in
ok @@ (k,v)
) record
in
return @@ O.T_record (O.LMap.of_list record)
| I.T_arrow {type1;type2} ->
let%bind type1 = idle_type_expression type1 in
let%bind type2 = idle_type_expression type2 in
return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator type_operator ->
let%bind type_operator = idle_type_operator type_operator in
return @@ T_operator type_operator
and idle_type_operator : I.type_operator -> O.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = idle_type_expression c in
ok @@ O.TC_contract c
| TC_option o ->
let%bind o = idle_type_expression o in
ok @@ O.TC_option o
| TC_list l ->
let%bind l = idle_type_expression l in
ok @@ O.TC_list l
| TC_set s ->
let%bind s = idle_type_expression s in
ok @@ O.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_map (k,v)
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_big_map (k,v)
| TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in
ok @@ O.TC_arrow (i,o)
let rec compile_expression : I.expression -> O.expression result =
fun e ->
let return expr = ok @@ O.make_expr ~loc:e.location expr in
match e.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
return @@ O.E_constant {cons_name;arguments}
| I.E_variable name -> return @@ O.E_variable name
| I.E_application {lamb;args} ->
let%bind lamb = compile_expression lamb in
let%bind args = compile_expression args in
return @@ O.E_application {lamb; args}
| I.E_lambda lambda ->
let%bind lambda = compile_lambda lambda in
return @@ O.E_lambda lambda
| I.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = idle_type_expression fun_type in
let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda}
| I.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option idle_type_expression ty_opt in
let%bind rhs = compile_expression rhs in
let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| I.E_constructor {constructor;element} ->
let%bind element = compile_expression element in
return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} ->
let%bind matchee = compile_expression matchee in
let%bind cases = compile_matching cases in
return @@ O.E_matching {matchee;cases}
| I.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v =compile_expression v in
ok @@ (k,v)
) record
in
return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {expr;label} ->
let%bind expr = compile_expression expr in
return @@ O.E_record_accessor {expr;label}
| I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in
let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update}
| I.E_map map ->
let%bind map = bind_map_list (
bind_map_pair compile_expression
) map
in
return @@ O.E_map map
| I.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair compile_expression
) big_map
in
return @@ O.E_big_map big_map
| I.E_list lst ->
let%bind lst = bind_map_list compile_expression lst in
return @@ O.E_list lst
| I.E_set set ->
let%bind set = bind_map_list compile_expression set in
return @@ O.E_set set
| I.E_look_up look_up ->
let%bind look_up = bind_map_pair compile_expression look_up in
return @@ O.E_look_up look_up
| I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_sequence {expr1; expr2} ->
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 ()
and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option idle_type_expression input_type in
let%bind output_type = bind_map_option idle_type_expression output_type in
let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result}
and compile_matching : I.matching_expr -> O.matching_expr result =
fun m ->
match m with
| I.Match_bool {match_true;match_false} ->
let%bind match_true = compile_expression match_true in
let%bind match_false = compile_expression match_false in
ok @@ O.Match_bool {match_true;match_false}
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr = compile_expression expr in
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| I.Match_option {match_none;match_some} ->
let%bind match_none = compile_expression match_none in
let (n,expr,tv) = match_some in
let%bind expr = compile_expression expr in
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
| I.Match_tuple ((lst,expr), tv) ->
let%bind expr = compile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = compile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ O.Match_variant (lst,tv)
let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in
match declaration with
| I.Declaration_constant (n, te_opt, inline, expr) ->
let%bind expr = compile_expression expr in
let%bind te_opt = bind_map_option idle_type_expression te_opt in
return @@ O.Declaration_constant (n, te_opt, inline, expr)
| I.Declaration_type (n, te) ->
let%bind te = idle_type_expression te in
return @@ O.Declaration_type (n,te)
let compile_program : I.program -> O.program result =
fun p ->
bind_map_list compile_declaration p
(* uncompiling *)
let rec uncompile_type_expression : O.type_expression -> I.type_expression 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%bind v = uncompile_type_expression v 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%bind v = uncompile_type_expression v in
ok @@ (k,v)
) record
in
return @@ I.T_record (O.LMap.of_list record)
| O.T_arrow {type1;type2} ->
let%bind type1 = uncompile_type_expression type1 in
let%bind type2 = uncompile_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 ->
let%bind type_operator = uncompile_type_operator type_operator in
return @@ T_operator type_operator
and uncompile_type_operator : O.type_operator -> I.type_operator result =
fun t_o ->
match t_o with
| TC_contract c ->
let%bind c = uncompile_type_expression c in
ok @@ I.TC_contract c
| TC_option o ->
let%bind o = uncompile_type_expression o in
ok @@ I.TC_option o
| TC_list l ->
let%bind l = uncompile_type_expression l in
ok @@ I.TC_list l
| TC_set s ->
let%bind s = uncompile_type_expression s in
ok @@ I.TC_set s
| TC_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_map (k,v)
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v)
| TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o)
let rec uncompile_expression : O.expression -> I.expression result =
fun e ->
let return expr = ok @@ I.make_expr ~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 uncompile_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 = uncompile_expression lamb in
let%bind args = uncompile_expression args in
return @@ I.E_application {lamb; args}
| O.E_lambda lambda ->
let%bind lambda = uncompile_lambda lambda in
return @@ I.E_lambda lambda
| O.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = uncompile_type_expression fun_type in
let%bind lambda = uncompile_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 = uncompile_expression expr1 in
let%bind expr2 = uncompile_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 uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression rhs in
let%bind let_result = uncompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| O.E_constructor {constructor;element} ->
let%bind element = uncompile_expression element in
return @@ I.E_constructor {constructor;element}
| O.E_matching {matchee; cases} ->
let%bind matchee = uncompile_expression matchee in
let%bind cases = uncompile_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 = uncompile_expression v in
ok @@ (k,v)
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {expr;label} ->
let%bind expr = uncompile_expression expr in
return @@ I.E_record_accessor {expr;label}
| O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in
return @@ I.E_record_update {record;path;update}
| O.E_map map ->
let%bind map = bind_map_list (
bind_map_pair uncompile_expression
) map
in
return @@ I.E_map map
| O.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair uncompile_expression
) big_map
in
return @@ I.E_big_map big_map
| O.E_list lst ->
let%bind lst = bind_map_list uncompile_expression lst in
return @@ I.E_list lst
| O.E_set set ->
let%bind set = bind_map_list uncompile_expression set in
return @@ I.E_set set
| O.E_look_up look_up ->
let%bind look_up = bind_map_pair uncompile_expression look_up in
return @@ I.E_look_up look_up
| O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation}
and uncompile_lambda : O.lambda -> I.lambda result =
fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option uncompile_type_expression input_type in
let%bind output_type = bind_map_option uncompile_type_expression output_type in
let%bind result = uncompile_expression result in
ok @@ I.{binder;input_type;output_type;result}
and uncompile_matching : O.matching_expr -> I.matching_expr result =
fun m ->
match m with
| O.Match_bool {match_true;match_false} ->
let%bind match_true = uncompile_expression match_true in
let%bind match_false = uncompile_expression match_false in
ok @@ I.Match_bool {match_true;match_false}
| O.Match_list {match_nil;match_cons} ->
let%bind match_nil = uncompile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| O.Match_option {match_none;match_some} ->
let%bind match_none = uncompile_expression match_none in
let (n,expr,tv) = match_some in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
| O.Match_tuple ((lst,expr), tv) ->
let%bind expr = uncompile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| O.Match_variant (lst,tv) ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = uncompile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ I.Match_variant (lst,tv)

13
src/passes/7-self_ast_core/dune Normal file
View File

@ -0,0 +1,13 @@
(library
(name self_ast_core)
(public_name ligo.self_ast_core)
(libraries
simple-utils
ast_core
proto-alpha-utils
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
)

0
src/passes/4-typer-new/PP.ml → src/passes/8-typer-new/PP.ml
View File

2
src/passes/4-typer-new/dune → src/passes/8-typer-new/dune
View File

@ -4,7 +4,7 @@
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
ast_simplified ast_core
ast_typed ast_typed
operators operators
UnionFind UnionFind

2
src/passes/4-typer-new/solver.ml → src/passes/8-typer-new/solver.ml
View File

@ -3,7 +3,7 @@ open Trace
module Core = Typesystem.Core module Core = Typesystem.Core
module Wrap = struct module Wrap = struct
module I = Ast_simplified module I = Ast_core
module T = Ast_typed module T = Ast_typed
module O = Core module O = Core

38
src/passes/4-typer-new/typer.ml → src/passes/8-typer-new/typer.ml
View File

@ -1,6 +1,6 @@
open Trace open Trace
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
open O.Combinators open O.Combinators
@ -446,10 +446,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
| E_literal (Literal_void) -> ( | E_literal (Literal_void) -> (
failwith "TODO: missing implementation for literal void" failwith "TODO: missing implementation for literal void"
) )
| E_skip -> (
(* E_skip just returns unit *)
return_wrapped (e_unit ()) state @@ Wrap.literal (t_unit ())
)
(* | E_literal (Literal_string s) -> ( (* | E_literal (Literal_string s) -> (
* L.log (Format.asprintf "literal_string option type: %a" PP_helpers.(option O.PP.type_expression) tv_opt) ; * L.log (Format.asprintf "literal_string option type: %a" PP_helpers.(option O.PP.type_expression) tv_opt) ;
* match Option.map Ast_typed.get_type' tv_opt with * match Option.map Ast_typed.get_type' tv_opt with
@ -683,11 +679,11 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
* let%bind (name', tv) = * let%bind (name', tv) =
* type_constant name tv_lst tv_opt ae.location in * type_constant name tv_lst tv_opt ae.location in
* return (E_constant (name' , lst')) tv *) * return (E_constant (name' , lst')) tv *)
| E_application {expr1;expr2} -> | E_application {lamb;args} ->
let%bind (f' , state') = type_expression e state expr1 in let%bind (f' , state') = type_expression e state lamb in
let%bind (arg , state'') = type_expression e state' expr2 in let%bind (args , state'') = type_expression e state' args in
let wrapped = Wrap.application f'.type_expression arg.type_expression in let wrapped = Wrap.application f'.type_expression args.type_expression in
return_wrapped (E_application {expr1=f';expr2=arg}) state'' wrapped return_wrapped (E_application {lamb=f';args}) state'' wrapped
(* | E_look_up dsi -> (* | E_look_up dsi ->
* let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in * let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in
@ -872,7 +868,7 @@ let untype_type_value (t:O.type_expression) : (I.type_expression) result =
(* TODO: we ended up with two versions of type_program… ??? *) (* TODO: we ended up with two versions of type_program… ??? *)
(* (*
Apply type_declaration on all the node of the AST_simplified from the root p Apply type_declaration on all the node of the AST_core from the root p
*) *)
let type_program_returns_state ((env, state, p) : environment * Solver.state * I.program) : (environment * Solver.state * O.program) result = let type_program_returns_state ((env, state, p) : environment * Solver.state * I.program) : (environment * Solver.state * O.program) result =
let aux ((e : environment), (s : Solver.state) , (ds : O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = let aux ((e : environment), (s : Solver.state) , (ds : O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
@ -950,10 +946,10 @@ let type_program' : I.program -> O.program result = fun p ->
ok p' ok p'
(* (*
Tranform a Ast_typed type_expression into an ast_simplified type_expression Tranform a Ast_typed type_expression into an ast_core type_expression
*) *)
let rec untype_type_expression (t:O.type_expression) : (I.type_expression) result = let rec untype_type_expression (t:O.type_expression) : (I.type_expression) result =
(* TODO: or should we use t.simplified if present? *) (* TODO: or should we use t.core if present? *)
let%bind t = match t.type_content with let%bind t = match t.type_content with
| O.T_sum x -> | O.T_sum x ->
let%bind x' = Stage_common.Helpers.bind_map_cmap untype_type_expression x in let%bind x' = Stage_common.Helpers.bind_map_cmap untype_type_expression x in
@ -999,13 +995,13 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
in in
ok @@ I.make_t t ok @@ I.make_t t
(* match t.simplified with *) (* match t.core with *)
(* | Some s -> ok s *) (* | Some s -> ok s *)
(* | _ -> fail @@ internal_assertion_failure "trying to untype generated type" *) (* | _ -> fail @@ internal_assertion_failure "trying to untype generated type" *)
(* (*
Tranform a Ast_typed literal into an ast_simplified literal Tranform a Ast_typed literal into an ast_core literal
*) *)
let untype_literal (l:O.literal) : I.literal result = let untype_literal (l:O.literal) : I.literal result =
let open I in let open I in
@ -1027,7 +1023,7 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_operation s -> ok (Literal_operation s) | Literal_operation s -> ok (Literal_operation s)
(* (*
Tranform a Ast_typed expression into an ast_simplified matching Tranform a Ast_typed expression into an ast_core matching
*) *)
let rec untype_expression (e:O.expression) : (I.expression) result = let rec untype_expression (e:O.expression) : (I.expression) result =
let open I in let open I in
@ -1041,9 +1037,9 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
return (e_constant cons_name lst') return (e_constant cons_name lst')
| E_variable (n) -> | E_variable (n) ->
return (e_variable (n)) return (e_variable (n))
| E_application {expr1;expr2} -> | E_application {lamb;args} ->
let%bind f' = untype_expression expr1 in let%bind f' = untype_expression lamb in
let%bind arg' = untype_expression expr2 in let%bind arg' = untype_expression args in
return (e_application f' arg') return (e_application f' arg')
| E_lambda lambda -> | E_lambda lambda ->
let%bind lambda = untype_lambda e.type_expression lambda in let%bind lambda = untype_lambda e.type_expression lambda in
@ -1094,7 +1090,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind tv = untype_type_value rhs.type_expression in let%bind tv = untype_type_value rhs.type_expression in
let%bind rhs = untype_expression rhs in let%bind rhs = untype_expression rhs in
let%bind result = untype_expression let_result in let%bind result = untype_expression let_result in
return (e_let_in (let_binder , (Some tv)) false inline rhs result) return (e_let_in (let_binder , (Some tv)) inline rhs result)
| E_recursive {fun_name; fun_type; lambda} -> | E_recursive {fun_name; fun_type; lambda} ->
let%bind lambda = untype_lambda fun_type lambda in let%bind lambda = untype_lambda fun_type lambda in
let%bind fun_type = untype_type_expression fun_type in let%bind fun_type = untype_type_expression fun_type in
@ -1107,7 +1103,7 @@ and untype_lambda ty {binder; result} : I.lambda result =
ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda) ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda)
(* (*
Tranform a Ast_typed matching into an ast_simplified matching Tranform a Ast_typed matching into an ast_core matching
*) *)
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m -> and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
let open I in let open I in

4
src/passes/4-typer-new/typer.ml.old → src/passes/8-typer-new/typer.ml.old
View File

@ -1,6 +1,6 @@
open Trace open Trace
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
open O.Combinators open O.Combinators
@ -736,7 +736,7 @@ and type_constant (name:string) (lst:O.type_expression list) (tv_opt:O.type_expr
typer lst tv_opt typer lst tv_opt
let untype_type_expression (t:O.type_expression) : (I.type_expression) result = let untype_type_expression (t:O.type_expression) : (I.type_expression) result =
match t.simplified with match t.core with
| Some s -> ok s | Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type" | _ -> fail @@ internal_assertion_failure "trying to untype generated type"

2
src/passes/4-typer-new/typer.mli → src/passes/8-typer-new/typer.mli
View File

@ -1,6 +1,6 @@
open Trace open Trace
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
module Environment = O.Environment module Environment = O.Environment

0
src/passes/4-typer-new/typer_new.ml → src/passes/8-typer-new/typer_new.ml
View File

2
src/passes/4-typer-old/dune → src/passes/8-typer-old/dune
View File

@ -4,7 +4,7 @@
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
ast_simplified ast_core
ast_typed ast_typed
typer_new typer_new
operators operators

30
src/passes/4-typer-old/typer.ml → src/passes/8-typer-old/typer.ml
View File

@ -1,6 +1,6 @@
open Trace open Trace
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
open O.Combinators open O.Combinators
@ -423,7 +423,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (E_variable name) tv'.type_value return (E_variable name) tv'.type_value
| E_literal (Literal_bool b) -> | E_literal (Literal_bool b) ->
return (E_literal (Literal_bool b)) (t_bool ()) return (E_literal (Literal_bool b)) (t_bool ())
| E_literal Literal_unit | E_skip -> | E_literal Literal_unit ->
return (E_literal (Literal_unit)) (t_unit ()) return (E_literal (Literal_unit)) (t_unit ())
| E_literal Literal_void -> return (E_literal (Literal_void)) (t_unit ()) (* TODO : IS this really a t_unit ?*) | E_literal Literal_void -> return (E_literal (Literal_void)) (t_unit ()) (* TODO : IS this really a t_unit ?*)
| E_literal (Literal_string s) -> | E_literal (Literal_string s) ->
@ -688,21 +688,21 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind (name', tv) = let%bind (name', tv) =
type_constant cons_name tv_lst tv_opt in type_constant cons_name tv_lst tv_opt in
return (E_constant {cons_name=name';arguments=lst'}) tv return (E_constant {cons_name=name';arguments=lst'}) tv
| E_application {expr1;expr2} -> | E_application {lamb; args} ->
let%bind expr1' = type_expression' e expr1 in let%bind lamb' = type_expression' e lamb in
let%bind expr2 = type_expression' e expr2 in let%bind args' = type_expression' e args in
let%bind tv = match expr1'.type_expression.type_content with let%bind tv = match lamb'.type_expression.type_content with
| T_arrow {type1;type2} -> | T_arrow {type1;type2} ->
let%bind _ = O.assert_type_expression_eq (type1, expr2.type_expression) in let%bind _ = O.assert_type_expression_eq (type1, args'.type_expression) in
ok type2 ok type2
| _ -> | _ ->
fail @@ type_error_approximate fail @@ type_error_approximate
~expected:"should be a function type" ~expected:"should be a function type"
~expression:expr1 ~expression:lamb
~actual:expr1'.type_expression ~actual:lamb'.type_expression
expr1'.location lamb'.location
in in
return (E_application {expr1=expr1';expr2}) tv return (E_application {lamb=lamb'; args=args'}) tv
| E_look_up dsi -> | E_look_up dsi ->
let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in
@ -841,9 +841,9 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
return (e_constant cons_name lst') return (e_constant cons_name lst')
| E_variable n -> | E_variable n ->
return (e_variable (n)) return (e_variable (n))
| E_application {expr1;expr2} -> | E_application {lamb;args} ->
let%bind f' = untype_expression expr1 in let%bind f' = untype_expression lamb in
let%bind arg' = untype_expression expr2 in let%bind arg' = untype_expression args in
return (e_application f' arg') return (e_application f' arg')
| E_lambda {binder ; result} -> ( | E_lambda {binder ; result} -> (
let%bind io = get_t_function ty in let%bind io = get_t_function ty in
@ -893,7 +893,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind tv = untype_type_expression rhs.type_expression in let%bind tv = untype_type_expression rhs.type_expression in
let%bind rhs = untype_expression rhs in let%bind rhs = untype_expression rhs in
let%bind result = untype_expression let_result in let%bind result = untype_expression let_result in
return (e_let_in (let_binder , (Some tv)) false inline rhs result) return (e_let_in (let_binder , (Some tv)) inline rhs result)
| E_recursive {fun_name;fun_type; lambda} -> | E_recursive {fun_name;fun_type; lambda} ->
let%bind fun_type = untype_type_expression fun_type in let%bind fun_type = untype_type_expression fun_type in
let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in

2
src/passes/4-typer-old/typer.mli → src/passes/8-typer-old/typer.mli
View File

@ -1,6 +1,6 @@
open Trace open Trace
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
module Environment = O.Environment module Environment = O.Environment

0
src/passes/4-typer-old/typer_old.ml → src/passes/8-typer-old/typer_old.ml
View File

2
src/passes/4-typer/dune → src/passes/8-typer/dune
View File

@ -4,7 +4,7 @@
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
ast_simplified ast_core
ast_typed ast_typed
typer_old typer_old
typer_new typer_new

2
src/passes/4-typer/typer.ml → src/passes/8-typer/typer.ml
View File

@ -1,6 +1,6 @@
let use_new_typer = false let use_new_typer = false
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
module Environment = O.Environment module Environment = O.Environment

2
src/passes/4-typer/typer.mli → src/passes/8-typer/typer.mli
View File

@ -2,7 +2,7 @@ val use_new_typer : bool
open Trace open Trace
module I = Ast_simplified module I = Ast_core
module O = Ast_typed module O = Ast_typed
module Environment = O.Environment module Environment = O.Environment

0
src/passes/5-self_ast_typed/contract_passes.ml → src/passes/9-self_ast_typed/contract_passes.ml
View File

0
src/passes/5-self_ast_typed/dune → src/passes/9-self_ast_typed/dune
View File

16
src/passes/5-self_ast_typed/helpers.ml → src/passes/9-self_ast_typed/helpers.ml
View File

@ -19,8 +19,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
| E_look_up ab -> | E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
ok res ok res
| E_application {expr1;expr2} -> ( | E_application {lamb; args} -> (
let ab = (expr1,expr2) in let ab = (lamb, args) in
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
ok res ok res
) )
@ -135,10 +135,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind e' = self c.element in let%bind e' = self c.element in
return @@ E_constructor {c with element = e'} return @@ E_constructor {c with element = e'}
) )
| E_application {expr1;expr2} -> ( | E_application {lamb; args} -> (
let ab = (expr1,expr2) in let ab = (lamb, args) in
let%bind (a,b) = bind_map_pair self ab in let%bind (a,b) = bind_map_pair self ab in
return @@ E_application {expr1=a;expr2=b} return @@ E_application {lamb=a;args=b}
) )
| E_let_in { let_binder ; rhs ; let_result; inline } -> ( | E_let_in { let_binder ; rhs ; let_result; inline } -> (
let%bind rhs = self rhs in let%bind rhs = self rhs in
@ -251,10 +251,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,e') = self init' c.element in let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'}) ok (res, return @@ E_constructor {c with element = e'})
) )
| E_application {expr1;expr2} -> ( | E_application {lamb;args} -> (
let ab = (expr1,expr2) in let ab = (lamb, args) in
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
ok (res, return @@ E_application {expr1=a;expr2=b}) ok (res, return @@ E_application {lamb=a;args=b})
) )
| E_let_in { let_binder ; rhs ; let_result; inline } -> ( | E_let_in { let_binder ; rhs ; let_result; inline } -> (
let%bind (res,rhs) = self init' rhs in let%bind (res,rhs) = self init' rhs in

0
src/passes/5-self_ast_typed/self_ast_typed.ml → src/passes/9-self_ast_typed/self_ast_typed.ml
View File

6
src/passes/5-self_ast_typed/tail_recursion.ml → src/passes/9-self_ast_typed/tail_recursion.ml
View File

@ -24,9 +24,9 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit
Assert.assert_true (final_path || n <> v) in Assert.assert_true (final_path || n <> v) in
ok () ok ()
) )
| E_application {expr1;expr2} -> | E_application {lamb;args} ->
let%bind _ = check_recursive_call n final_path expr1 in let%bind _ = check_recursive_call n final_path lamb in
let%bind _ = check_recursive_call n false expr2 in let%bind _ = check_recursive_call n false args in
ok () ok ()
| E_lambda {result;_} -> | E_lambda {result;_} ->
let%bind _ = check_recursive_call n final_path result in let%bind _ = check_recursive_call n final_path result in

0
src/passes/9-self_michelson/main.ml
View File

3
src/passes/operators/dune
View File

@ -4,6 +4,9 @@
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
ast_imperative
ast_sugar
ast_core
ast_typed ast_typed
typesystem typesystem
mini_c mini_c

6
src/passes/operators/operators.ml
View File

@ -9,15 +9,15 @@ open Trace
a new constructor at all those places. a new constructor at all those places.
*) *)
module Simplify = struct module Concrete_to_imperative = struct
open Ast_simplified open Ast_imperative
(* (*
Each front-end has its owns constants. Each front-end has its owns constants.
Constants are special names that have their own case in the AST. E_constant Constants are special names that have their own case in the AST. E_constant
for regular constants, and T_constant for type constants. Both types are for regular constants, and T_constant for type constants. Both types are
defined in `Ast_simplified/types.ml`. defined in `Ast_core/types.ml`.
For instance, "2 + 2" in Pascaligo is translated to `E_constant ("ADD" , [ For instance, "2 + 2" in Pascaligo is translated to `E_constant ("ADD" , [
E_literal (Literal_int 2) ; E_literal (Literal_int 2) ;
E_literal (Literal_int 2) ; E_literal (Literal_int 2) ;

4
src/passes/operators/operators.mli
View File

@ -1,6 +1,6 @@
module Simplify : sig module Concrete_to_imperative : sig
open Ast_simplified open Ast_imperative
open Trace open Trace
module Pascaligo : sig module Pascaligo : sig

16
src/stages/ast_simplified/PP.ml → src/stages/1-ast_imperative/PP.ml
View File

@ -4,7 +4,7 @@ open Format
open PP_helpers open PP_helpers
include Stage_common.PP include Stage_common.PP
include Ast_PP_type(Ast_simplified_parameter) include Ast_PP_type(Ast_imperative_parameter)
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev
@ -18,8 +18,8 @@ and expression_content ppf (ec : expression_content) =
literal ppf l literal ppf l
| E_variable n -> | E_variable n ->
fprintf ppf "%a" expression_variable n fprintf ppf "%a" expression_variable n
| E_application app -> | E_application {lamb;args} ->
fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2 fprintf ppf "(%a)@(%a)" expression lamb expression args
| E_constructor c -> | E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element fprintf ppf "%a(%a)" constructor c.constructor expression c.element
| E_constant c -> | E_constant c ->
@ -52,18 +52,20 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "match %a with %a" fprintf ppf "match %a with %a"
expression matchee (matching expression) expression matchee (matching expression)
cases cases
| E_let_in { let_binder ; mut; rhs ; let_result; inline } ->
fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
| E_recursive { fun_name; fun_type; lambda} -> | E_recursive { fun_name; fun_type; lambda} ->
fprintf ppf "rec (%a:%a => %a )" fprintf ppf "rec (%a:%a => %a )"
expression_variable fun_name expression_variable fun_name
type_expression fun_type type_expression fun_type
expression_content (E_lambda lambda) expression_content (E_lambda lambda)
| E_skip -> | E_let_in { let_binder ; mut; rhs ; let_result; inline } ->
fprintf ppf "skip" fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
| E_ascription {anno_expr; type_annotation} -> | E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation type_annotation
| E_sequence {expr1;expr2} ->
fprintf ppf "%a;\n%a" expression expr1 expression expr2
| E_skip ->
fprintf ppf "skip"
and option_type_name ppf and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) = ((n, ty_opt) : expression_variable * type_expression option) =

0
src/stages/ast_simplified/ast_simplified.ml → src/stages/1-ast_imperative/ast_imperative.ml
View File

88
src/stages/ast_simplified/combinators.ml → src/stages/1-ast_imperative/combinators.ml
View File

@ -79,57 +79,57 @@ let t_operator op lst: type_expression result =
| TC_contract _ , [t] -> ok @@ t_contract t | TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op | _ , _ -> fail @@ bad_type_operator op
let location_wrap ?(loc = Location.generated) expression_content = let make_expr ?(loc = Location.generated) expression_content =
let location = loc in let location = loc in
{ expression_content; location } { expression_content; location }
let e_var ?loc (n: string) : expression = location_wrap ?loc @@ E_variable (Var.of_name n) let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = location_wrap ?loc @@ E_literal l let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l
let e_unit ?loc () : expression = location_wrap ?loc @@ E_literal (Literal_unit) let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_int n) let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_nat n) let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_timestamp n) let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = location_wrap ?loc @@ E_literal (Literal_bool b) let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_string s) let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_address s) let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_mutez s) let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_signature s) let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key s) let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key_hash s) let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_chain_id s) let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s)
let e'_bytes b : expression_content result = let e'_bytes b : expression_content result =
let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in
ok @@ E_literal (Literal_bytes bytes) ok @@ E_literal (Literal_bytes bytes)
let e_bytes_hex ?loc b : expression result = let e_bytes_hex ?loc b : expression result =
let%bind e' = e'_bytes b in let%bind e' = e'_bytes b in
ok @@ location_wrap ?loc e' ok @@ make_expr ?loc e'
let e_bytes_raw ?loc (b: bytes) : expression = let e_bytes_raw ?loc (b: bytes) : expression =
location_wrap ?loc @@ E_literal (Literal_bytes b) make_expr ?loc @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc (s: string) : expression = let e_bytes_string ?loc (s: string) : expression =
location_wrap ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_big_map ?loc lst : expression = location_wrap ?loc @@ E_big_map lst let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
let e_some ?loc s : expression = location_wrap ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant {cons_name = C_NONE; arguments = []} let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_map ?loc lst : expression = location_wrap ?loc @@ E_map lst let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
let e_set ?loc lst : expression = location_wrap ?loc @@ E_set lst let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
let e_list ?loc lst : expression = location_wrap ?loc @@ E_list lst let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; label= Label b} let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
let e_variable ?loc v = location_wrap ?loc @@ E_variable v let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_skip ?loc () = location_wrap ?loc @@ E_skip let e_skip ?loc () = make_expr ?loc @@ E_skip
let e_let_in ?loc (binder, ascr) mut inline rhs let_result = let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline } make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
let e_annotation ?loc anno_expr ty = location_wrap ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_application ?loc a b = location_wrap ?loc @@ E_application {expr1=a ; expr2=b} let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
let e_binop ?loc name a b = location_wrap ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = location_wrap ?loc @@ E_constant {cons_name=name ; arguments = lst} let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_look_up ?loc x y = location_wrap ?loc @@ E_look_up (x , y) let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
let e_sequence ?loc expr1 expr2 = e_let_in ?loc (Var.fresh (), Some t_unit) false false expr1 expr2 let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2}
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
(* (*
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*)
@ -141,14 +141,14 @@ let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
e_matching ?loc a (ez_match_variant lst) e_matching ?loc a (ez_match_variant lst)
let e_record_ez ?loc (lst : (string * expr) list) : expression = let e_record_ez ?loc (lst : (string * expr) list) : expression =
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
location_wrap ?loc @@ E_record map make_expr ?loc @@ E_record map
let e_record ?loc map = let e_record ?loc map =
let lst = Map.String.to_kv_list map in let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst e_record_ez ?loc lst
let e_update ?loc record path update = let e_update ?loc record path update =
let path = Label path in let path = Label path in
location_wrap ?loc @@ E_record_update {record; path; update} make_expr ?loc @@ E_record_update {record; path; update}
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
@ -177,13 +177,13 @@ let e_lambda ?loc (binder : expression_variable)
(output_type : type_expression option) (output_type : type_expression option)
(result : expression) (result : expression)
: expression = : expression =
location_wrap ?loc @@ E_lambda { make_expr ?loc @@ E_lambda {
binder = binder; binder = binder ;
input_type = input_type ; input_type = input_type ;
output_type = output_type ; output_type = output_type ;
result ; result ;
} }
let e_recursive ?loc fun_name fun_type lambda = location_wrap ?loc @@ E_recursive {fun_name; fun_type; lambda} let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_assign_with_let ?loc var access_path expr = let e_assign_with_let ?loc var access_path expr =
@ -237,7 +237,7 @@ let tuple_of_record (m: _ LMap.t) =
let get_e_tuple = fun t -> let get_e_tuple = fun t ->
match t with match t with
| E_record r -> ok @@ tuple_of_record r | E_record r -> ok @@ tuple_of_record r
| _ -> simple_fail "ast_simplified: get_e_tuple: not a tuple" | _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *) (* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e -> let extract_pair : expression -> (expression * expression) result = fun e ->

1
src/stages/ast_simplified/combinators.mli → src/stages/1-ast_imperative/combinators.mli
View File

@ -46,6 +46,7 @@ val t_map : type_expression -> type_expression -> type_expression
val t_operator : type_operator -> type_expression list -> type_expression result val t_operator : type_operator -> type_expression list -> type_expression result
val t_set : type_expression -> type_expression val t_set : type_expression -> type_expression
val make_expr : ?loc:Location.t -> expression_content -> expression
val e_var : ?loc:Location.t -> string -> expression val e_var : ?loc:Location.t -> string -> expression
val e_literal : ?loc:Location.t -> literal -> expression val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> expression val e_unit : ?loc:Location.t -> unit -> expression

13
src/stages/1-ast_imperative/dune Normal file
View File

@ -0,0 +1,13 @@
(library
(name ast_imperative)
(public_name ligo.ast_impretative)
(libraries
simple-utils
tezos-utils
stage_common
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -open Simple_utils ))
)

331
src/stages/1-ast_imperative/misc.ml Normal file
View File

@ -0,0 +1,331 @@
open Trace
open Types
open Stage_common.Helpers
module Errors = struct
let different_literals_because_different_types name a b () =
let title () = "literals have different types: " ^ name in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
("b" , fun () -> Format.asprintf "%a" PP.literal b )
] in
error ~data title message ()
let different_literals name a b () =
let title () = name ^ " are different" in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
("b" , fun () -> Format.asprintf "%a" PP.literal b )
] in
error ~data title message ()
let error_uncomparable_literals name a b () =
let title () = name ^ " are not comparable" in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
("b" , fun () -> Format.asprintf "%a" PP.literal b )
] in
error ~data title message ()
end
open Errors
let assert_literal_eq (a, b : literal * literal) : unit result =
match (a, b) with
| Literal_bool a, Literal_bool b when a = b -> ok ()
| Literal_bool _, Literal_bool _ -> fail @@ different_literals "different bools" a b
| Literal_bool _, _ -> fail @@ different_literals_because_different_types "bool vs non-bool" a b
| Literal_int a, Literal_int b when a = b -> ok ()
| Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b
| Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b
| Literal_nat a, Literal_nat b when a = b -> ok ()
| Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b
| Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b
| Literal_timestamp a, Literal_timestamp b when a = b -> ok ()
| Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b
| Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b
| Literal_mutez a, Literal_mutez b when a = b -> ok ()
| Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b
| Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b
| Literal_string a, Literal_string b when a = b -> ok ()
| Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b
| Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b
| Literal_bytes a, Literal_bytes b when a = b -> ok ()
| Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b
| Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
| Literal_void, Literal_void -> ok ()
| Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
| Literal_unit, Literal_unit -> ok ()
| Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
| Literal_address a, Literal_address b when a = b -> ok ()
| Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b
| Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b
| Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b
| Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
| Literal_signature a, Literal_signature b when a = b -> ok ()
| Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b
| Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b
| Literal_key a, Literal_key b when a = b -> ok ()
| Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b
| Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b
| Literal_key_hash a, Literal_key_hash b when a = b -> ok ()
| Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b
| Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b
| Literal_chain_id a, Literal_chain_id b when a = b -> ok ()
| Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b
| Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
let rec assert_value_eq (a, b: (expression * expression )) : unit result =
Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b;
let error_content () =
Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b
in
trace (fun () -> error (thunk "not equal") error_content ()) @@
match (a.expression_content , b.expression_content) with
| E_literal a , E_literal b ->
assert_literal_eq (a, b)
| E_literal _ , _ ->
simple_fail "comparing a literal with not a literal"
| E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (
let%bind lst =
generic_try (simple_error "constants with different number of elements")
(fun () -> List.combine ca.arguments cb.arguments) in
let%bind _all = bind_list @@ List.map assert_value_eq lst in
ok ()
)
| E_constant _ , E_constant _ ->
simple_fail "different constants"
| E_constant _ , _ ->
let error_content () =
Format.asprintf "%a vs %a"
PP.expression a
PP.expression b
in
fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ())
| E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> (
let%bind _eq = assert_value_eq (ca.element, cb.element) in
ok ()
)
| E_constructor _, E_constructor _ ->
simple_fail "different constructors"
| E_constructor _, _ ->
simple_fail "comparing constructor with other expression"
| E_record sma, E_record smb -> (
let aux _ a b =
match a, b with
| Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (simple_fail "different record keys")
in
let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
ok ()
)
| E_record _, _ ->
simple_fail "comparing record with other expression"
| E_record_update ura, E_record_update urb ->
let _ =
generic_try (simple_error "Updating different record") @@
fun () -> assert_value_eq (ura.record, urb.record) in
let aux (Label a,Label b) =
assert (String.equal a b)
in
let () = aux (ura.path, urb.path) in
let%bind () = assert_value_eq (ura.update,urb.update) in
ok ()
| E_record_update _, _ ->
simple_fail "comparing record update with other expression"
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
let%bind lst = generic_try (simple_error "maps of different lengths")
(fun () ->
let lsta' = List.sort compare lsta in
let lstb' = List.sort compare lstb in
List.combine lsta' lstb') in
let aux = fun ((ka, va), (kb, vb)) ->
let%bind _ = assert_value_eq (ka, kb) in
let%bind _ = assert_value_eq (va, vb) in
ok () in
let%bind _all = bind_map_list aux lst in
ok ()
)
| (E_map _ | E_big_map _), _ ->
simple_fail "comparing map with other expression"
| E_list lsta, E_list lstb -> (
let%bind lst =
generic_try (simple_error "list of different lengths")
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_list _, _ ->
simple_fail "comparing list with other expression"
| E_set lsta, E_set lstb -> (
let lsta' = List.sort (compare) lsta in
let lstb' = List.sort (compare) lstb in
let%bind lst =
generic_try (simple_error "set of different lengths")
(fun () -> List.combine lsta' lstb') in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_set _, _ ->
simple_fail "comparing set with other expression"
| (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_recursive _,_) | (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
| (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)
(* module Rename = struct
* open Trace
*
* module Type = struct
* (\* Type renaming, not needed. Yet. *\)
* end
*
* module Value = struct
* type renaming = string * (string * access_path) (\* src -> dst *\)
* type renamings = renaming list
* let filter (r:renamings) (s:string) : renamings =
* List.filter (fun (x, _) -> not (x = s)) r
* let filters (r:renamings) (ss:string list) : renamings =
* List.filter (fun (x, _) -> not (List.mem x ss)) r
*
* let rec rename_instruction (r:renamings) (i:instruction) : instruction result =
* match i with
* | I_assignment ({name;annotated_expression = e} as a) -> (
* match List.assoc_opt name r with
* | None ->
* let%bind annotated_expression = rename_annotated_expression (filter r name) e in
* ok (I_assignment {a with annotated_expression})
* | Some (name', lst) -> (
* let%bind annotated_expression = rename_annotated_expression r e in
* match lst with
* | [] -> ok (I_assignment {name = name' ; annotated_expression})
* | lst ->
* let (hds, tl) =
* let open List in
* let r = rev lst in
* rev @@ tl r, hd r
* in
* let%bind tl' = match tl with
* | Access_record n -> ok n
* | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in
* ok (I_record_patch (name', hds, [tl', annotated_expression]))
* )
* )
* | I_skip -> ok I_skip
* | I_fail e ->
* let%bind e' = rename_annotated_expression r e in
* ok (I_fail e')
* | I_loop (cond, body) ->
* let%bind cond' = rename_annotated_expression r cond in
* let%bind body' = rename_block r body in
* ok (I_loop (cond', body'))
* | I_matching (ae, m) ->
* let%bind ae' = rename_annotated_expression r ae in
* let%bind m' = rename_matching rename_block r m in
* ok (I_matching (ae', m'))
* | I_record_patch (v, path, lst) ->
* let aux (x, y) =
* let%bind y' = rename_annotated_expression (filter r v) y in
* ok (x, y') in
* let%bind lst' = bind_map_list aux lst in
* match List.assoc_opt v r with
* | None -> (
* ok (I_record_patch (v, path, lst'))
* )
* | Some (v', path') -> (
* ok (I_record_patch (v', path' @ path, lst'))
* )
* and rename_block (r:renamings) (bl:block) : block result =
* bind_map_list (rename_instruction r) bl
*
* and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result =
* fun f r m ->
* match m with
* | Match_bool { match_true = mt ; match_false = mf } ->
* let%bind match_true = f r mt in
* let%bind match_false = f r mf in
* ok (Match_bool {match_true ; match_false})
* | Match_option { match_none = mn ; match_some = (some, ms) } ->
* let%bind match_none = f r mn in
* let%bind ms' = f (filter r some) ms in
* ok (Match_option {match_none ; match_some = (some, ms')})
* | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } ->
* let%bind match_nil = f r mn in
* let%bind mc' = f (filters r [hd;tl]) mc in
* ok (Match_list {match_nil ; match_cons = (hd, tl, mc')})
* | Match_tuple (lst, body) ->
* let%bind body' = f (filters r lst) body in
* ok (Match_tuple (lst, body'))
*
* and rename_matching_instruction = fun x -> rename_matching rename_block x
*
* and rename_matching_expr = fun x -> rename_matching rename_expression x
*
* and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result =
* let%bind expression = rename_expression r ae.expression in
* ok {ae with expression}
*
* and rename_expression : renamings -> expression -> expression result = fun r e ->
* match e with
* | E_literal _ as l -> ok l
* | E_constant (name, lst) ->
* let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
* ok (E_constant (name, lst'))
* | E_constructor (name, ae) ->
* let%bind ae' = rename_annotated_expression r ae in
* ok (E_constructor (name, ae'))
* | E_variable v -> (
* match List.assoc_opt v r with
* | None -> ok (E_variable v)
* | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path))
* )
* | E_lambda ({binder;body;result} as l) ->
* let r' = filter r binder in
* let%bind body = rename_block r' body in
* let%bind result = rename_annotated_expression r' result in
* ok (E_lambda {l with body ; result})
* | E_application (f, arg) ->
* let%bind f' = rename_annotated_expression r f in
* let%bind arg' = rename_annotated_expression r arg in
* ok (E_application (f', arg'))
* | E_tuple lst ->
* let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
* ok (E_tuple lst')
* | E_accessor (ae, p) ->
* let%bind ae' = rename_annotated_expression r ae in
* ok (E_accessor (ae', p))
* | E_record sm ->
* let%bind sm' = bind_smap
* @@ SMap.map (rename_annotated_expression r) sm in
* ok (E_record sm')
* | E_map m ->
* let%bind m' = bind_map_list
* (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in
* ok (E_map m')
* | E_list lst ->
* let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
* ok (E_list lst')
* | E_look_up m ->
* let%bind m' = bind_map_pair (rename_annotated_expression r) m in
* ok (E_look_up m')
* | E_matching (ae, m) ->
* let%bind ae' = rename_annotated_expression r ae in
* let%bind m' = rename_matching rename_annotated_expression r m in
* ok (E_matching (ae', m'))
* end
* end *)

0
src/stages/ast_simplified/misc.mli → src/stages/1-ast_imperative/misc.mli
View File

126
src/stages/1-ast_imperative/types.ml Normal file
View File

@ -0,0 +1,126 @@
[@@@warning "-30"]
module Location = Simple_utils.Location
module Ast_imperative_parameter = struct
type type_meta = unit
end
include Stage_common.Types
(*include Ast_generic_type(Ast_core_parameter)
*)
include Ast_generic_type (Ast_imperative_parameter)
type inline = bool
type program = declaration Location.wrap list
and declaration =
| Declaration_type of (type_variable * type_expression)
(* A Declaration_constant is described by
* a name
* an optional type annotation
* a boolean indicating whether it should be inlined
* an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
(* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t}
and expression_content =
(* Base *)
| E_literal of literal
| E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of expression_variable
| E_application of application
| E_lambda of lambda
| E_recursive of recursive
| E_let_in of let_in
(* Variant *)
| E_constructor of constructor (* For user defined constructors *)
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record_accessor of accessor
| E_record_update of update
(* Advanced *)
| E_ascription of ascription
(* Sugar *)
| E_sequence of sequence
| E_skip
(* Data Structures *)
| E_map of (expression * expression) list
| E_big_map of (expression * expression) list
| E_list of expression list
| E_set of expression list
| E_look_up of (expression * expression)
and constant =
{ cons_name: constant' (* this is at the end because it is huge *)
; arguments: expression list }
and application = {
lamb: expression ;
args: expression ;
}
and lambda =
{ binder: expression_variable
; input_type: type_expression option
; output_type: type_expression option
; result: expression }
and recursive = {
fun_name : expression_variable;
fun_type : type_expression;
lambda : lambda;
}
and let_in =
{ let_binder: expression_variable * type_expression option
; mut: bool
; rhs: expression
; let_result: expression
; inline: bool }
and constructor = {constructor: constructor'; element: expression}
and accessor = {expr: expression; label: label}
and update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content
and matching =
{ matchee: expression
; cases: matching_expr
}
and ascription = {anno_expr: expression; type_annotation: type_expression}
and sequence = {
expr1: expression ;
expr2: expression ;
}
and environment_element_definition =
| ED_binder
| ED_declaration of (expression * free_variables)
and free_variables = expression_variable list
and environment_element =
{ type_value: type_expression
; source_environment: full_environment
; definition: environment_element_definition }
and environment = (expression_variable * environment_element) list
and type_environment = (type_variable * type_expression) list
(* SUBST ??? *)
and small_environment = environment * type_environment
and full_environment = small_environment List.Ne.t
and expr = expression
and texpr = type_expression

139
src/stages/2-ast_sugar/PP.ml Normal file
View File

@ -0,0 +1,139 @@
[@@@coverage exclude_file]
open Types
open Format
open PP_helpers
include Stage_common.PP
include Ast_PP_type(Ast_sugar_parameter)
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
and expression_content ppf (ec : expression_content) =
match ec with
| E_literal l ->
literal ppf l
| E_variable n ->
fprintf ppf "%a" expression_variable n
| E_application {lamb;args} ->
fprintf ppf "(%a)@(%a)" expression lamb expression args
| E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element
| E_constant c ->
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
c.arguments
| E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.expr label ra.label
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
| E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m ->
fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
| E_list lst ->
fprintf ppf "list[%a]" (list_sep_d expression) lst
| E_set lst ->
fprintf ppf "set[%a]" (list_sep_d expression) lst
| E_look_up (ds, ind) ->
fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a"
expression_variable binder
(PP_helpers.option type_expression)
input_type
(PP_helpers.option type_expression)
output_type expression result
| E_recursive { fun_name; fun_type; lambda} ->
fprintf ppf "rec (%a:%a => %a )"
expression_variable fun_name
type_expression fun_type
expression_content (E_lambda lambda)
| E_matching {matchee; cases; _} ->
fprintf ppf "match %a with %a" expression matchee (matching expression)
cases
| E_let_in { let_binder ; rhs ; let_result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result
| E_sequence {expr1;expr2} ->
fprintf ppf "%a;\n%a" expression expr1 expression expr2
| E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
| E_skip ->
fprintf ppf "skip"
and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) =
match ty_opt with
| None ->
fprintf ppf "%a" expression_variable n
| Some ty ->
fprintf ppf "%a : %a" expression_variable n type_expression ty
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
fun f ppf m -> match m with
| Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
(* Shows the type expected for the matched value *)
and matching_type ppf m = match m with
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_variant (lst, _) ->
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
| Match_bool _ ->
fprintf ppf "boolean"
| Match_list _ ->
fprintf ppf "list"
| Match_option _ ->
fprintf ppf "option"
and matching_variant_case_type ppf ((c,n),_a) =
fprintf ppf "| %a %a" constructor c expression_variable n
and option_mut ppf mut =
if mut then
fprintf ppf "[@mut]"
else
fprintf ppf ""
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
else
fprintf ppf ""
let declaration ppf (d : declaration) =
match d with
| Declaration_type (type_name, te) ->
fprintf ppf "type %a = %a" type_variable type_name type_expression te
| Declaration_constant (name, ty_opt, i, expr) ->
fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression
expr
option_inline i
let program ppf (p : program) =
fprintf ppf "@[<v>%a@]"
(list_sep declaration (tag "@;"))
(List.map Location.unwrap p)

8
src/stages/2-ast_sugar/ast_sugar.ml Normal file
View File

@ -0,0 +1,8 @@
include Types
(* include Misc *)
include Combinators
module Types = Types
module Misc = Misc
module PP=PP
module Combinators = Combinators

268
src/stages/2-ast_sugar/combinators.ml Normal file
View File

@ -0,0 +1,268 @@
open Types
open Simple_utils.Trace
module Option = Simple_utils.Option
module SMap = Map.String
module Errors = struct
let bad_kind expected location =
let title () = Format.asprintf "a %s was expected" expected in
let message () = "" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title message
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
let message () = "" in
error title message
end
open Errors
let make_t type_content = {type_content; type_meta = ()}
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 : type_expression = make_t @@ T_constant (TC_bool)
let t_string : type_expression = make_t @@ T_constant (TC_string)
let t_bytes : type_expression = make_t @@ T_constant (TC_bytes)
let t_int : type_expression = make_t @@ T_constant (TC_int)
let t_operation : type_expression = make_t @@ T_constant (TC_operation)
let t_nat : type_expression = make_t @@ T_constant (TC_nat)
let t_tez : type_expression = make_t @@ T_constant (TC_mutez)
let t_unit : type_expression = make_t @@ T_constant (TC_unit)
let t_address : type_expression = make_t @@ T_constant (TC_address)
let t_signature : type_expression = make_t @@ T_constant (TC_signature)
let t_key : type_expression = make_t @@ T_constant (TC_key)
let t_key_hash : type_expression = make_t @@ T_constant (TC_key_hash)
let t_timestamp : type_expression = make_t @@ T_constant (TC_timestamp)
let t_option o : type_expression = make_t @@ T_operator (TC_option o)
let t_list t : type_expression = make_t @@ T_operator (TC_list t)
let t_variable n : type_expression = make_t @@ T_variable (Var.of_name n)
let t_record_ez lst =
let lst = List.map (fun (k, v) -> (Label k, v)) lst in
let m = LMap.of_list lst in
make_t @@ T_record m
let t_record m : type_expression =
let lst = Map.String.to_kv_list m in
t_record_ez lst
let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)]
let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst)
let ez_t_sum (lst:(string * type_expression) 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 @@ T_sum map
let t_sum m : type_expression =
let lst = Map.String.to_kv_list m in
ez_t_sum lst
let t_function type1 type2 : type_expression = make_t @@ T_arrow {type1; type2}
let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value))
let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value))
let t_set key : type_expression = make_t @@ T_operator (TC_set key)
let t_contract contract : type_expression = make_t @@ T_operator (TC_contract contract)
(* TODO find a better way than using list*)
let t_operator op lst: type_expression result =
match op,lst with
| TC_set _ , [t] -> ok @@ t_set t
| TC_list _ , [t] -> ok @@ t_list t
| TC_option _ , [t] -> ok @@ t_option t
| TC_map (_,_) , [kt;vt] -> ok @@ t_map kt vt
| TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map kt vt
| TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op
let make_expr ?(loc = Location.generated) expression_content =
let location = loc in
{ expression_content; location }
let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l
let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s)
let e'_bytes b : expression_content result =
let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in
ok @@ E_literal (Literal_bytes bytes)
let e_bytes_hex ?loc b : expression result =
let%bind e' = e'_bytes b in
ok @@ make_expr ?loc e'
let e_bytes_raw ?loc (b: bytes) : expression =
make_expr ?loc @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc (s: string) : expression =
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_skip ?loc () = make_expr ?loc @@ E_skip
let e_let_in ?loc (binder, ascr) inline rhs let_result =
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline }
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2}
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
(*
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*)
*)
let ez_match_variant (lst : ((string * string) * 'a) list) =
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
Match_variant (lst,())
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
e_matching ?loc a (ez_match_variant lst)
let e_record_ez ?loc (lst : (string * expr) list) : expression =
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
make_expr ?loc @@ E_record map
let e_record ?loc map =
let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst
let e_update ?loc record path update =
let path = Label path in
make_expr ?loc @@ E_record_update {record; path; update}
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let make_option_typed ?loc e t_opt =
match t_opt with
| None -> e
| Some t -> e_annotation ?loc e t
let e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in
e_annotation ?loc (e_none ?loc ()) type_annotation
let e_typed_list ?loc lst t =
e_annotation ?loc (e_list lst) (t_list t)
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v)
let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_lambda ?loc (binder : expression_variable)
(input_type : type_expression option)
(output_type : type_expression option)
(result : expression)
: expression =
make_expr ?loc @@ E_lambda {
binder = binder ;
input_type = input_type ;
output_type = output_type ;
result ;
}
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_assign_with_let ?loc var access_path expr =
let var = Var.of_name (var) in
match access_path with
| [] -> (var, None), true, expr, false
| lst ->
let rec aux path record= match path with
| [] -> failwith "acces_path cannot be empty"
| [e] -> e_update ?loc record e expr
| elem::tail ->
let next_record = e_accessor record elem in
e_update ?loc record elem (aux tail next_record )
in
(var, None), true, (aux lst (e_variable var)), false
let get_e_accessor = fun t ->
match t with
| E_record_accessor {expr; label} -> ok (expr , label)
| _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t ->
let%bind _ = get_e_accessor t in
ok ()
let get_e_pair = fun t ->
match t with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> simple_fail "not a pair"
)
| _ -> simple_fail "not a pair"
let get_e_list = fun t ->
match t with
| E_list lst -> ok lst
| _ -> simple_fail "not a list"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let opt = LMap.find_opt (Label (string_of_int i)) m in
Option.bind (fun opt -> Some (opt,i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let get_e_tuple = fun t ->
match t with
| E_record r -> ok @@ tuple_of_record r
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression_content with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> fail @@ bad_kind "pair" e.location
)
| _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e ->
match e.expression_content with
| E_list lst -> ok lst
| _ -> fail @@ bad_kind "list" e.location
let extract_record : expression -> (label * expression) list result = fun e ->
match e.expression_content with
| E_record lst -> ok @@ LMap.to_kv_list lst
| _ -> fail @@ bad_kind "record" e.location
let extract_map : expression -> (expression * expression) list result = fun e ->
match e.expression_content with
| E_map lst -> ok lst
| _ -> fail @@ bad_kind "map" e.location

135
src/stages/2-ast_sugar/combinators.mli Normal file
View File

@ -0,0 +1,135 @@
open Types
open Simple_utils.Trace
(*
module Option = Simple_utils.Option
module SMap = Map.String
module Errors : sig
val bad_kind : name -> Location.t -> unit -> error
end
*)
val make_t : type_content -> type_expression
val t_bool : type_expression
val t_string : type_expression
val t_bytes : type_expression
val t_int : type_expression
val t_operation : type_expression
val t_nat : type_expression
val t_tez : type_expression
val t_unit : type_expression
val t_address : type_expression
val t_key : type_expression
val t_key_hash : type_expression
val t_timestamp : type_expression
val t_signature : type_expression
(*
val t_option : type_expression -> type_expression
*)
val t_list : type_expression -> type_expression
val t_variable : string -> type_expression
(*
val t_record : te_map -> type_expression
*)
val t_pair : ( type_expression * type_expression ) -> type_expression
val t_tuple : type_expression list -> type_expression
val t_record : type_expression Map.String.t -> type_expression
val t_record_ez : (string * type_expression) list -> type_expression
val t_sum : type_expression Map.String.t -> type_expression
val ez_t_sum : ( string * type_expression ) list -> type_expression
val t_function : type_expression -> type_expression -> type_expression
val t_map : type_expression -> type_expression -> type_expression
val t_operator : type_operator -> type_expression list -> type_expression result
val t_set : type_expression -> type_expression
val make_expr : ?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 -> int -> expression
val e_nat : ?loc:Location.t -> int -> expression
val e_timestamp : ?loc:Location.t -> int -> expression
val e_bool : ?loc:Location.t -> bool -> expression
val e_string : ?loc:Location.t -> 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 -> int -> expression
val e'_bytes : string -> expression_content result
val e_bytes_hex : ?loc:Location.t -> string -> expression result
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
val e_bytes_string : ?loc:Location.t -> string -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
val e_tuple : ?loc:Location.t -> expression list -> 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_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_list : ?loc:Location.t -> expression list -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_accessor : ?loc:Location.t -> expression -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val e_typed_none : ?loc:Location.t -> type_expression -> expression
val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_set : ?loc:Location.t -> expression list -> 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 Map.String.t -> expression
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
(*
val get_e_accessor : expression' -> ( expression * access_path ) result
*)
val assert_e_accessor : expression_content -> unit result
val get_e_pair : expression_content -> ( expression * expression ) result
val get_e_list : expression_content -> ( expression list ) result
val get_e_tuple : expression_content -> ( expression list ) result
(*
val get_e_failwith : expression -> expression result
val is_e_failwith : expression -> bool
*)
val extract_pair : expression -> ( expression * expression ) result
val extract_list : expression -> (expression list) result
val extract_record : expression -> (label * expression) list result
val extract_map : expression -> (expression * expression) list result

4
src/stages/ast_simplified/dune → src/stages/2-ast_sugar/dune
View File

@ -1,6 +1,6 @@
(library (library
(name ast_simplified) (name ast_sugar)
(public_name ligo.ast_simplified) (public_name ligo.ast_sugar)
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils

Some files were not shown because too many files have changed in this diff Show More