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

result monad refactoring:

Browse Source 
- do not use plain JSON rep for errors and use polymorphic variants instead
- split formatting for human readable and JSON output
- no more simple_errors simple_fails
- much less result bindings used in stages
This commit is contained in:
Lesenechal Remi 2020-06-12 13:33:14 +02:00
parent d53be83490
commit c6b95bf07a
177 changed files with 6946 additions and 6458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

458
src/bin/cli.ml
View File

@ -106,14 +106,15 @@ let predecessor_timestamp =
let display_format =
let open Arg in
let open Display in
let info =
let docv = "DISPLAY_FORMAT" in
let doc = "$(docv) is the format that will be used by the CLI. Available formats are 'dev', 'json', and 'human-readable' (default). When human-readable lacks details (we are still tweaking it), please contact us and use another format in the meanwhile." in
info ~docv ~doc ["format" ; "display-format"] in
value @@
opt
(enum [("human-readable", `Human_readable); ("dev", `Dev); ("json", `Json)])
`Human_readable
(enum [("human-readable", human_readable); ("dev", dev); ("json", json)])
human_readable
info
let michelson_code_format =
@ -127,110 +128,6 @@ let michelson_code_format =
(enum [("text", `Text); ("json", `Json); ("hex", `Hex)])
`Text info
module Helpers = Ligo.Compile.Helpers
module Compile = Ligo.Compile
module Uncompile = Ligo.Uncompile
module Run = Ligo.Run.Of_michelson
let compile_file =
let f source_file entry_point syntax display_format disable_typecheck michelson_format =
toplevel ~display_format @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax (Contract entry_point) 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 ~disable_typecheck michelson in
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ disable_michelson_typechecking $ michelson_code_format) in
let cmdname = "compile-contract" in
let doc = "Subcommand: Compile a contract." in
(Term.ret term , Term.info ~doc cmdname)
let preprocess =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind pp =
Compile.Of_source.preprocess source_file (Syntax_name syntax) in
ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
) in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "preprocess" in
let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let pretty_print =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind pp =
Compile.Of_source.pretty_print source_file (Syntax_name syntax) in
ok @@ Buffer.contents pp
) in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "pretty-print" in
let doc = "Subcommand: Pretty-print the source file."
in (Term.ret term, Term.info ~doc cmdname)
let print_cst =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind pp = Compile.Of_source.pretty_print_cst source_file (Syntax_name syntax) in
ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-cst" in
let doc = "Subcommand: Print the CST.\nWarning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind imperative = Compile.Utils.to_imperatve source_file syntax in
ok @@ Format.asprintf "%a\n" Compile.Of_imperative.pretty_print imperative
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast" in
let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast_sugar =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind sugar = Compile.Utils.to_sugar source_file syntax in
ok @@ Format.asprintf "%a\n" Compile.Of_sugar.pretty_print sugar
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast-sugar" in
let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast_core =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind core = Compile.Utils.to_core source_file syntax in
ok @@ Format.asprintf "%a\n" Compile.Of_core.pretty_print core
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast-core" in
let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast_typed =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast-typed" in
let doc = "Subcommand: Print the typed AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let optimize =
let open Arg in
let docv = "ENTRY_POINT" in
@ -239,17 +136,108 @@ let optimize =
info ~docv ~doc ["optimize"] in
value @@ opt (some string) None info
module Helpers = Ligo.Compile.Helpers
module Compile = Ligo.Compile
module Uncompile = Ligo.Uncompile
module Run = Ligo.Run.Of_michelson
let compile_file =
let f source_file entry_point syntax display_format disable_typecheck michelson_format =
return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax (Contract entry_point) 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
Compile.Of_michelson.build_contract ~disable_typecheck michelson
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ disable_michelson_typechecking $ michelson_code_format) in
let cmdname = "compile-contract" in
let doc = "Subcommand: Compile a contract." in
(Term.ret term , Term.info ~doc cmdname)
let preprocess =
let f source_file syntax display_format =
return_result ~display_format (Parser.Formatter.ppx_format) @@
Compile.Of_source.preprocess source_file (Syntax_name syntax)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "preprocess" in
let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let pretty_print =
let f source_file syntax display_format =
return_result ~display_format (Parser.Formatter.ppx_format) @@
Compile.Of_source.pretty_print source_file (Syntax_name syntax)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "pretty-print" in
let doc = "Subcommand: Pretty-print the source file."
in (Term.ret term, Term.info ~doc cmdname)
let print_cst =
let f source_file syntax display_format =
return_result ~display_format (Parser.Formatter.ppx_format) @@
Compile.Of_source.pretty_print_cst source_file (Syntax_name syntax)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-cst" in
let doc = "Subcommand: Print the CST.\nWarning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast =
let f source_file syntax display_format =
return_result ~display_format (Ast_imperative.Formatter.program_format) @@
Compile.Utils.to_imperatve source_file syntax
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast" in
let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast_sugar =
let f source_file syntax display_format =
return_result ~display_format (Ast_sugar.Formatter.program_format) @@
Compile.Utils.to_sugar source_file syntax
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast-sugar" in
let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast_core =
let f source_file syntax display_format =
return_result ~display_format (Ast_core.Formatter.program_format) @@
Compile.Utils.to_core source_file syntax
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast-core" in
let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast_typed =
let f source_file syntax display_format =
return_result ~display_format (Ast_typed.Formatter.program_format) @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
ok typed
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast-typed" in
let doc = "Subcommand: Print the typed AST.\n Warning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_mini_c =
let f source_file syntax display_format optimize = (
toplevel ~display_format @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind mini_c = Compile.Of_typed.compile typed in
match optimize with
| None -> ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c
| Some entry_point ->
let%bind mini_c = Compile.Of_mini_c.aggregate_contract mini_c entry_point in
ok @@ Format.asprintf "%a\n" Mini_c.PP.expression mini_c
)
let f source_file syntax display_format optimize =
return_result ~display_format (Mini_c.Formatter.program_format) @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind mini_c = Compile.Of_typed.compile typed in
match optimize with
| None -> ok @@ Mini_c.Formatter.Raw mini_c
| Some entry_point ->
let%bind o = Compile.Of_mini_c.aggregate_contract mini_c entry_point in
ok @@ Mini_c.Formatter.Optimized o
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format $ optimize) in
let cmdname = "print-mini-c" in
@ -257,11 +245,12 @@ let print_mini_c =
(Term.ret term, Term.info ~doc cmdname)
let measure_contract =
let f source_file entry_point syntax display_format =
toplevel ~display_format @@
let%bind contract = Compile.Utils.compile_file source_file syntax entry_point in
let open Tezos_utils in
ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract)
let f source_file entry_point syntax display_format =
let value =
let%bind contract = Compile.Utils.compile_file source_file syntax entry_point in
ok @@ Tezos_utils.Michelson.measure contract in
let format = Display.bind_format Formatter.contract_size_format Main.Formatter.error_format in
toplevel ~display_format (Display.Displayable { value ; format }) (returned_value value)
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format) in
@ -271,24 +260,23 @@ let measure_contract =
let compile_parameter =
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) 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 env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) 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 env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state 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 () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_parameter michelson_prg compiled_param in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind value = Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
in
let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state 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 () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_parameter michelson_prg compiled_param in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
let cmdname = "compile-parameter" in
@ -297,27 +285,21 @@ let compile_parameter =
let interpret =
let f expression init_file syntax amount balance sender source predecessor_timestamp display_format =
toplevel ~display_format @@
let%bind (decl_list,state,env) = match init_file with
| Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let env = Ast_typed.program_environment Environment.default typed_prg in
ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Environment.default) in
return_result ~display_format (Uncompile.Formatter.expression_format) @@
let%bind (decl_list,state,env) = match init_file with
| Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let env = Ast_typed.program_environment Environment.default typed_prg in
ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Environment.default) in
let%bind (typed_exp,_) = Compile.Utils.type_expression init_file syntax expression env state 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 options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
match runres with
| Fail fail_res ->
let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring
| Success value' ->
let%bind core_output = Uncompile.uncompile_expression typed_exp.type_expression value' in
ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
let%bind (typed_exp,_) = Compile.Utils.type_expression init_file syntax expression env state 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 options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
Uncompile.uncompile_expression typed_exp.type_expression runres
in
let term =
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
@ -327,10 +309,9 @@ let interpret =
let temp_ligo_interpreter =
let f source_file syntax display_format =
toplevel ~display_format @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind res = Compile.Of_typed.some_interpret typed in
ok @@ Format.asprintf "%s\n" res
return_result ~display_format (Ligo_interpreter.Formatter.program_format) @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
Compile.Of_typed.some_interpret typed
in
let term =
Term.(const f $ source_file 0 $ syntax $ display_format ) in
@ -340,24 +321,22 @@ let temp_ligo_interpreter =
let compile_storage =
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) 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 env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) 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 env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state 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 () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_storage michelson_prg compiled_param in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind value = Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
in
let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state 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 () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_storage michelson_prg compiled_param in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
let cmdname = "compile-storage" in
@ -366,28 +345,22 @@ let compile_storage =
let dry_run =
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
return_result ~display_format (Uncompile.Formatter.expression_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
let%bind compiled_params = Compile.Utils.compile_storage storage input source_file syntax env state mini_c_prg in
let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in
let%bind compiled_params = Compile.Utils.compile_storage storage input source_file syntax env state mini_c_prg 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 runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
match runres with
| Fail fail_res ->
let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring
| Success michelson_output ->
let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "dry-run" in
@ -396,31 +369,25 @@ let dry_run =
let run_function =
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
return_result ~display_format (Uncompile.Formatter.expression_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
let%bind imperative_param = Compile.Of_source.compile_expression v_syntax parameter 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 v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
let%bind imperative_param = Compile.Of_source.compile_expression v_syntax parameter 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 michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in
match runres with
| Fail fail_res ->
let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring
| Success michelson_output ->
let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in
Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "run-function" in
@ -429,16 +396,15 @@ let run_function =
let evaluate_value =
let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@
let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
let%bind mini_c = Compile.Of_typed.compile typed_prg in
let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in
let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty 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_core.PP.expression core_output
in
return_result ~display_format Uncompile.Formatter.expression_format @@
let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
let%bind mini_c = Compile.Of_typed.compile typed_prg in
let%bind (exp,_) = trace_option Main_errors.entrypoint_not_found @@ Mini_c.get_entry mini_c entry_point in
let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options compiled.expr compiled.expr_ty in
Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point runres
in
let term =
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "evaluate-value" in
@ -447,13 +413,12 @@ let evaluate_value =
let compile_expression =
let f expression syntax display_format michelson_format =
toplevel ~display_format @@
let env = Environment.default in
let state = Typer.Solver.initial_state in
let%bind compiled_exp = Compile.Utils.compile_expression None syntax expression env state 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
in
return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
let env = Environment.default in
let state = Typer.Solver.initial_state in
let%bind compiled_exp = Compile.Utils.compile_expression None syntax expression env state in
Run.evaluate_expression compiled_exp.expr compiled_exp.expr_ty
in
let term =
Term.(const f $ expression "" 1 $ req_syntax 0 $ display_format $ michelson_code_format) in
let cmdname = "compile-expression" in
@ -461,7 +426,10 @@ let compile_expression =
(Term.ret term , Term.info ~doc cmdname)
let dump_changelog =
let f display_format = toplevel ~display_format @@ (ok @@ [%blob "../../CHANGELOG.md"]) in
let f display_format =
let value = [%blob "../../CHANGELOG.md"] in
let format = Formatter.changelog_format in
toplevel ~display_format (Display.Displayable {value ; format}) (returned_value (ok ())) in
let term =
Term.(const f $ display_format) in
let cmdname = "changelog" in
@ -469,14 +437,14 @@ let dump_changelog =
(Term.ret term , Term.info ~doc cmdname)
let list_declarations =
let f source_file syntax =
toplevel ~display_format:(`Human_readable) @@
let%bind core_prg = Compile.Utils.to_core source_file syntax 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) ]
let f source_file syntax display_format =
return_result ~display_format Formatter.declarations_format @@
let%bind core_prg = Compile.Utils.to_core source_file syntax in
let declarations = Compile.Of_core.list_declarations core_prg in
ok (source_file, declarations)
in
let term =
Term.(const f $ source_file 0 $ syntax ) in
Term.(const f $ source_file 0 $ syntax $ display_format ) in
let cmdname = "list-declarations" in
let doc = "Subcommand: List all the top-level declarations." in
(Term.ret term , Term.info ~doc cmdname)

36
src/bin/cli_helpers.ml
View File

@ -1,23 +1,23 @@
open Cmdliner
open Trace
open Main.Display
let error_suggest: string = "\n If you're not sure how to fix this error, you can
do one of the following:
let returned_value : (_,_) result -> unit -> unit Term.ret =
fun v () -> match v with
| Ok _ -> `Ok ()
| Error _ -> `Error (false, "error")
* Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog'\n"
let toplevel : display_format:ex_display_format -> displayable -> (unit -> unit Term.ret) -> unit Term.ret =
fun ~display_format disp return ->
let (Ex_display_format t) = display_format in
let as_str : string =
match t with
| Human_readable -> convert ~display_format:t disp ;
| Dev -> convert ~display_format:t disp ;
| Json -> Yojson.Basic.to_string @@ convert ~display_format:t disp in
Format.printf "%s\n" as_str ;
return ()
let toplevel ~(display_format : display_format) (x : string result) : unit Term.ret =
match x with
| Ok _ -> Format.printf "%a%!" (formatted_string_result_pp display_format) x;
`Ok ()
| Error _ ->
begin
match display_format with
| `Human_readable -> print_string error_suggest ;
| _ -> ()
end ;
`Error (false, Format.asprintf "%a%!" (formatted_string_result_pp display_format) x)
let return_result : display_format:ex_display_format -> 'value format -> ('value, Main_errors.Types.all) result -> unit Term.ret =
fun ~display_format value_format value ->
let format = Display.bind_format value_format Main.Formatter.error_format in
toplevel ~display_format (Display.Displayable {value ; format}) (returned_value value)

6
src/bin/cli_helpers.mli
View File

@ -1,4 +1,6 @@
open Cmdliner
open Trace
open Display
val toplevel : display_format : Main.Display.display_format -> string result -> unit Term.ret
val toplevel : display_format:ex_display_format -> displayable -> (unit -> unit Term.ret) -> unit Term.ret
val returned_value : (_,_) Trace.result -> unit -> unit Term.ret
val return_result : display_format:ex_display_format -> 'value format -> ('value, Main_errors.Types.all) result -> unit Term.ret

2
src/bin/dune
View File

@ -5,7 +5,7 @@
cmdliner
ligo
)
(modules cli cli_helpers version)
(modules cli cli_helpers formatter version)
(preprocess
(pps ppx_let ppx_blob bisect_ppx --conditional)
)

42
src/bin/formatter.ml Normal file
View File

@ -0,0 +1,42 @@
open Display
let declarations_ppformat ~display_format f ((source_file,decls),_) =
match display_format with
| Human_readable | Dev ->
Format.fprintf f "%s declarations:\n" source_file ;
List.iter (fun decl -> Format.fprintf f "%s\n" decl) decls
let declarations_jsonformat ((source_file,decls),_) : json =
let json_decl = List.map (fun decl -> `String decl) decls in
`Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ]
let declarations_format : 'a format = {
pp = declarations_ppformat;
to_json = declarations_jsonformat;
}
let changelog_ppformat ~display_format f changelog =
match display_format with
| Human_readable | Dev ->
Format.fprintf f "%s" changelog
let changelog_jsonformat changelog : json =
`String changelog
let changelog_format : 'a format = {
pp = changelog_ppformat;
to_json = changelog_jsonformat;
}
let contract_size_ppformat ~display_format f (contract_size,_) =
match display_format with
| Human_readable | Dev ->
Format.fprintf f "%d bytes" contract_size
let contract_size_jsonformat (contract_size,_) : json =
`Int contract_size
let contract_size_format : 'a format = {
pp = contract_size_ppformat;
to_json = contract_size_jsonformat;
}

1
src/main/compile/dune
View File

@ -2,6 +2,7 @@
(name compile)
(public_name ligo.compile)
(libraries
main_errors
simple-utils
tezos-utils
parser

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

@ -1,4 +1,5 @@
open Trace
open Main_errors
type s_syntax = Syntax_name of string
type v_syntax = PascaLIGO | CameLIGO | ReasonLIGO
@ -10,78 +11,65 @@ let syntax_to_variant (Syntax_name syntax) source =
".ligo" | ".pligo" -> ok PascaLIGO
| ".mligo" -> ok CameLIGO
| ".religo" -> ok ReasonLIGO
| _ -> simple_fail "Cannot auto-detect the syntax.\n\
Hint: Use -s <name of syntax>\n")
| ext -> fail (syntax_auto_detection ext))
| ("pascaligo" | "PascaLIGO"), _ -> ok PascaLIGO
| ("cameligo" | "CameLIGO"), _ -> ok CameLIGO
| ("reasonligo" | "ReasonLIGO"), _ -> ok ReasonLIGO
| _ -> simple_fail "Invalid syntax name.\n\
Hint: Use \"pascaligo\", \"cameligo\" \
or \"reasonligo\".\n"
| _ -> fail (invalid_syntax syntax)
let parsify_pascaligo source =
let%bind raw =
trace (simple_error "parsing") @@
let%bind raw = trace parser_tracer @@
Parser.Pascaligo.parse_file source in
let%bind imperative =
trace (simple_error "abstracting") @@
Concrete_to_imperative.Pascaligo.compile_program raw
let%bind imperative = trace cit_pascaligo_tracer @@
Concrete_to_imperative.Pascaligo.compile_program raw
in ok imperative
let parsify_expression_pascaligo source =
let%bind raw =
trace (simple_error "parsing expression") @@
let%bind raw = trace parser_tracer @@
Parser.Pascaligo.parse_expression source in
let%bind imperative =
trace (simple_error "abstracting expression") @@
let%bind imperative = trace cit_pascaligo_tracer @@
Concrete_to_imperative.Pascaligo.compile_expression raw
in ok imperative
let parsify_cameligo source =
let%bind raw =
trace (simple_error "parsing") @@
let%bind raw = trace parser_tracer @@
Parser.Cameligo.parse_file source in
let%bind imperative =
trace (simple_error "abstracting") @@
let%bind imperative = trace cit_cameligo_tracer @@
Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative
let parsify_expression_cameligo source =
let%bind raw =
trace (simple_error "parsing expression") @@
let%bind raw = trace parser_tracer @@
Parser.Cameligo.parse_expression source in
let%bind imperative =
trace (simple_error "abstracting expression") @@
let%bind imperative = trace cit_cameligo_tracer @@
Concrete_to_imperative.Cameligo.compile_expression raw
in ok imperative
let parsify_reasonligo source =
let%bind raw =
trace (simple_error "parsing") @@
let%bind raw = trace parser_tracer @@
Parser.Reasonligo.parse_file source in
let%bind imperative =
trace (simple_error "abstracting") @@
let%bind imperative = trace cit_cameligo_tracer @@
Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative
let parsify_expression_reasonligo source =
let%bind raw =
trace (simple_error "parsing expression") @@
let%bind raw = trace parser_tracer @@
Parser.Reasonligo.parse_expression source in
let%bind imperative =
trace (simple_error "abstracting expression") @@
let%bind imperative = trace cit_cameligo_tracer @@
Concrete_to_imperative.Cameligo.compile_expression raw
in ok imperative
let parsify syntax source =
let parsify syntax source : (Ast_imperative.program, _) Trace.result =
let%bind parsify =
match syntax with
PascaLIGO -> ok parsify_pascaligo
| CameLIGO -> ok parsify_cameligo
| ReasonLIGO -> ok parsify_reasonligo in
let%bind parsified = parsify source in
let%bind applied = Self_ast_imperative.all_program parsified
in ok applied
let%bind applied = trace self_ast_imperative_tracer @@
Self_ast_imperative.all_program parsified in
ok applied
let parsify_expression syntax source =
let%bind parsify = match syntax with
@ -89,33 +77,28 @@ let parsify_expression syntax source =
| CameLIGO -> ok parsify_expression_cameligo
| ReasonLIGO -> ok parsify_expression_reasonligo in
let%bind parsified = parsify source in
let%bind applied = Self_ast_imperative.all_expression parsified
let%bind applied = trace self_ast_imperative_tracer @@
Self_ast_imperative.all_expression parsified
in ok applied
let parsify_string_reasonligo source =
let%bind raw =
trace (simple_error "parsing") @@
let%bind raw = trace parser_tracer @@
Parser.Reasonligo.parse_string source in
let%bind imperative =
trace (simple_error "abstracting") @@
let%bind imperative = trace cit_cameligo_tracer @@
Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative
let parsify_string_pascaligo source =
let%bind raw =
trace (simple_error "parsing") @@
let%bind raw = trace parser_tracer @@
Parser.Pascaligo.parse_string source in
let%bind imperative =
trace (simple_error "abstracting") @@
let%bind imperative = trace cit_pascaligo_tracer @@
Concrete_to_imperative.Pascaligo.compile_program raw
in ok imperative
let parsify_string_cameligo source =
let%bind raw =
trace (simple_error "parsing") @@
let%bind raw = trace parser_tracer @@
Parser.Cameligo.parse_string source in
let%bind imperative =
trace (simple_error "abstracting") @@
let%bind imperative = trace cit_cameligo_tracer @@
Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative
@ -126,11 +109,12 @@ let parsify_string syntax source =
| CameLIGO -> ok parsify_string_cameligo
| ReasonLIGO -> ok parsify_string_reasonligo in
let%bind parsified = parsify source in
let%bind applied = Self_ast_imperative.all_program parsified
let%bind applied = trace self_ast_imperative_tracer @@
Self_ast_imperative.all_program parsified
in ok applied
let pretty_print_pascaligo_cst source =
let%bind ast = Parser.Pascaligo.parse_file source in
let%bind ast = trace parser_tracer @@ Parser.Pascaligo.parse_file source in
let buffer = Buffer.create 59 in
let state =
Parser_pascaligo.ParserLog.mk_state
@ -141,7 +125,7 @@ let pretty_print_pascaligo_cst source =
ok buffer
let pretty_print_cameligo_cst source =
let%bind ast = Parser.Cameligo.parse_file source in
let%bind ast = trace parser_tracer @@ Parser.Cameligo.parse_file source in
let buffer = Buffer.create 59 in
let state = (* TODO: Should flow from the CLI *)
Parser_cameligo.ParserLog.mk_state
@ -152,7 +136,7 @@ let pretty_print_cameligo_cst source =
ok buffer
let pretty_print_reasonligo_cst source =
let%bind ast = Parser.Reasonligo.parse_file source in
let%bind ast = trace parser_tracer @@ Parser.Reasonligo.parse_file source in
let buffer = Buffer.create 59 in
let state = (* TODO: Should flow from the CLI *)
Parser_cameligo.ParserLog.mk_state
@ -179,6 +163,7 @@ let preprocess_reasonligo = Parser.Reasonligo.preprocess
let preprocess syntax source =
let%bind v_syntax =
syntax_to_variant syntax (Some source) in
trace parser_tracer @@
match v_syntax with
PascaLIGO -> preprocess_pascaligo source
| CameLIGO -> preprocess_cameligo source
@ -221,6 +206,6 @@ let pretty_print syntax source =
let%bind v_syntax =
syntax_to_variant syntax (Some source) in
match v_syntax with
PascaLIGO -> pretty_print_pascaligo source
| CameLIGO -> pretty_print_cameligo source
| ReasonLIGO -> pretty_print_reasonligo source
PascaLIGO -> trace parser_tracer @@ pretty_print_pascaligo source
| CameLIGO -> trace parser_tracer @@ pretty_print_cameligo source
| ReasonLIGO -> trace parser_tracer @@ pretty_print_reasonligo source

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

@ -1,26 +1,28 @@
open Main_errors
open Trace
type form =
| Contract of string
| Env
let compile (cform: form) (program : Ast_core.program) : (Ast_typed.program * Typesystem.Solver_types.typer_state) result =
let%bind (prog_typed , state) = Typer.type_program program in
let compile (cform: form) (program : Ast_core.program) : (Ast_typed.program * Typesystem.Solver_types.typer_state , _) result =
let%bind (prog_typed , state) = trace typer_tracer @@ Typer.type_program program in
let () = Typer.Solver.discard_state state in
let%bind applied = Self_ast_typed.all_program prog_typed in
let%bind applied' = match cform with
| Contract entrypoint -> Self_ast_typed.all_contract entrypoint applied
| Env -> ok applied in
ok @@ (applied', state)
let%bind applied = trace self_ast_typed_tracer @@
let%bind selfed = Self_ast_typed.all_program prog_typed in
match cform with
| Contract entrypoint -> Self_ast_typed.all_contract entrypoint selfed
| Env -> ok selfed in
ok @@ (applied, state)
let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem.Solver_types.typer_state) (e : Ast_core.expression)
: (Ast_typed.expression * Typesystem.Solver_types.typer_state) result =
let%bind (ae_typed,state) = Typer.type_expression_subst env state e in
: (Ast_typed.expression * Typesystem.Solver_types.typer_state , _) result =
let%bind (ae_typed,state) = trace typer_tracer @@ Typer.type_expression_subst env state e in
let () = Typer.Solver.discard_state state in
let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in
let%bind ae_typed' = trace self_ast_typed_tracer @@ Self_ast_typed.all_expression ae_typed in
ok @@ (ae_typed',state)
let apply (entry_point : string) (param : Ast_core.expression) : Ast_core.expression result =
let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result =
let name = Var.of_name entry_point in
let entry_point_var : Ast_core.expression =
{ expression_content = Ast_core.E_variable name ;
@ -30,9 +32,6 @@ let apply (entry_point : string) (param : Ast_core.expression) : Ast_core.expres
location = Virtual "generated application" } in
ok applied
let pretty_print formatter (program : Ast_core.program) =
Ast_core.PP.program formatter program
let list_declarations (program : Ast_core.program) : string list =
List.fold_left
(fun prev el ->

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

@ -1,3 +1,4 @@
open Main_errors
open Trace
open Ast_imperative
open Imperative_to_sugar
@ -6,11 +7,11 @@ type form =
| Contract of string
| Env
let compile (program : program) : Ast_sugar.program result =
compile_program program
let compile (program : program) : (Ast_sugar.program, _) result =
trace imperative_to_sugar_tracer @@ compile_program program
let compile_expression (e : expression) : Ast_sugar.expression result =
compile_expression e
let compile_expression (e : expression) : (Ast_sugar.expression , _) result =
trace imperative_to_sugar_tracer @@ compile_expression e
let pretty_print formatter (program : program) =
PP.program formatter program

60
src/main/compile/of_michelson.ml
View File

@ -1,71 +1,43 @@
open Main_errors
open Tezos_utils
open Proto_alpha_utils
open Trace
module Errors = struct
(*
TODO: those errors should have been caught in the earlier stages on the ligo pipeline
build_contract is a kind of security net
*)
let title_type_check_msg () = "generated Michelson contract failed to typecheck"
let bad_parameter c () =
let message () =
let code = Format.asprintf "%a" Michelson.pp c in
"bad contract parameter type (some michelson types are forbidden as contract parameter):\n"^code in
error title_type_check_msg message
let bad_storage c () =
let message () =
let code = Format.asprintf "%a" Michelson.pp c in
"bad storage type (some michelson types are forbidden as contract storage):\n"^code in
error title_type_check_msg message
let bad_contract c () =
let message () =
let code = Format.asprintf "%a" Michelson.pp c in
"bad contract type\n"^code in
error title_type_check_msg message
let ran_out_of_gas () =
let message () = "Ran out of gas!" in
error title_type_check_msg message
let unknown () =
let message () =
"unknown error" in
error title_type_check_msg message
end
let build_contract : ?disable_typecheck:bool -> Compiler.compiled_expression -> Michelson.michelson result =
let build_contract : ?disable_typecheck:bool -> Compiler.compiled_expression -> (Michelson.michelson , _) result =
fun ?(disable_typecheck= false) compiled ->
let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_contract_inputs compiled.expr_ty in
let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = trace_option (entrypoint_not_a_function) @@
Self_michelson.fetch_contract_inputs compiled.expr_ty in
let%bind param_michelson =
Trace.trace_tzresult_lwt (simple_error "Could not unparse parameter") @@
Trace.trace_tzresult_lwt unparse_tracer @@
Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in
let%bind storage_michelson =
Trace.trace_tzresult_lwt (simple_error "Could not unparse storage") @@
Trace.trace_tzresult_lwt unparse_tracer @@
Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in
let contract = Michelson.contract param_michelson storage_michelson compiled.expr in
if disable_typecheck then
ok contract
else
let%bind res =
Trace.trace_tzresult_lwt (simple_error "Could not typecheck the code") @@
Trace.trace_tzresult_lwt (typecheck_contract_tracer contract) @@
Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
match res with
| Type_checked -> ok contract
| Err_parameter -> fail @@ Errors.bad_parameter contract ()
| Err_storage -> fail @@ Errors.bad_storage contract ()
| Err_contract -> fail @@ Errors.bad_contract contract ()
| Err_gas -> fail @@ Errors.ran_out_of_gas ()
| Err_unknown -> fail @@ Errors.unknown ()
| Err_parameter -> fail @@ bad_parameter contract
| Err_storage -> fail @@ bad_storage contract
| Err_contract -> fail @@ bad_contract contract
| Err_gas -> fail @@ gas_exhaustion
| Err_unknown -> fail @@ unknown
type check_type = Check_parameter | Check_storage
let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result =
let assert_equal_contract_type : Simple_utils.Runned_result.check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> (unit , _) result =
fun c compiled_prg compiled_param ->
let%bind (Ex_ty expected_ty) =
let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in
let%bind (c_param_ty,c_storage_ty) = trace_option (entrypoint_not_a_function) @@
Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in
match c with
| Check_parameter -> ok c_param_ty
| Check_storage -> ok c_storage_ty in
let (Ex_ty actual_ty) = compiled_param.expr_ty in
let%bind _ =
Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@
Trace.trace_tzresult typecheck_parameters_tracer @@
Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in
ok ()

29
src/main/compile/of_mini_c.ml
View File

@ -1,31 +1,33 @@
open Main_errors
open Mini_c
open Proto_alpha_utils
open Trace
let compile_contract : expression -> Compiler.compiled_expression result = fun e ->
let%bind e = Self_mini_c.contract_check e in
let%bind (input_ty , _) = get_t_function e.type_expression in
let%bind body = get_function e in
let%bind body = Compiler.Program.translate_function_body body [] input_ty in
let compile_contract : expression -> (Compiler.compiled_expression , _) result = fun e ->
let%bind e = trace self_mini_c_tracer @@ Self_mini_c.contract_check e in
let%bind (input_ty , _) = trace self_mini_c_tracer @@ Self_mini_c.get_t_function e.type_expression in
let%bind body = trace self_mini_c_tracer @@ Self_mini_c. get_function e in
let%bind body = trace compiler_tracer @@ Compiler.Program.translate_function_body body [] input_ty in
let expr = Self_michelson.optimize body in
let%bind expr_ty = Compiler.Type.Ty.type_ e.type_expression in
let%bind expr_ty = trace compiler_tracer @@ Compiler.Type.Ty.type_ e.type_expression in
ok ({ expr_ty ; expr } : Compiler.Program.compiled_expression)
let compile_expression : expression -> Compiler.compiled_expression result = fun e ->
let compile_expression : expression -> (Compiler.compiled_expression, _) result = fun e ->
trace compiler_tracer @@
let%bind expr = Compiler.Program.translate_expression e Compiler.Environment.empty in
let expr = Self_michelson.optimize expr in
let%bind expr_ty = Compiler.Type.Ty.type_ e.type_expression in
ok ({ expr_ty ; expr } : Compiler.Program.compiled_expression)
let aggregate_and_compile = fun program form ->
let%bind aggregated = aggregate_entry program form in
let aggregate_and_compile : program -> form_t -> (Compiler.compiled_expression, _) result = fun program form ->
let%bind aggregated = trace self_mini_c_tracer @@ Self_mini_c.aggregate_entry program form in
let aggregated' = Self_mini_c.all_expression aggregated in
match form with
| ContractForm _ -> compile_contract aggregated'
| ExpressionForm _ -> compile_expression aggregated'
let aggregate_and_compile_contract = fun (program : Types.program) name ->
let%bind (exp, idx) = get_entry program name in
let aggregate_and_compile_contract : program -> string -> (Compiler.compiled_expression, _) result = fun program name ->
let%bind (exp, idx) = trace_option entrypoint_not_found @@ Mini_c.get_entry program name in
let program' = List.take idx program in
aggregate_and_compile program' (ContractForm exp)
@ -39,10 +41,11 @@ let pretty_print program =
(* TODO refactor? *)
let aggregate = fun program form ->
let%bind aggregated = aggregate_entry program form in
trace self_mini_c_tracer @@
let%bind aggregated = Self_mini_c.aggregate_entry program form in
ok @@ Self_mini_c.all_expression aggregated
let aggregate_contract = fun (program : Types.program) name ->
let%bind (exp, idx) = get_entry program name in
let%bind (exp, idx) = trace_option entrypoint_not_found @@ get_entry program name in
let program' = List.take idx program in
aggregate program' (ContractForm exp)

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

@ -1,20 +1,20 @@
open Trace
open Helpers
let compile (source_filename:string) syntax : Ast_imperative.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 abstract = parsify syntax source_filename in
ok abstract
let compile_string (source:string) syntax : Ast_imperative.program result =
let compile_string (source:string) syntax : (Ast_imperative.program , _) result =
let%bind abstract = parsify_string syntax source in
ok abstract
let compile_expression : v_syntax -> string -> Ast_imperative.expression result =
let compile_expression : v_syntax -> string -> (Ast_imperative.expression , _) result =
fun syntax exp ->
parsify_expression syntax exp
let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expression result =
let compile_contract_input : string -> string -> v_syntax -> (Ast_imperative.expression , _) result =
fun storage parameter syntax ->
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
ok @@ Ast_imperative.e_pair storage parameter
@ -26,4 +26,4 @@ let preprocess source_filename syntax =
Helpers.preprocess syntax source_filename
let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename
Helpers.pretty_print syntax source_filename

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

@ -1,19 +1,17 @@
open Trace
open Ast_sugar
open Sugar_to_core
open Main_errors
type form =
| Contract of string
| Env
let compile (program : program) : Ast_core.program result =
compile_program program
let compile (program : program) : (Ast_core.program , _) result =
trace sugar_to_core_tracer @@ 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 compile_expression (e : expression) : (Ast_core.expression , _) result =
trace sugar_to_core_tracer @@ compile_expression e
let list_declarations (program : program) : string list =
List.fold_left

46
src/main/compile/of_typed.ml
View File

@ -1,31 +1,29 @@
open Main_errors
open Trace
open Ast_typed
let compile : Ast_typed.program -> Mini_c.program result = fun p ->
Transpiler.transpile_program p
let compile : Ast_typed.program -> (Mini_c.program, _) result = fun p ->
trace transpiler_tracer @@ Transpiler.transpile_program p
let compile_expression : expression -> Mini_c.expression result = fun e ->
Transpiler.transpile_annotated_expression e
let compile_expression : expression -> (Mini_c.expression, _) result = fun e ->
trace transpiler_tracer @@ Transpiler.transpile_annotated_expression e
type check_type = Check_parameter | Check_storage
let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.expression -> unit result =
fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") (
let%bind entry_point = Ast_typed.get_entry contract entry in
match entry_point.type_expression.type_content with
| T_arrow {type1=args} -> (
match args.type_content with
| T_record m when LMap.cardinal m = 2 -> (
let {field_type=param_exp;_} = LMap.find (Label "0") m in
let {field_type=storage_exp;_} = LMap.find (Label "1") m in
match c with
| Check_parameter -> assert_type_expression_eq (param_exp, param.type_expression)
| Check_storage -> assert_type_expression_eq (storage_exp, param.type_expression)
)
| _ -> dummy_fail
let assert_equal_contract_type : Simple_utils.Runned_result.check_type -> string -> Ast_typed.program -> Ast_typed.expression -> (unit , _) result =
fun c entry contract param ->
let%bind entry_point = trace_option entrypoint_not_found (Ast_typed.get_entry contract entry) in
trace (arguments_check_tracer c) (
match entry_point.type_expression.type_content with
| T_arrow {type1=args} -> (
match args.type_content with
| T_record m when LMap.cardinal m = 2 -> (
let {field_type=param_exp;_} = LMap.find (Label "0") m in
let {field_type=storage_exp;_} = LMap.find (Label "1") m in
match c with
| Check_parameter -> trace typer_tracer @@ Typer.assert_type_expression_eq (param_exp, param.type_expression)
| Check_storage -> trace typer_tracer @@ Typer.assert_type_expression_eq (storage_exp, param.type_expression)
)
| _ -> fail @@ entrypoint_not_a_function )
| _ -> fail @@ entrypoint_not_a_function
)
| _ -> dummy_fail )
let pretty_print ppf program =
Ast_typed.PP.program ppf program
let some_interpret = Interpreter.dummy
let some_interpret x = trace interpret_tracer @@ Interpreter.eval x

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

@ -14,7 +14,7 @@ let to_core f stx =
let%bind core = Of_sugar.compile sugar in
ok @@ core
let type_file f stx env =
let type_file f stx env : (Ast_typed.program * Typesystem.Solver_types.typer_state, _) result =
let%bind core = to_core f stx in
let%bind typed,state = Of_core.compile env core in
ok @@ (typed,state)
@ -24,7 +24,7 @@ let to_mini_c f stx env =
let%bind mini_c = Of_typed.compile typed in
ok @@ mini_c
let compile_file f stx ep =
let compile_file f stx ep : (Michelson.michelson, _) result =
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

105
src/main/display.ml
View File

@ -1,105 +0,0 @@
open Trace
let rec error_pp ?(dev = false) out (e : error) =
let open JSON_string_utils in
let message =
let opt = e |> member "message" |> string in
match opt with
| Some msg -> ": " ^ msg
| None -> "" in
let error_code =
let error_code = e |> member "error_code" in
match error_code with
| `Null -> ""
| _ -> " (" ^ (J.to_string error_code) ^ ")" in
let title =
let opt = e |> member "title" |> string in
Option.unopt ~default:"" opt in
let data =
let data = e |> member "data" in
match data with
| `Null -> ""
| _ -> " " ^ (J.to_string data) ^ "\n" in
let infos =
let infos = e |> member "infos" in
match infos with
| `List lst -> lst
| `Null -> []
| x -> [ x ] in
let children =
let infos = e |> member "children" in
match infos with
| `List lst -> lst
| `Null -> []
| x -> [ x ] in
let location =
let opt = e |> member "data" |> member "location" |> string in
let aux cur prec =
match prec with
| None -> cur |> member "data" |> member "location" |> string
| Some s -> Some s
in
match List.fold_right aux infos opt with
| None -> ""
| Some s -> s ^ ". "
in
let print x = Format.fprintf out x in
if not dev then (
print "%s%s%s%s%s" location title error_code message data
) else (
print "%s%s%s.\n%s%s\n%a\n%a\n" title error_code message data location
(Format.pp_print_list (error_pp ~dev)) infos
(Format.pp_print_list (error_pp ~dev)) children
)
let result_pp_hr f out (r : _ result) =
match r with
| Ok (s , _) -> Format.fprintf out "%a" f s
| Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ())
let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s\n" s)
let result_pp_dev f out (r : _ result) =
match r with
| Ok (s , _) -> Format.fprintf out "%a" f s
| Error e -> Format.fprintf out "%a" (error_pp ~dev:true) (e ())
let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s\n" s)
let json_pp out x = Format.fprintf out "%s" (J.to_string x)
let string_result_pp_json out (r : string result) =
let status_json status content : J.t = `Assoc ([
("status" , `String status) ;
("content" , content) ;
]) in
match r with
| Ok (x , _) -> (
Format.fprintf out "%a\n" json_pp (status_json "ok" (`String x))
)
| Error e -> (
Format.fprintf out "%a\n" json_pp (status_json "error" (e ()))
)
type display_format = [
| `Human_readable
| `Json
| `Dev
]
let formatted_string_result_pp (display_format : display_format) =
match display_format with
| `Human_readable -> string_result_pp_hr
| `Dev -> string_result_pp_dev
| `Json -> string_result_pp_json
type michelson_format = [
| `Text
| `Json
| `Hex
]
let michelson_pp (mf : michelson_format) = match mf with
| `Text -> Michelson.pp
| `Json -> Michelson.pp_json
| `Hex -> Michelson.pp_hex

32
src/main/display.mli
View File

@ -1,32 +0,0 @@
open Trace
val error_pp : ?dev:bool -> Format.formatter -> error -> unit
val result_pp_hr : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Simple_utils.Trace.result -> unit
val string_result_pp_hr : Format.formatter -> string Simple_utils.Trace.result -> unit
val result_pp_dev : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Simple_utils.Trace.result -> unit
val string_result_pp_dev : Format.formatter -> string Simple_utils.Trace.result -> unit
val json_pp : Format.formatter -> Simple_utils.Trace.J.t -> unit
val string_result_pp_json : Format.formatter -> string result -> unit
type display_format = [
| `Human_readable
| `Json
| `Dev
]
val formatted_string_result_pp : display_format -> Format.formatter -> string Simple_utils.Trace.result -> unit
type michelson_format = [
| `Text
| `Json
| `Hex
]
val michelson_pp : michelson_format -> Format.formatter -> Tezos_utils.Michelson.michelson -> unit

1
src/main/dune
View File

@ -5,6 +5,7 @@
run
compile
uncompile
main_errors
)
(preprocess
(pps ppx_let bisect_ppx --conditional)

1
src/main/main.ml
View File

@ -2,3 +2,4 @@ module Run = Run
module Compile = Compile
module Uncompile = Uncompile
module Display = Display
module Formatter = Main_errors.Formatter

26
src/main/main_errors/dune Normal file
View File

@ -0,0 +1,26 @@
(library
(name main_errors)
(public_name ligo.main_errors)
(libraries
simple-utils
parser
concrete_to_imperative
self_ast_imperative
interpreter
imperative_to_sugar
ast_sugar
self_ast_sugar
sugar_to_core
self_ast_core
typer
self_ast_typed
transpiler
self_mini_c
compiler
self_michelson
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
)

294
src/main/main_errors/formatter.ml Normal file
View File

@ -0,0 +1,294 @@
open Trace
open Display
let error_suggest: string = "\n
If you're not sure how to fix this error, you can do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog'"
let rec error_ppformat' : display_format:string display_format ->
Format.formatter -> Types.all -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Test_err_tracer (name,err) ->
Format.fprintf f "@[<hv>Test '%s'@ %a@]"
name (error_ppformat' ~display_format) err
| `Test_run_tracer (ep, err) ->
Format.fprintf f "@[<hv>Running entrypoint '%s'@ %a@]"
ep (error_ppformat' ~display_format) err
| `Test_expect_tracer (expected, actual) ->
Format.fprintf f "@[<hv>Expected:@ %a@ got:@ %a@]"
Ast_core.PP.expression expected
Ast_core.PP.expression actual
| `Test_expect_n_tracer (i,err) ->
Format.fprintf f "@[<hv>Expect n=%d@ %a@]"
i (error_ppformat' ~display_format) err
| `Test_expect_exp_tracer (e,err) ->
Format.fprintf f "@[<hv>Expect %a@ %a@]"
Ast_core.PP.expression e
(error_ppformat' ~display_format) err
| `Test_expect_eq_n_tracer (i,err) ->
Format.fprintf f "@[<hv>Expected eq_n=%d@ %a@]"
i (error_ppformat' ~display_format) err
| `Test_internal t ->
Format.fprintf f "@[<hv>Internal error:@ %s@]" t
| `Test_md_file_tracer (md_file,s,grp,prg,err) ->
Format.fprintf f "@[<hv>Failed to compile %s@ syntax: %s@ group: %s@ program: %s@ %a@]"
md_file s grp prg (error_ppformat' ~display_format) err
| `Test_bad_code_block arg ->
Format.fprintf f "@[<hv>Bad code block argument '%s'@ only 'group=NAME' or 'skip' are allowed@]"
arg
| `Test_expected_to_fail -> Format.fprintf f "test was expected to fail but did not"
| `Test_not_expected_to_fail -> Format.fprintf f "test was not expected to fail but did"
| `Main_invalid_syntax_name syntax ->
Format.fprintf f
"@[<hv>Invalid syntax name '%s'@ Hint: Use 'pascaligo', 'cameligo' or 'reasonligo'@]"
syntax
| `Main_invalid_extension extension ->
Format.fprintf f
"@[<hv>Invalid extension '%s'@ Hint: Use '.ligo', '.mligo', '.religo' or the --syntax option@]"
extension
| `Main_bad_michelson_parameter c ->
let s = Format.asprintf
"generated Michelson contract failed to typecheck : bad contract parameter type\n\
code:\n %a" Michelson.pp c in
Format.pp_print_string f s
| `Main_bad_michelson_storage c ->
let s = Format.asprintf
"generated Michelson contract failed to typecheck : bad contract storage type\n\
code:\n %a" Michelson.pp c in
Format.pp_print_string f s
| `Main_bad_michelson c ->
let s = Format.asprintf
"generated Michelson contract failed to typecheck : bad contract type\n\
code:\n %a" Michelson.pp c in
Format.pp_print_string f s
| `Main_gas_exhaustion -> Format.pp_print_string f "gas exhaustion"
| `Main_unparse_tracer _ -> Format.pp_print_string f "could not unparse michelson type"
| `Main_typecheck_contract_tracer (c,_) ->
let s = Format.asprintf
"Could not typecheck michelson code:\n %a"
Michelson.pp c in
Format.pp_print_string f s
| `Main_typecheck_parameter -> Format.pp_print_string f "Passed parameter does not match the contract type"
| `Main_check_typed_arguments (Simple_utils.Runned_result.Check_parameter, err) ->
Format.fprintf f "@[<v>Provided parameter type does not match contract parameter type@ %a@]"
(error_ppformat' ~display_format) err
| `Main_check_typed_arguments (Simple_utils.Runned_result.Check_storage, err) ->
Format.fprintf f "@[<v>Provided storage type does not match contract storage type@ %a@]"
(error_ppformat' ~display_format) err
| `Main_unknown_failwith_type ->
Format.fprintf f "@[<v>Execution failed with an unknown failwith type@]"
| `Main_unknown ->
Format.fprintf f "@[<v>Unknown error@]"
| `Main_execution_failed (fw:Runned_result.failwith) ->
let value = match fw with
| Failwith_int i -> string_of_int i
| Failwith_string s -> s
| Failwith_bytes b -> Bytes.to_string b in
Format.fprintf f
"[<hv>Execution failed with %s@]"
value
| `Main_entrypoint_not_a_function -> Format.fprintf f "@[<hv>Given entrypoint is not a function@]"
| `Main_entrypoint_not_found -> Format.fprintf f "@[<hv>Missing entrypoint@]"
| `Main_invalid_amount a -> Format.fprintf f "@[<hv>Invalid amount %s@]" a
| `Main_invalid_address a -> Format.fprintf f "@[<hv>Invalid address %s@]" a
| `Main_invalid_timestamp t -> Format.fprintf f "@[<hv>Invalid timestamp notation %s@]" t
| `Main_unparse_michelson_result _ -> Format.fprintf f "@[<hv>Error unparsing michelson result@]"
| `Main_parse_payload _ -> Format.fprintf f "@[<hv>Error parsing message@]"
| `Main_pack_payload _ -> Format.fprintf f "@[<hv>Error packing message@]"
| `Main_parse_michelson_input _ -> Format.fprintf f "@[<hv>Error parsing input@]"
| `Main_parse_michelson_code _ -> Format.fprintf f "@[<hv>Error parsing program code@]"
| `Main_michelson_execution_error _ -> Format.fprintf f "@[<hv>Error of execution@]"
| `Main_parser e -> Parser.Errors.error_ppformat ~display_format f e
| `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_ppformat ~display_format f e
| `Main_imperative_to_sugar e -> Imperative_to_sugar.Errors.error_ppformat ~display_format f e
| `Main_sugar_to_core _e -> () (*no error in this pass*)
| `Main_cit_pascaligo e -> Concrete_to_imperative.Errors_pascaligo.error_ppformat ~display_format f e
| `Main_cit_cameligo e -> Concrete_to_imperative.Errors_cameligo.error_ppformat ~display_format f e
| `Main_typer e -> Typer.Errors.error_ppformat ~display_format f e
| `Main_interpreter _ -> () (*no error*)
| `Main_self_ast_typed e -> Self_ast_typed.Errors.error_ppformat ~display_format f e
| `Main_self_mini_c e -> Self_mini_c.Errors.error_ppformat ~display_format f e
| `Main_transpiler e -> Transpiler.Errors.error_ppformat ~display_format f e
| `Main_compiler e -> Compiler.Errors.error_ppformat ~display_format f e
| `Main_uncompile_michelson e -> Compiler.Errors.error_ppformat ~display_format f e
| `Main_uncompile_mini_c e -> Transpiler.Errors.error_ppformat ~display_format f e
| `Main_uncompile_typed e -> Typer.Errors.error_ppformat ~display_format f e
)
let error_ppformat : display_format:string display_format ->
Format.formatter -> Types.all -> unit = fun ~display_format f a ->
Format.fprintf f "@[<v>%a@ %s@]"
(error_ppformat' ~display_format) a
error_suggest
let rec error_jsonformat : Types.all -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Test_err_tracer _
| `Test_run_tracer _
| `Test_expect_tracer _
| `Test_expect_n_tracer _
| `Test_expect_exp_tracer _
| `Test_expect_eq_n_tracer _
| `Test_internal _
| `Test_md_file_tracer _
| `Test_bad_code_block _
| `Test_expected_to_fail
| `Test_not_expected_to_fail
-> `Null
(* Top-level errors *)
| `Main_invalid_syntax_name _ ->
json_error ~stage:"command line interpreter" ~content:(`String "bad syntax name")
| `Main_invalid_extension _ ->
json_error ~stage:"command line interpreter" ~content:(`String "bad file extension")
| `Main_bad_michelson_parameter c ->
let code = Format.asprintf "%a" Michelson.pp c in
let content = `Assoc [("message", `String "bad contract parameter type") ; ("code", `String code)] in
json_error ~stage:"michelson contract build" ~content
| `Main_bad_michelson_storage c ->
let code = Format.asprintf "%a" Michelson.pp c in
let content = `Assoc [("message", `String "bad contract storage type") ; ("code", `String code)] in
json_error ~stage:"michelson contract build" ~content
| `Main_bad_michelson c ->
let code = Format.asprintf "%a" Michelson.pp c in
let content = `Assoc [("message", `String "bad contract type") ; ("code", `String code)] in
json_error ~stage:"michelson contract build" ~content
| `Main_gas_exhaustion ->
let content = `Assoc [("message", `String "gas exhaustion")] in
json_error ~stage:"michelson contract build" ~content
| `Main_unparse_tracer _ ->
let content = `Assoc [("message", `String "could not unparse michelson type")] in
json_error ~stage:"michelson contract build" ~content
| `Main_typecheck_contract_tracer (c,_) ->
let code = Format.asprintf "%a" Michelson.pp c in
let content = `Assoc [
("message", `String "Could not typecheck michelson code") ;
("code", `String code) ; ] in
json_error ~stage:"michelson contract build" ~content
| `Main_typecheck_parameter ->
let content = `Assoc [("message", `String "Passed parameter does not match the contract type")] in
json_error ~stage:"michelson contract build" ~content
| `Main_check_typed_arguments (Simple_utils.Runned_result.Check_parameter, err) ->
let content = `Assoc [
("message", `String "Passed parameter does not match the contract type");
("children", error_jsonformat err);
] in
json_error ~stage:"contract argument typechecking" ~content
| `Main_check_typed_arguments (Simple_utils.Runned_result.Check_storage, err) ->
let content = `Assoc [
("message", `String "Passed storage does not match the contract type");
("children", error_jsonformat err);
] in
json_error ~stage:"contract argument typechecking" ~content
| `Main_unknown_failwith_type ->
json_error ~stage:"michelson execution" ~content:(`String "unknown failwith type")
| `Main_unknown ->
json_error ~stage:"michelson execution" ~content:(`String "unknown error")
| `Main_execution_failed (fw:Runned_result.failwith) ->
let value = match fw with
| Failwith_int i -> `Assoc [("value", `Int i) ; ("type", `String "int")]
| Failwith_string s -> `Assoc [("value", `String s) ; ("type", `String "int")]
| Failwith_bytes b -> `Assoc [("value", `String (Bytes.to_string b)) ; ("type", `String "bytes")]
in
let content = `Assoc [("failwith", value)] in
json_error ~stage:"michelson execution" ~content
| `Main_invalid_amount a ->
let message = `String "invalid amount" in
let value = `String a in
let content = `Assoc [("message", message) ; ("value", value)] in
json_error ~stage:"parsing command line parameters" ~content
| `Main_invalid_address a ->
let message = `String "invalid address" in
let value = `String a in
let content = `Assoc [("message", message) ; ("value", value)] in
json_error ~stage:"parsing command line parameters" ~content
| `Main_invalid_timestamp t ->
let message = `String "invalid timestamp notation" in
let value = `String t in
let content = `Assoc [("message", message) ; ("value", value)] in
json_error ~stage:"parsing command line parameters" ~content
| `Main_unparse_michelson_result _ ->
json_error ~stage:"michelson execution" ~content:(`String "error unparsing michelson result")
| `Main_parse_payload _ ->
json_error ~stage:"michelson execution" ~content:(`String "error parsing message")
| `Main_pack_payload _ ->
json_error ~stage:"michelson execution" ~content:(`String "error packing message")
| `Main_parse_michelson_input _ ->
json_error ~stage:"michelson execution" ~content:(`String "error parsing input")
| `Main_parse_michelson_code _ ->
json_error ~stage:"michelson execution" ~content:(`String "error parsing program code")
| `Main_michelson_execution_error _ ->
json_error ~stage:"michelson execution" ~content:(`String "error of execution")
| `Main_entrypoint_not_a_function -> json_error ~stage:"top-level glue" ~content:(`String "given entrypoint is not a function")
| `Main_entrypoint_not_found -> json_error ~stage:"top-level glue" ~content:(`String "Missing entrypoint")
| `Main_parser e -> Parser.Errors.error_jsonformat e
| `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_jsonformat e
| `Main_imperative_to_sugar e -> Imperative_to_sugar.Errors.error_jsonformat e
| `Main_sugar_to_core _ -> `Null (*no error in this pass*)
| `Main_cit_pascaligo e -> Concrete_to_imperative.Errors_pascaligo.error_jsonformat e
| `Main_cit_cameligo e -> Concrete_to_imperative.Errors_cameligo.error_jsonformat e
| `Main_typer e -> Typer.Errors.error_jsonformat e
| `Main_interpreter _ -> `Null (*no error*)
| `Main_self_ast_typed e -> Self_ast_typed.Errors.error_jsonformat e
| `Main_transpiler e -> Transpiler.Errors.error_jsonformat e
| `Main_self_mini_c e -> Self_mini_c.Errors.error_jsonformat e
| `Main_compiler e -> Compiler.Errors.error_jsonformat e
| `Main_uncompile_michelson e -> Compiler.Errors.error_jsonformat e
| `Main_uncompile_mini_c e -> Transpiler.Errors.error_jsonformat e
| `Main_uncompile_typed e -> Typer.Errors.error_jsonformat e
let error_format : _ Display.format = {
pp = error_ppformat;
to_json = error_jsonformat;
}

70
src/main/main_errors/main_errors.ml Normal file
View File

@ -0,0 +1,70 @@
module Formatter = Formatter
module Types = Types
(* passes tracers *)
let parser_tracer (e:Parser.Errors.parser_error) = `Main_parser e
let cit_cameligo_tracer (e:Concrete_to_imperative.Errors_cameligo.abs_error) = `Main_cit_cameligo e
let cit_pascaligo_tracer (e:Concrete_to_imperative.Errors_pascaligo.abs_error) = `Main_cit_pascaligo e
let self_ast_imperative_tracer (e:Self_ast_imperative.Errors.self_ast_imperative_error) = `Main_self_ast_imperative e
let imperative_to_sugar_tracer (e:Imperative_to_sugar.Errors.imperative_to_sugar_error) = `Main_imperative_to_sugar e
let sugar_to_core_tracer (e:Sugar_to_core.Errors.sugar_to_core_error) = `Main_sugar_to_core e
let typer_tracer (e:Typer.Errors.typer_error) = `Main_typer e
let self_ast_typed_tracer (e:Self_ast_typed.Errors.self_ast_typed_error) = `Main_self_ast_typed e
let self_mini_c_tracer (e:Self_mini_c.Errors.self_mini_c_error) = `Main_self_mini_c e
let transpiler_tracer (e:Transpiler.Errors.transpiler_error) = `Main_transpiler e
let compiler_tracer (e:Compiler.Errors.compiler_error) = `Main_compiler e
let interpret_tracer (e:Interpreter.interpreter_error) = `Main_interpreter e
let uncompile_mini_c : Transpiler.Errors.transpiler_error -> _ = fun e -> `Main_uncompile_mini_c e
let uncompile_typed : Typer.Errors.typer_error -> _ = fun e -> `Main_uncompile_typed e
let uncompile_michelson : Compiler.Errors.compiler_error -> _ = fun e -> `Main_uncompile_michelson e
(* top-level glue (in between passes) *)
let syntax_auto_detection extension = `Main_invalid_extension extension
let invalid_syntax syntax = `Main_invalid_syntax_name syntax
let entrypoint_not_a_function = `Main_entrypoint_not_a_function
let entrypoint_not_found = `Main_entrypoint_not_found
(* Michelson execution errors *)
let arguments_check_tracer ps err = `Main_check_typed_arguments (ps, err)
let unparse_tracer errs = `Main_unparse_tracer errs
let typecheck_contract_tracer c errs = `Main_typecheck_contract_tracer (c,errs)
let typecheck_parameters_tracer _ = `Main_typecheck_parameter
let bad_parameter c = `Main_bad_michelson_parameter c
let bad_storage c = `Main_bad_michelson_storage c
let bad_contract c = `Main_bad_michelson c
let gas_exhaustion = `Main_gas_exhaustion
let unknown = `Main_unknown
let unknown_failwith_type = `Main_unknown_failwith_type
let failwith fw = `Main_execution_failed fw
let unparsing_michelson_tracer err = `Main_unparse_michelson_result err
let parsing_payload_tracer err = `Main_parse_payload err
let packing_payload_tracer err = `Main_pack_payload err
let parsing_input_tracer err = `Main_parse_michelson_input err
let parsing_code_tracer err = `Main_parse_michelson_code err
let error_of_execution_tracer err = `Main_michelson_execution_error err
let invalid_amount s = `Main_invalid_amount s
let invalid_address s = `Main_invalid_address s
let invalid_timestamp s = `Main_invalid_timestamp s
(* test errors *)
let test_tracer name err = `Test_err_tracer (name,err)
let test_run_tracer entrypoint err = `Test_run_tracer (entrypoint,err)
let test_expect expected actual = `Test_expect_tracer (expected,actual)
let test_expect_n_tracer i err = `Test_expect_n_tracer (i,err)
let test_expect_exp_tracer e err = `Test_expect_exp_tracer (e,err)
let test_expect_eq_n_tracer i err = `Test_expect_eq_n_tracer (i,err)
let test_internal loc = `Test_internal loc
let test_md_file_tracer md_file s group prg err = `Test_md_file_tracer (md_file,s,group,prg,err)
let test_code_block_arg arg = `Test_bad_code_block arg
let test_expected_to_fail = `Test_expected_to_fail
let test_not_expected_to_fail = `Test_not_expected_to_fail

56
src/main/main_errors/types.ml Normal file
View File

@ -0,0 +1,56 @@
type all =
[
| `Main_invalid_syntax_name of string
| `Main_invalid_extension of string
| `Main_bad_michelson_parameter of Michelson.michelson
| `Main_bad_michelson_storage of Michelson.michelson
| `Main_bad_michelson of Michelson.michelson
| `Main_gas_exhaustion
| `Main_unparse_tracer of [ `Tezos_alpha_error of Proto_alpha_utils.Error_monad.error ] list
| `Main_typecheck_contract_tracer of Michelson.michelson * [ `Tezos_alpha_error of Proto_alpha_utils.Error_monad.error ] list
| `Main_typecheck_parameter
| `Main_check_typed_arguments of Simple_utils.Runned_result.check_type * all
| `Main_unknown_failwith_type
| `Main_unknown
| `Main_execution_failed of Runned_result.failwith
| `Main_unparse_michelson_result of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_parse_payload of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_pack_payload of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_parse_michelson_input of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_parse_michelson_code of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_michelson_execution_error of Proto_alpha_utils.Trace.tezos_alpha_error list
| `Main_parser of Parser.Errors.parser_error
| `Main_self_ast_imperative of Self_ast_imperative.Errors.self_ast_imperative_error
| `Main_imperative_to_sugar of Imperative_to_sugar.Errors.imperative_to_sugar_error
| `Main_sugar_to_core of Sugar_to_core.Errors.sugar_to_core_error
| `Main_cit_pascaligo of Concrete_to_imperative.Errors_pascaligo.abs_error
| `Main_cit_cameligo of Concrete_to_imperative.Errors_cameligo.abs_error
| `Main_typer of Typer.Errors.typer_error
| `Main_interpreter of Interpreter.interpreter_error
| `Main_self_ast_typed of Self_ast_typed.Errors.self_ast_typed_error
| `Main_self_mini_c of Self_mini_c.Errors.self_mini_c_error
| `Main_transpiler of Transpiler.Errors.transpiler_error
| `Main_compiler of Compiler.Errors.compiler_error
| `Main_uncompile_michelson of Compiler.Errors.compiler_error
| `Main_uncompile_mini_c of Transpiler.Errors.transpiler_error
| `Main_uncompile_typed of Typer.Errors.typer_error
| `Main_entrypoint_not_a_function
| `Main_entrypoint_not_found
| `Main_invalid_amount of string
| `Main_invalid_address of string
| `Main_invalid_timestamp of string
| `Test_err_tracer of string * all
| `Test_run_tracer of string * all
| `Test_expect_tracer of Ast_core.expression * Ast_core.expression
| `Test_expect_n_tracer of int * all
| `Test_expect_exp_tracer of Ast_core.expression * all
| `Test_expect_eq_n_tracer of int * all
| `Test_internal of string
| `Test_md_file_tracer of string * string * string * string * all
| `Test_bad_code_block of string
| `Test_expected_to_fail
| `Test_not_expected_to_fail
]

85
src/main/run/of_michelson.ml
View File

@ -2,33 +2,12 @@ open Proto_alpha_utils
open Trace
open Memory_proto_alpha.Protocol.Script_ir_translator
open Memory_proto_alpha.X
open Simple_utils.Runned_result
module Errors = struct
let unknown_failwith_type () =
let title () = "Execution failed with an unknown failwith type" in
let message () = "only bytes, string or int are printable" in
error title message
let failwith str () =
let title () = "Execution failed" in
let message () = "" in
let data = [
("value" , fun () -> Format.asprintf "%s" str);
] in
error ~data title message
end
module Errors = Main_errors
type options = Memory_proto_alpha.options
type run_failwith_res =
| Failwith_int of int
| Failwith_string of string
| Failwith_bytes of bytes
type run_res =
| Success of ex_typed_value
| Fail of run_failwith_res
type dry_run_options =
{ amount : string ;
balance : string ;
@ -36,23 +15,15 @@ type dry_run_options =
sender : string option ;
source : string option }
let failwith_to_string (f:run_failwith_res) : string result =
let%bind str = match f with
| Failwith_int i -> ok @@ string_of_int i
| Failwith_string s -> ok @@ Format.asprintf "\"%s\"" (String.escaped s)
| Failwith_bytes b ->
ok @@ Format.asprintf "0X%a" Hex.pp (Hex.of_bytes b) in
ok @@ Format.asprintf "failwith(%s)" str
let make_dry_run_options (opts : dry_run_options) : options result =
let make_dry_run_options (opts : dry_run_options) : (options , _) result =
let open Proto_alpha_utils.Trace in
let open Proto_alpha_utils.Memory_proto_alpha in
let open Protocol.Alpha_context in
let%bind balance = match Tez.of_string opts.balance with
| None -> simple_fail "invalid amount"
| None -> fail @@ Errors.invalid_amount opts.balance
| Some balance -> ok balance in
let%bind amount = match Tez.of_string opts.amount with
| None -> simple_fail "invalid amount"
| None -> fail @@ Errors.invalid_amount opts.balance
| Some amount -> ok amount in
let%bind sender =
match opts.sender with
@ -60,7 +31,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
| Some sender ->
let%bind sender =
trace_alpha_tzresult
(simple_error "invalid address")
(fun _ -> Errors.invalid_address sender)
(Contract.of_b58check sender) in
ok (Some sender) in
let%bind source =
@ -69,7 +40,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
| Some source ->
let%bind source =
trace_alpha_tzresult
(simple_error "invalid source address")
(fun _ -> Errors.invalid_address source)
(Contract.of_b58check source) in
ok (Some source) in
let%bind predecessor_timestamp =
@ -78,33 +49,33 @@ let make_dry_run_options (opts : dry_run_options) : options result =
| Some st ->
match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with
| Some t -> ok (Some t)
| None -> simple_fail ("\""^st^"\" is a bad timestamp notation") in
| None -> fail @@ Errors.invalid_timestamp st in
ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ~balance ?sender ?source ()
let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result =
let ex_value_ty_to_michelson (v : ex_typed_value) : (Michelson.t , _) result =
let (Ex_typed_value (value , ty)) = v in
Trace.trace_tzresult_lwt (simple_error "error unparsing michelson result") @@
Trace.trace_tzresult_lwt Errors.unparsing_michelson_tracer @@
Memory_proto_alpha.unparse_michelson_data value ty
let pack_payload (payload:Michelson.t) ty =
let%bind payload =
Trace.trace_tzresult_lwt (simple_error "error parsing message") @@
Trace.trace_tzresult_lwt Errors.parsing_payload_tracer @@
Memory_proto_alpha.parse_michelson_data payload ty in
let%bind data =
Trace.trace_tzresult_lwt (simple_error "error packing message") @@
Trace.trace_tzresult_lwt Errors.packing_payload_tracer @@
Memory_proto_alpha.pack ty payload in
ok @@ data
let fetch_lambda_types (contract_ty:ex_ty) =
match contract_ty with
| Ex_ty (Lambda_t (in_ty, out_ty, _)) -> ok (Ex_ty in_ty, Ex_ty out_ty)
| _ -> simple_fail "failed to fetch lambda types"
| _ -> fail Errors.unknown (*TODO*)
let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : run_res result =
let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : (ex_typed_value runned_result, _) result =
let open! Tezos_raw_protocol_006_PsCARTHA in
let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in
let%bind input =
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
Trace.trace_tzresult_lwt Errors.parsing_input_tracer @@
Memory_proto_alpha.parse_michelson_data input_michelson input_ty
in
let top_level = Script_ir_translator.Toplevel
@ -114,11 +85,11 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi
let ty_stack_after = Script_typed_ir.Item_t (output_ty, Empty_t, None) in
let exp = Michelson.strip_annots exp in
let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Trace.trace_tzresult_lwt Errors.parsing_code_tracer @@
Memory_proto_alpha.parse_michelson_fail ~top_level exp ty_stack_before ty_stack_after in
let open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind res =
Trace.trace_tzresult_lwt (simple_error "error of execution") @@
Trace.trace_tzresult_lwt Errors.error_of_execution_tracer @@
Memory_proto_alpha.failure_interpret ?options descr (Item(input, Empty)) in
match res with
| Memory_proto_alpha.Succeed stack ->
@ -128,9 +99,9 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi
| Int (_ , i) -> ok @@ Fail (Failwith_int (Z.to_int i))
| String (_ , s) -> ok @@ Fail (Failwith_string s)
| Bytes (_, s) -> ok @@ Fail (Failwith_bytes s)
| _ -> fail @@ Errors.unknown_failwith_type () )
| _ -> fail @@ Errors.unknown_failwith_type )
let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result =
let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : (ex_typed_value runned_result, _) result =
let open! Tezos_raw_protocol_006_PsCARTHA in
let (Ex_ty exp_type') = exp_type in
let exp = Michelson.strip_annots exp in
@ -138,11 +109,11 @@ let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result
and ty_stack_before = Script_typed_ir.Empty_t
and ty_stack_after = Script_typed_ir.Item_t (exp_type', Empty_t, None) in
let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Trace.trace_tzresult_lwt Errors.parsing_code_tracer @@
Memory_proto_alpha.parse_michelson_fail ~top_level exp ty_stack_before ty_stack_after in
let open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind res =
Trace.trace_tzresult_lwt (simple_error "error of execution") @@
Trace.trace_tzresult_lwt Errors.error_of_execution_tracer @@
Memory_proto_alpha.failure_interpret ?options descr Empty in
match res with
| Memory_proto_alpha.Succeed stack ->
@ -152,24 +123,22 @@ let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result
| Int (_ , i) -> ok @@ Fail (Failwith_int (Z.to_int i))
| String (_ , s) -> ok @@ Fail (Failwith_string s)
| Bytes (_, s) -> ok @@ Fail (Failwith_bytes s)
| _ -> fail @@ Errors.unknown_failwith_type () )
| _ -> fail @@ Errors.unknown_failwith_type )
let run_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : run_failwith_res result =
let run_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : (failwith , _) result =
let%bind expr = run_expression ?options exp exp_type in
match expr with
| Success _ -> simple_fail "An error of execution was expected"
| Success _ -> fail Errors.unknown (* TODO : simple_fail "an error of execution was expected" *)
| Fail res -> ok res
let run_no_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : ex_typed_value result =
let run_no_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : (ex_typed_value , _) result =
let%bind expr = run_expression ?options exp exp_type in
match expr with
| Success tval -> ok tval
| Fail _ -> simple_fail "Unexpected error of execution"
| Fail _ -> fail Errors.unknown (* TODO : simple_fail "unexpected error of execution" *)
let evaluate_expression ?options exp exp_type =
let%bind etv = run_expression ?options exp exp_type in
match etv with
| Success etv' -> ex_value_ty_to_michelson etv'
| Fail res ->
let%bind str = failwith_to_string res in
fail @@ Errors.failwith str ()
| Fail res -> fail @@ Errors.failwith res

1
src/main/uncompile/dune
View File

@ -11,6 +11,7 @@
ast_typed
mini_c
transpiler
main_errors
)
(preprocess
(pps ppx_let bisect_ppx --conditional)

35
src/main/uncompile/formatter.ml Normal file
View File

@ -0,0 +1,35 @@
open Display
open Simple_utils.Runned_result
let failwith_to_string (f:failwith) : string =
let str = match f with
| Failwith_int i -> string_of_int i
| Failwith_string s -> Format.asprintf "\"%s\"" (String.escaped s)
| Failwith_bytes b ->
Format.asprintf "0X%a" Hex.pp (Hex.of_bytes b) in
Format.asprintf "failwith(%s)" str
let expression_ppformat ~display_format f (runned_result,_) =
match display_format with
| Display.Human_readable | Dev -> (
match runned_result with
| Fail fail_res ->
let failstring = failwith_to_string fail_res in
Format.pp_print_string f failstring
| Success typed ->
Ast_core.PP.expression f typed
)
let expression_jsonformat (runned_result,_) : Display.json =
match runned_result with
| Fail fail_res ->
let failstring = failwith_to_string fail_res in
`Assoc [("value", `Null) ; ("failure", `String failstring)]
| Success typed ->
let temp = Format.asprintf "%a" Ast_core.PP.expression typed in
`Assoc [("value", `String temp) ; ("failure", `Null)]
let expression_format : 'a Display.format = {
pp = expression_ppformat ;
to_json = expression_jsonformat ;
}

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

@ -1,25 +1,44 @@
module Formatter = Formatter
open Main_errors
open Trace
open Simple_utils.Runned_result
type ret_type = Function | Expression
let uncompile_value func_or_expr program entry ex_ty_value =
let%bind entry_expression = Ast_typed.get_entry program entry in
let%bind output_type = match func_or_expr with
| Expression -> ok entry_expression.type_expression
let%bind output_type =
let%bind entry_expression = trace_option entrypoint_not_found @@ Ast_typed.get_entry program entry in
match func_or_expr with
| Expression ->
ok entry_expression.type_expression
| Function ->
let%bind (_,output_type) = Ast_typed.get_t_function entry_expression.type_expression in
let%bind (_,output_type) = trace_option entrypoint_not_a_function @@ Ast_typed.get_t_function entry_expression.type_expression in
ok output_type in
let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = Transpiler.untranspile mini_c output_type in
let%bind core = Typer.untype_expression typed in
let%bind mini_c = trace uncompile_michelson @@ Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = trace uncompile_mini_c @@ Transpiler.untranspile mini_c output_type in
let%bind core = trace uncompile_typed @@ Typer.untype_expression typed in
ok @@ core
let uncompile_typed_program_entry_expression_result program entry ex_ty_value =
uncompile_value Expression program entry ex_ty_value
let uncompile_typed_program_entry_expression_result program entry runned_result =
match runned_result with
| Fail s -> ok (Fail s)
| Success ex_ty_value ->
let%bind uncompiled_value = uncompile_value Expression program entry ex_ty_value in
ok (Success uncompiled_value)
let uncompile_typed_program_entry_function_result program entry ex_ty_value =
uncompile_value Function program entry ex_ty_value
let uncompile_typed_program_entry_function_result program entry runned_result =
match runned_result with
| Fail s -> ok (Fail s)
| Success ex_ty_value ->
let%bind uncompiled_value = uncompile_value Function program entry ex_ty_value in
ok (Success uncompiled_value)
let uncompile_expression type_value runned_result =
match runned_result with
| Fail s -> ok (Fail s)
| Success ex_ty_value ->
let%bind mini_c = trace uncompile_michelson @@ Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = trace uncompile_mini_c @@ Transpiler.untranspile mini_c type_value in
let%bind uncompiled_value = trace uncompile_typed @@ Typer.untype_expression typed in
ok (Success uncompiled_value)
let uncompile_expression type_value ex_ty_value =
let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = Transpiler.untranspile mini_c type_value in
Typer.untype_expression typed

8
src/passes/01-parser/cameligo.ml
View File

@ -69,14 +69,6 @@ module ParserLog =
module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
module Errors =
struct
let generic message =
let title () = ""
and message () = message.Region.value
in Trace.error ~data:[] title message
end
let apply parser =
let local_fail error =
Trace.fail

11
src/passes/01-parser/cameligo.mli
View File

@ -1,13 +1,14 @@
(** This file provides an interface to the CameLIGO parser. *)
open Trace
module AST = Parser_cameligo.AST
(** Open a CameLIGO filename given by string and convert into an
abstract syntax tree. *)
val parse_file : string -> AST.t Trace.result
val parse_file : string -> (AST.t , Errors.parser_error) result
(** Convert a given string into a CameLIGO abstract syntax tree *)
val parse_string : string -> AST.t Trace.result
val parse_string : string -> (AST.t , Errors.parser_error) result
(** Parse a given string as a CameLIGO expression and return an
expression AST.
@ -15,10 +16,10 @@ val parse_string : string -> AST.t Trace.result
This is intended to be used for interactive interpreters, or other
scenarios where you would want to parse a CameLIGO expression
outside of a contract. *)
val parse_expression : string -> AST.expr Trace.result
val parse_expression : string -> (AST.expr , Errors.parser_error) result
(** Preprocess a given CameLIGO file and preprocess it. *)
val preprocess : string -> Buffer.t Trace.result
val preprocess : string -> (Buffer.t , Errors.parser_error) result
(** Pretty-print a given CameLIGO file (after parsing it). *)
val pretty_print : string -> Buffer.t Trace.result
val pretty_print : string -> (Buffer.t, Errors.parser_error) result

4
src/passes/01-parser/cameligo/AST.ml
View File

@ -493,6 +493,10 @@ let expr_to_region = function
| ESeq {region; _} | ERecord {region; _} | EUpdate {region; _}
| ECodeInsert {region; _} -> region
let declaration_to_region = function
| Let {region;_}
| TypeDecl {region;_} -> region
let selection_to_region = function
FieldName f -> f.region
| Component c -> c.region

2
src/passes/01-parser/cameligo/ParserLog.ml
View File

@ -612,6 +612,8 @@ let pattern_to_string ~offsets ~mode =
to_string ~offsets ~mode print_pattern
let expr_to_string ~offsets ~mode =
to_string ~offsets ~mode print_expr
let type_expr_to_string ~offsets ~mode =
to_string ~offsets ~mode print_type_expr
(** {1 Pretty-printing the AST} *)

2
src/passes/01-parser/cameligo/ParserLog.mli
View File

@ -24,6 +24,8 @@ val pattern_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.pattern -> string
val expr_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.expr -> string
val type_expr_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.type_expr -> string
(** {1 Pretty-printing of AST nodes} *)

78
src/passes/01-parser/errors.ml Normal file
View File

@ -0,0 +1,78 @@
open Trace
open Simple_utils.Display
type parser_error = [
| `Parser_generic of string Region.reg
| `Parser_wrong_function_arguments of Parser_cameligo.AST.expr
| `Parser_invalid_wild of Parser_cameligo.AST.expr
]
let stage = "parser"
let generic reg = `Parser_generic reg
let wrong_function_arguments expr = `Parser_wrong_function_arguments expr
let invalid_wild expr = `Parser_invalid_wild expr
let wrong_function_msg =
"It looks like you are defining a function, \
however we do not\n\
understand the parameters declaration.\n\
Examples of valid functions:\n\
let x = (a: string, b: int) : int => 3;\n\
let tuple = ((a, b): (int, int)) => a + b; \n\
let x = (a: string) : string => \"Hello, \" ++ a;\n"
let wild_pattern_msg =
"It looks like you are using a wild pattern where it cannot be used"
let error_ppformat : display_format:string display_format ->
Format.formatter -> parser_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Parser_generic reg ->
Format.pp_print_string f reg.Region.value ;
| `Parser_wrong_function_arguments expr ->
let loc = Format.asprintf "%a"
Location.pp_lift @@ Parser_cameligo.AST.expr_to_region expr in
let s = Format.asprintf "%s\n%s" loc wrong_function_msg in
Format.pp_print_string f s ;
| `Parser_invalid_wild expr ->
let loc = Format.asprintf "%a"
Location.pp_lift @@ Parser_cameligo.AST.expr_to_region expr in
let s = Format.asprintf "%s\n%s" loc wild_pattern_msg in
Format.pp_print_string f s ;
)
let error_jsonformat : parser_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Parser_generic reg ->
let content = `Assoc [
("message", `String reg.Region.value); ]
in
json_error ~stage ~content
| `Parser_wrong_function_arguments expr ->
let loc = Format.asprintf "%a" Location.pp_lift @@
Parser_cameligo.AST.expr_to_region expr in
let content = `Assoc [
("message", `String wrong_function_msg);
("location", `String loc); ]
in
json_error ~stage ~content
| `Parser_invalid_wild expr ->
let loc = Format.asprintf "%a" Location.pp_lift @@
Parser_cameligo.AST.expr_to_region expr in
let content = `Assoc [
("message", `String wild_pattern_msg);
("location", `String loc); ]
in
json_error ~stage ~content

14
src/passes/01-parser/formatter.ml Normal file
View File

@ -0,0 +1,14 @@
open Display
let ppx_ppformat ~display_format f (buf,_) =
match display_format with
| Human_readable | Dev -> Format.fprintf f "%s\n" (Buffer.contents buf)
let ppx_jsonformat (buf,_) : json =
let s = Format.asprintf "%s" (Buffer.contents buf) in
`String s
let ppx_format : 'a format = {
pp = ppx_ppformat;
to_json = ppx_jsonformat;
}

4
src/passes/01-parser/parser.ml
View File

@ -1,5 +1,5 @@
module Pascaligo = Pascaligo
module Cameligo = Cameligo
module Reasonligo = Reasonligo
module Errors = Errors
module Formatter = Formatter

8
src/passes/01-parser/pascaligo.ml
View File

@ -68,14 +68,6 @@ module ParserLog =
module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
module Errors =
struct
let generic message =
let title () = ""
and message () = message.Region.value
in Trace.error ~data:[] title message
end
let apply parser =
let local_fail error =
Trace.fail

10
src/passes/01-parser/pascaligo.mli
View File

@ -1,13 +1,15 @@
(** This file provides an interface to the PascaLIGO parser. *)
open Errors
open Trace
module AST = Parser_pascaligo.AST
(** Open a PascaLIGO filename given by string and convert into an
abstract syntax tree. *)
val parse_file : string -> AST.t Trace.result
val parse_file : string -> (AST.t, parser_error) result
(** Convert a given string into a PascaLIGO abstract syntax tree *)
val parse_string : string -> AST.t Trace.result
val parse_string : string -> (AST.t, parser_error) result
(** Parse a given string as a PascaLIGO expression and return an
expression AST.
@ -15,7 +17,7 @@ val parse_string : string -> AST.t Trace.result
This is intended to be used for interactive interpreters, or other
scenarios where you would want to parse a PascaLIGO expression
outside of a contract. *)
val parse_expression : string -> AST.expr Trace.result
val parse_expression : string -> (AST.expr, parser_error) result
(** Preprocess a given PascaLIGO file and preprocess it. *)
val preprocess : string -> Buffer.t Trace.result
val preprocess : string -> (Buffer.t, parser_error) result

6
src/passes/01-parser/pascaligo/AST.ml
View File

@ -806,6 +806,12 @@ let pattern_to_region = function
| PList PCons {region; _}
| PTuple {region; _} -> region
let declaration_to_region = function
TypeDecl {region;_}
| ConstDecl {region;_}
| FunDecl {region;_}
| AttrDecl {region;_} -> region
let lhs_to_region : lhs -> Region.t = function
Path path -> path_to_region path
| MapPath {region; _} -> region

2
src/passes/01-parser/pascaligo/ParserLog.ml
View File

@ -858,6 +858,8 @@ let pattern_to_string ~offsets ~mode =
to_string ~offsets ~mode print_pattern
let instruction_to_string ~offsets ~mode =
to_string ~offsets ~mode print_instruction
let type_expr_to_string ~offsets ~mode =
to_string ~offsets ~mode print_type_expr
(* Pretty-printing the AST *)

2
src/passes/01-parser/pascaligo/ParserLog.mli
View File

@ -30,6 +30,8 @@ val pattern_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.pattern -> string
val instruction_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.instruction -> string
val type_expr_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.type_expr -> string
(** {1 Pretty-printing of AST nodes} *)

38
src/passes/01-parser/reasonligo.ml
View File

@ -1,5 +1,3 @@
open Trace
module AST = Parser_cameligo.AST
module LexToken = Parser_reasonligo.LexToken
module Lexer = Lexer.Make (LexToken)
@ -72,42 +70,6 @@ module ParserLog =
module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
module Errors =
struct
let generic message =
let title () = ""
and message () = message.Region.value
in Trace.error ~data:[] title message
let wrong_function_arguments (expr: AST.expr) =
let title () = "" in
let message () =
"It looks like you are defining a function, \
however we do not\n\
understand the parameters declaration.\n\
Examples of valid functions:\n\
let x = (a: string, b: int) : int => 3;\n\
let tuple = ((a, b): (int, int)) => a + b; \n\
let x = (a: string) : string => \"Hello, \" ++ a;\n" in
let expression_loc = AST.expr_to_region expr in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
in error ~data title message
let invalid_wild (expr: AST.expr) =
let title () = "" in
let message () =
"It looks like you are using a wild pattern where it cannot be used."
in
let expression_loc = AST.expr_to_region expr in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
in error ~data title message
end
let apply parser =
let local_fail error =
Trace.fail

11
src/passes/01-parser/reasonligo.mli
View File

@ -1,13 +1,14 @@
(** This file provides an interface to the ReasonLIGO parser. *)
open Trace
module AST = Parser_cameligo.AST
(** Open a ReasonLIGO filename given by string and convert into an
abstract syntax tree. *)
val parse_file : string -> AST.t Trace.result
val parse_file : string -> (AST.t , Errors.parser_error) result
(** Convert a given string into a ReasonLIGO abstract syntax tree *)
val parse_string : string -> AST.t Trace.result
val parse_string : string -> (AST.t , Errors.parser_error) result
(** Parse a given string as a ReasonLIGO expression and return an
expression AST.
@ -15,10 +16,10 @@ val parse_string : string -> AST.t Trace.result
This is intended to be used for interactive interpreters, or other
scenarios where you would want to parse a ReasonLIGO expression
outside of a contract. *)
val parse_expression : string -> AST.expr Trace.result
val parse_expression : string -> (AST.expr , Errors.parser_error) result
(** Preprocess a given ReasonLIGO file and preprocess it. *)
val preprocess : string -> Buffer.t Trace.result
val preprocess : string -> (Buffer.t , Errors.parser_error) result
(** Pretty-print a given CameLIGO file (after parsing it). *)
val pretty_print : string -> Buffer.t Trace.result
val pretty_print : string -> (Buffer.t , Errors.parser_error) result

235
src/passes/02-concrete_to_imperative/cameligo.ml
View File

@ -1,5 +1,6 @@
[@@@warning "-45"]
open Errors_cameligo
open Trace
open Ast_imperative
@ -18,152 +19,6 @@ let pseq_to_list = function
| Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
module Errors = struct
let wrong_pattern expected_name actual =
let title () = "wrong pattern" in
let message () =
match actual with
| Raw.PVar v -> v.value
| Raw.PTuple _ -> "tuple"
| Raw.PRecord _ -> "record"
| Raw.PList _ -> "list"
| Raw.PBytes _ -> "bytes"
| _ -> "other"
in
let data = [
("expected", fun () -> expected_name);
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@
Raw.pattern_to_region actual)]
in error ~data title message
let unsupported_let_in_function (region : Region.t) (patterns : Raw.pattern list) =
let title () = "" in
let message () = "\nDefining functions with \"let ... in\" \
is not supported yet.\n" in
let patterns_loc =
List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p))
region patterns in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc)]
in error ~data title message
let unknown_predefined_type name =
let title () = "Type constants" in
let message () =
Format.asprintf "Unknown predefined type \"%s\".\n"
name.Region.value in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)]
in error ~data title message
let untyped_fun_param var =
let title () = "" in
let message () =
Format.asprintf "\nUntyped function parameters \
are not supported yet.\n" in
let param_loc = var.Region.region in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)]
in error ~data title message
let untyped_recursive_function var =
let title () = "" in
let message () =
Format.asprintf "\nUntyped recursive functions \
are not supported yet.\n" in
let param_loc = var.Region.region in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)]
in error ~data title message
let unsupported_tuple_pattern p =
let title () = "" in
let message () =
Format.asprintf "\nTuple patterns are not supported yet.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let unsupported_cst_constr p =
let title () = "" in
let message () =
Format.asprintf "\nConstant constructors are not supported yet.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)]
in error ~data title message
let unsupported_non_var_pattern p =
let title () = "" in
let message () =
Format.asprintf "\nNon-variable patterns in constructors \
are not supported yet.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let abstracting_expr t =
let title () = "abstracting expression" in
let message () = "" in
let data = [
("expression" ,
(** TODO: The labelled arguments should be flowing from the CLI. *)
thunk @@ Parser_cameligo.ParserLog.expr_to_string
~offsets:true ~mode:`Point t)]
in error ~data title message
let only_constructors p =
let title () = "" in
let message () =
Format.asprintf "\nCurrently, only constructors are \
supported in patterns.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let unsupported_sugared_lists region =
let title () = "" in
let message () =
Format.asprintf "\nCurrently, only empty lists and \
constructors (::) \
are supported in patterns.\n" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)]
in error ~data title message
let corner_case description =
let title () = "Corner case" in
let message () = description in
error title message
let unknown_built_in name =
let title () = "\n Unknown built-in function" in
let message () = "" in
let data = [
("built-in", fun () -> name);
] in
error ~data title message
end
open Errors
open Operators.Concrete_to_imperative.Cameligo
let r_split = Location.r_split
@ -226,8 +81,8 @@ and unpar_pattern : Raw.pattern -> Raw.pattern = function
| PPar p -> unpar_pattern p.value.inside
| _ as p -> p
and compile_type_expression : Raw.type_expr -> type_expression result = fun te ->
trace (simple_info "abstracting this type expression...") @@
and compile_type_expression : Raw.type_expr -> (type_expression, abs_error) result = fun te ->
trace (abstracting_type_expr_tracer te) @@
match te with
TPar x -> compile_type_expression x.value.inside
| TVar v -> (
@ -255,38 +110,39 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
(match lst with
| [a ; b ; c ; d ] -> (
let%bind b' =
trace_option (simple_error "second argument of michelson_or must be a string singleton") @@
trace_option (michelson_type_wrong te name.value) @@
get_t_string_singleton_opt b in
let%bind d' =
trace_option (simple_error "fourth argument of michelson_or must be a string singleton") @@
trace_option (michelson_type_wrong te name.value) @@
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d'
)
| _ -> simple_fail "michelson_or does not have the right number of argument")
| _ -> fail @@ michelson_type_wrong_arity loc name.value)
| "michelson_pair" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
let%bind b' =
trace_option (simple_error "second argument of michelson_pair must be a string singleton") @@
trace_option (michelson_type_wrong te name.value) @@
get_t_string_singleton_opt b in
let%bind d' =
trace_option (simple_error "fourth argument of michelson_pair must be a string singleton") @@
trace_option (michelson_type_wrong te name.value) @@
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d'
)
| _ -> simple_fail "michelson_pair does not have the right number of argument")
| _ -> fail @@ michelson_type_wrong_arity loc name.value)
| _ ->
let lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_map_list compile_type_expression lst in
let%bind cst =
trace_option (unknown_predefined_type name) @@
type_operators name.value in
ok @@ t_operator ~loc cst lst' )
type_operators name.value in
ok @@ t_operator ~loc cst lst'
)
)
| TProd p -> (
let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in
@ -321,9 +177,9 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
@@ npseq_to_list s in
let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TString _s -> simple_fail "we don't support singleton string type"
| TString _s -> fail @@ unsupported_string_singleton te
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
and compile_list_type_expression (lst:Raw.type_expr list) : (type_expression , abs_error) result =
match lst with
| [] -> ok @@ t_unit ()
| [hd] -> compile_type_expression hd
@ -332,7 +188,7 @@ and compile_list_type_expression (lst:Raw.type_expr list) : type_expression resu
ok @@ t_tuple lst
let rec compile_expression :
Raw.expr -> expr result = fun t ->
Raw.expr -> (expr , abs_error) result = fun t ->
let return x = ok x in
let compile_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in
@ -377,7 +233,7 @@ let compile_update (u: Raw.update Region.reg) =
let aux ur ((var, path), expr) =
ok @@ e_update ~loc ur (Access_record var :: path) expr
in bind_fold_list aux record updates'
in trace (abstracting_expr t) @@
in trace (abstracting_expr_tracer t) @@
match t with
Raw.ELetIn e ->
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
@ -464,7 +320,7 @@ in trace (abstracting_expr t) @@
| Some t -> ok @@ t
| None -> match rhs'.expression_content with
| E_ascription a -> ok a.type_annotation
| _ -> fail @@ untyped_recursive_function e
| _ -> fail @@ untyped_recursive_fun e.Region.region
in
let expression_content = E_recursive {fun_name;fun_type;lambda} in
let expression_content = E_let_in {li with rhs = {li.rhs with expression_content}} in
@ -476,7 +332,7 @@ in trace (abstracting_expr t) @@
(* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) ->
fail @@ unsupported_let_in_function e.region (f :: p1 :: ps)
fail @@ unsupported_let_in_function (f :: p1 :: ps)
end
| Raw.EAnnot a ->
let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in
@ -645,7 +501,7 @@ in trace (abstracting_expr t) @@
return @@ e_raw_code ~loc language code
)
and compile_fun lamb' : expr result =
and compile_fun lamb' : (expr , abs_error) result =
let return x = ok x in
let (lamb , loc) = r_split lamb' in
let%bind params' =
@ -756,7 +612,7 @@ and compile_fun lamb' : expr result =
return @@ ret_lamb
and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
and compile_logic_expression ?te_annot (t:Raw.logic_expr) : (expr , abs_error) result =
let return x = ok @@ make_option_typed x te_annot in
match t with
| BoolExpr (False reg) -> (
@ -786,7 +642,7 @@ and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
| CompExpr (Neq c) ->
compile_binop "NEQ" c
and compile_list_expression (t:Raw.list_expr) : expression result =
and compile_list_expression (t:Raw.list_expr) : (expression , abs_error) result =
let return x = ok @@ x in
match t with
ECons c -> compile_binop "CONS" c
@ -798,7 +654,7 @@ and compile_list_expression (t:Raw.list_expr) : expression result =
return @@ e_list ~loc lst'
)
and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : (expression , abs_error) result =
let return x = ok @@ x in
let (args , loc) = r_split t in
let%bind a = compile_expression args.arg1 in
@ -806,14 +662,14 @@ and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result
let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ; b ]
and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : (expression , abs_error) result =
let return x = ok @@ x in
let (t , loc) = r_split t in
let%bind a = compile_expression t.arg in
let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ]
and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
and compile_tuple_expression ?loc (lst:Raw.expr list) : (expression , abs_error) result =
let return x = ok @@ x in
match lst with
| [] -> return @@ e_literal ?loc Literal_unit
@ -822,7 +678,7 @@ and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let%bind lst = bind_list @@ List.map compile_expression lst in
return @@ e_tuple ?loc lst
and compile_declaration : Raw.declaration -> declaration Location.wrap list result =
and compile_declaration : Raw.declaration -> (declaration Location.wrap list , abs_error) result =
fun t ->
let open! Raw in
let loc : 'a . 'a Raw.reg -> _ -> _ =
@ -881,7 +737,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
gen_access_tuple name ~i: (i + 1) ~accesses
in ok (gen_access_tuple name)
(* TODO: Improve this error message *)
| other -> fail @@ abstracting_expr other
| other -> fail @@ bad_deconstruction other
in let%bind decls =
(* 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))
@ -939,7 +795,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
| Some _ -> match rhs'.expression_content with
E_lambda lambda ->
(match lhs_type with
None -> fail @@ untyped_recursive_function var
None -> fail @@ untyped_recursive_fun var.Region.region
| Some (lhs_type) ->
let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in
ok @@ {rhs' with expression_content})
@ -948,7 +804,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
)
and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error) result =
fun t ->
let open Raw in
let rec get_var (t:Raw.pattern) =
@ -964,8 +820,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
let get_single (t:Raw.pattern) =
let t' = get_tuple t in
let%bind () =
trace_strong (unsupported_tuple_pattern t) @@
Assert.assert_list_size t' 1 in
Assert.assert_list_size (unsupported_tuple_pattern t) t' 1 in
ok (List.hd t') in
let rec get_constr (t:Raw.pattern) =
match t with
@ -1011,8 +866,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
let%bind patterns =
let aux (x , y) =
let xs = get_tuple x in
trace_strong (unsupported_tuple_pattern x) @@
Assert.assert_list_size xs 1 >>? fun () ->
let%bind () = Assert.assert_list_size (unsupported_tuple_pattern x) xs 1 in
ok (List.hd xs , y)
in
bind_map_list aux t in
@ -1023,8 +877,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
| [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
let%bind () =
trace_strong (unsupported_sugared_lists sugar_nil.region)
@@ Assert.assert_list_empty
Assert.assert_list_empty (unsupported_sugared_lists sugar_nil.region)
@@ pseq_to_list
@@ sugar_nil.value.elements in
let%bind (a, b) =
@ -1034,27 +887,18 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
ok (a, b) in
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil}
| lst ->
let error x =
let title () = "Pattern" in
(** TODO: The labelled arguments should be flowing from the CLI. *)
let content () =
Printf.sprintf "Pattern : %s"
(Parser_cameligo.ParserLog.pattern_to_string
~offsets:true ~mode:`Point x) in
error title content
in
let as_variant () =
trace (simple_info "currently, only booleans, lists, options, and constructors \
are supported in patterns") @@
trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let%bind constrs =
let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr x
let%bind x' = get_constr x
in ok (x', y)
in bind_map_list aux lst
in ok @@ ez_match_variant constrs in
let as_option () =
trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr_opt x
let%bind x' = get_constr_opt x
in ok (x', y) in
let%bind constrs = bind_map_list aux lst in
match constrs with
@ -1065,9 +909,12 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
ok @@ Match_option {
match_some = (Var.of_name some_var, some_expr);
match_none = none_expr }
| _ -> simple_fail "bad option pattern"
| _ -> fail @@ corner_case "bad option pattern"
in bind_or (as_option () , as_variant ())
let compile_program : Raw.ast -> program result = fun t ->
let%bind decls = bind_map_list compile_declaration @@ nseq_to_list t.decl in
let compile_program : Raw.ast -> (program , abs_error) result = fun t ->
let declarations = nseq_to_list t.decl in
let%bind decls =
trace (program_tracer declarations) @@
bind_map_list compile_declaration declarations in
ok @@ List.concat @@ decls

52
src/passes/02-concrete_to_imperative/cameligo.mli
View File

@ -7,56 +7,8 @@ module Raw = Parser.Cameligo.AST
module SMap = Map.String
module Option = Simple_utils.Option
(*
val nseq_to_list : 'a * 'a list -> 'a list
val npseq_to_list : 'a * ( 'b * 'a ) list -> 'a list
*)
val npseq_to_nelist : 'a * ( 'b * 'c ) list -> 'a * 'c list
(*
val pseq_to_list : ('a * ('b * 'a) list) option -> 'a list
val get_value : 'a Raw.reg -> 'a
*)
module Errors : sig
(*
val wrong_pattern : string -> Raw.pattern -> unit -> error
val multiple_patterns : string -> Raw.pattern list -> unit -> error
val unknown_predefined_type : string Raw.reg -> unit -> error
val unsupported_arith_op : Raw.expr -> unit -> error
val unsupported_string_catenation : Raw.expr -> unit -> error
val untyped_fun_param : 'a Raw.reg -> unit -> error
val unsupported_tuple_pattern : Raw.pattern -> unit -> error
val unsupported_cst_constr : Raw.pattern -> unit -> error
val unsupported_non_var_pattern : Raw.pattern -> unit -> error
val abstracting_expr : Raw.expr -> unit -> error
val only_constructors : Raw.pattern -> unit -> error
val unsupported_sugared_lists : Raw.wild -> unit -> error
val bad_set_definition : unit -> error
val bad_list_definition : unit -> error
val bad_map_definition : unit -> error
val corner_case : loc:string -> string -> unit -> error
*)
end
val compile_expression : Raw.expr -> (expr, Errors_cameligo.abs_error) result
(*
val r_split : 'a Raw.reg -> 'a * Location.t
val pattern_to_var : Raw.pattern -> Raw.variable 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 patterns_to_var : Raw.pattern list -> Raw.variable result
val compile_type_expression : Raw.type_expr -> type_expression result
val compile_list_type_expression : Raw.type_expr list -> type_expression result
*)
val compile_expression : Raw.expr -> expr result
(*
val compile_fun : Raw.fun_expr Raw.reg -> expr result
val compile_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result
val compile_list_expression : Raw.list_expr -> expression result
val compile_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result
val compile_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result
val compile_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result
val compile_declaration : Raw.declaration -> declaration Location.wrap result
val compile_cases : (Raw.pattern * 'a) list -> 'a matching result
*)
val compile_program : Raw.ast -> program result
val compile_program : Raw.ast -> (program, Errors_cameligo.abs_error) result

2
src/passes/02-concrete_to_imperative/concrete_to_imperative.ml
View File

@ -1,2 +1,4 @@
module Errors_cameligo = Errors_cameligo
module Errors_pascaligo = Errors_pascaligo
module Pascaligo = Pascaligo
module Cameligo = Cameligo

2
src/passes/02-concrete_to_imperative/dune
View File

@ -7,7 +7,7 @@
parser
ast_imperative
operators)
(modules cameligo pascaligo concrete_to_imperative)
(modules errors_cameligo errors_pascaligo cameligo pascaligo concrete_to_imperative)
(preprocess
(pps
ppx_let

316
src/passes/02-concrete_to_imperative/errors_cameligo.ml Normal file
View File

@ -0,0 +1,316 @@
open Trace
open Simple_utils.Display
module Raw = Parser_cameligo.AST
let stage = "abstracter"
type abs_error = [
| `Concrete_cameligo_wrong_pattern of string * Raw.pattern
| `Concrete_cameligo_unsupported_let_in of Raw.pattern list
| `Concrete_cameligo_unknown_predefined_type of Raw.type_constr
| `Concrete_cameligo_untyped_fun_param of Raw.variable
| `Concrete_cameligo_recursive_fun of Region.t
| `Concrete_cameligo_unsupported_tuple_pattern of Raw.pattern
| `Concrete_cameligo_unsupported_constant_constr of Raw.pattern
| `Concrete_cameligo_unsupported_non_var_pattern of Raw.pattern
| `Concrete_cameligo_unsupported_pattern_type of Raw.pattern list
| `Concrete_cameligo_unsupported_string_singleton of Raw.type_expr
| `Concrete_cameligo_abstraction_tracer of Raw.expr * abs_error
| `Concrete_cameligo_abstraction_type_tracer of Raw.type_expr * abs_error
| `Concrete_cameligo_bad_deconstruction of Raw.expr
| `Concrete_cameligo_only_constructors of Raw.pattern
| `Concrete_cameligo_unsupported_sugared_lists of Raw.wild
| `Concrete_cameligo_corner_case of string
| `Concrete_cameligo_unknown_built_in of string
| `Concrete_cameligo_michelson_type_wrong of Raw.type_expr * string
| `Concrete_cameligo_michelson_type_wrong_arity of Location.t * string
| `Concrete_cameligo_program_tracer of Raw.declaration list * abs_error
]
let wrong_pattern expected actual = `Concrete_cameligo_wrong_pattern (expected,actual)
let unsupported_let_in_function patterns = `Concrete_cameligo_unsupported_let_in patterns
let unknown_predefined_type name = `Concrete_cameligo_unknown_predefined_type name
let untyped_fun_param var = `Concrete_cameligo_untyped_fun_param var
let untyped_recursive_fun reg = `Concrete_cameligo_recursive_fun reg
let unsupported_tuple_pattern p = `Concrete_cameligo_unsupported_tuple_pattern p
let unsupported_cst_constr p = `Concrete_cameligo_unsupported_constant_constr p
let unsupported_non_var_pattern p = `Concrete_cameligo_unsupported_non_var_pattern p
let unsupported_pattern_type pl = `Concrete_cameligo_unsupported_pattern_type pl
let unsupported_string_singleton te = `Concrete_cameligo_unsupported_string_singleton te
let abstracting_expr_tracer t err = `Concrete_cameligo_abstraction_tracer (t,err)
let abstracting_type_expr_tracer t err = `Concrete_cameligo_abstraction_type_tracer (t,err)
let bad_deconstruction t = `Concrete_cameligo_bad_deconstruction t
let only_constructors p = `Concrete_cameligo_only_constructors p
let unsupported_sugared_lists region = `Concrete_cameligo_unsupported_sugared_lists region
let corner_case desc = `Concrete_cameligo_corner_case desc
let unknown_built_in name = `Concrete_cameligo_unknown_built_in name
let michelson_type_wrong texpr name = `Concrete_cameligo_michelson_type_wrong (texpr,name)
let michelson_type_wrong_arity loc name = `Concrete_cameligo_michelson_type_wrong_arity (loc,name)
let program_tracer decl err = `Concrete_cameligo_program_tracer (decl,err)
let rec error_ppformat : display_format:string display_format ->
Format.formatter -> abs_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Concrete_cameligo_wrong_pattern (expected_name,actual) ->
Format.fprintf f
"@[<hv>%a@Wrong pattern: expected %s got %s@]"
Location.pp_lift (Raw.pattern_to_region actual)
(Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point actual)
expected_name
| `Concrete_cameligo_unsupported_let_in expr ->
Format.fprintf f
"@[<hv>%a@Defining functions with \"let ... in\" is not supported yet@]"
Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost expr)
| `Concrete_cameligo_unknown_predefined_type type_name ->
Format.fprintf f
"@[<hv>%a@Unknown predefined type \"%s\"@]"
Location.pp_lift type_name.Region.region
type_name.Region.value
| `Concrete_cameligo_untyped_fun_param variable ->
Format.fprintf f
"@[<hv>%a@Untyped function parameters are not supported yet@]"
Location.pp_lift variable.Region.region
| `Concrete_cameligo_recursive_fun reg ->
Format.fprintf f
"@[<hv>%a@Untyped recursive functions are not supported yet@]"
Location.pp_lift reg
| `Concrete_cameligo_unsupported_tuple_pattern p ->
Format.fprintf f
"@[<hv>%a@The following tuple pattern is not supported yet:@\"%s\"@]"
Location.pp_lift (Raw.pattern_to_region p)
(Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p)
| `Concrete_cameligo_unsupported_constant_constr p ->
Format.fprintf f
"@[<hv>%a@Constant constructors are not supported yet@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_cameligo_unsupported_non_var_pattern p ->
Format.fprintf f
"@[<hv>%a@Non-variable patterns in constructors are not supported yet@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_cameligo_unsupported_pattern_type pl ->
Format.fprintf f
"@[<hv>%a@Currently, only booleans, lists, options, and constructors are supported in patterns@]"
Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl)
| `Concrete_cameligo_unsupported_string_singleton te ->
Format.fprintf f
"@[<hv>%a@Unsupported singleton string type@]"
Location.pp_lift (Raw.type_expr_to_region te)
| `Concrete_cameligo_abstraction_tracer (expr,err) ->
Format.fprintf f
"@[<hv>%a@Abstracting expression:@\"%s\"@%a@]"
Location.pp_lift (Raw.expr_to_region expr)
(Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr)
(error_ppformat ~display_format) err
| `Concrete_cameligo_abstraction_type_tracer (te,err) ->
Format.fprintf f
"@[<hv>%a@Abstracting type expression:@\"%s\"@%a@]"
Location.pp_lift (Raw.type_expr_to_region te)
(Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point te)
(error_ppformat ~display_format) err
| `Concrete_cameligo_bad_deconstruction expr ->
Format.fprintf f
"@[<hv>%a@Bad tuple deconstruction \"%s\"@]"
Location.pp_lift (Raw.expr_to_region expr)
(Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr)
| `Concrete_cameligo_only_constructors p ->
Format.fprintf f
"@[<hv>%a@Currently, only constructors are supported in patterns@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_cameligo_unsupported_sugared_lists wild ->
Format.fprintf f
"@[<hv>%a@Currently, only empty lists and constructors (::) are supported in patterns@]"
Location.pp_lift wild
| `Concrete_cameligo_corner_case desc ->
Format.fprintf f "Corner case: %s" desc
| `Concrete_cameligo_unknown_built_in bi ->
Format.fprintf f "Unknown built-in function %s" bi
| `Concrete_cameligo_michelson_type_wrong (texpr,name) ->
Format.fprintf f
"@[<hv>%a@Argument %s of %s must be a string singleton@]"
Location.pp_lift (Raw.type_expr_to_region texpr)
(Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr)
name
| `Concrete_cameligo_michelson_type_wrong_arity (loc,name) ->
Format.fprintf f
"@[<hv>%a@%s does not have the right number of argument@]"
Location.pp loc
name
| `Concrete_cameligo_program_tracer (decl,err) ->
Format.fprintf f
"@[<hv>%a@Abstracting program@%a@]"
Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl)
(error_ppformat ~display_format) err
)
let rec error_jsonformat : abs_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Concrete_cameligo_wrong_pattern (expected_name,actual) ->
let message = `String "wrong pattern" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region actual) in
let actual = (Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point actual) in
let content = `Assoc [
("message", message);
("location", `String loc);
("expected", `String expected_name);
("actual", `String actual) ] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_let_in expr ->
let message = `String "Defining functions with \"let ... in\" is not supported yet" in
let loc = Format.asprintf "%a"
Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost expr) in
let content = `Assoc [
("message", message);
("location", `String loc)] in
json_error ~stage ~content
| `Concrete_cameligo_unknown_predefined_type type_name ->
let message = `String "Unknown predefined type" in
let t = `String type_name.Region.value in
let loc = Format.asprintf "%a" Location.pp_lift type_name.Region.region in
let content = `Assoc [
("message", message );
("location", `String loc);
("type", t ) ] in
json_error ~stage ~content
| `Concrete_cameligo_untyped_fun_param variable ->
let message = `String "Untyped function parameters are not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift variable.Region.region in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_recursive_fun reg ->
let message = `String "Untyped recursive functions are not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift reg in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_tuple_pattern p ->
let message = `String "The following tuple pattern is not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let pattern = Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p in
let content = `Assoc [
("message", message );
("location", `String loc);
("pattern", `String pattern); ] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_constant_constr p ->
let message = `String "Constant constructors are not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_non_var_pattern p ->
let message = `String "Non-variable patterns in constructors are not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_pattern_type pl ->
let loc = Format.asprintf "%a"
Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl) in
let message = `String "Currently, only booleans, lists, options, and constructors are supported in patterns" in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_string_singleton te ->
let message = `String "Unsupported singleton string type" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region te) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_abstraction_tracer (expr,err) ->
let message = `String "Abstracting expression" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.expr_to_region expr) in
let expr = Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr in
let children = error_jsonformat err in
let content = `Assoc [
("message", message );
("location", `String loc);
("expression", `String expr);
("children", children) ] in
json_error ~stage ~content
| `Concrete_cameligo_abstraction_type_tracer (te,err) ->
let message = `String "Abstracting type expression" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region te) in
let expr = Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point te in
let children = error_jsonformat err in
let content = `Assoc [
("message", message );
("location", `String loc);
("type expression", `String expr);
("children", children) ] in
json_error ~stage ~content
| `Concrete_cameligo_bad_deconstruction expr ->
let message = `String "Bad tuple deconstruction" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.expr_to_region expr) in
let expr = Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr in
let content = `Assoc [
("message", message );
("location", `String loc);
("expression", `String expr) ] in
json_error ~stage ~content
| `Concrete_cameligo_only_constructors p ->
let message = `String "Currently, only constructors are supported in patterns" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_cameligo_unsupported_sugared_lists wild ->
let message = `String "Currently, only empty lists and constructors (::) are supported in patterns" in
let loc = Format.asprintf "%a" Location.pp_lift wild in
let content = `Assoc [
("message", message );
("location", `String loc); ] in
json_error ~stage ~content
| `Concrete_cameligo_corner_case desc ->
let message = Format.asprintf "Corner case: %s" desc in
let content = `Assoc [
("message", `String message ); ] in
json_error ~stage ~content
| `Concrete_cameligo_unknown_built_in bi ->
let message = Format.asprintf "Unknown built-in function %s" bi in
let content = `Assoc [
("message", `String message ); ] in
json_error ~stage ~content
| `Concrete_cameligo_michelson_type_wrong (texpr,name) ->
let message = Format.asprintf "Argument %s of %s must be a string singleton"
(Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr) name in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region texpr) in
let content = `Assoc [
("message", `String message );
("location", `String loc); ] in
json_error ~stage ~content
| `Concrete_cameligo_michelson_type_wrong_arity (loc,name) ->
let message = Format.asprintf "%s does not have the right number of argument" name in
let loc = Format.asprintf "%a" Location.pp loc in
let content = `Assoc [
("message", `String message );
("location", `String loc); ] in
json_error ~stage ~content
| `Concrete_cameligo_program_tracer (decl,err) ->
let message = `String "Abstracting program" in
let loc = Format.asprintf "%a"
Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl) in
let children = error_jsonformat err in
let content = `Assoc [
("message", message );
("location", `String loc);
("children", children) ] in
json_error ~stage ~content

227
src/passes/02-concrete_to_imperative/errors_pascaligo.ml Normal file
View File

@ -0,0 +1,227 @@
open Trace
open Simple_utils.Display
module Raw = Parser_pascaligo.AST
let stage = "abstracter"
type abs_error = [
| `Concrete_pascaligo_unsupported_constant_constr of Raw.pattern
| `Concrete_pascaligo_unknown_predefined_type of Raw.constr
| `Concrete_pascaligo_unsupported_non_var_pattern of Raw.pattern
| `Concrete_pascaligo_only_constructors of Raw.pattern
| `Concrete_pascaligo_unsupported_pattern_type of Raw.pattern list
| `Concrete_pascaligo_unsupported_tuple_pattern of Raw.pattern
| `Concrete_pascaligo_unsupported_string_singleton of Raw.type_expr
| `Concrete_pascaligo_unsupported_deep_some_pattern of Raw.pattern
| `Concrete_pascaligo_unsupported_deep_list_pattern of (Raw.pattern, Raw.wild) Parser_shared.Utils.nsepseq Raw.reg
| `Concrete_pascaligo_unknown_built_in of string
| `Concrete_pascaligo_michelson_type_wrong of Raw.type_expr * string
| `Concrete_pascaligo_michelson_type_wrong_arity of Location.t * string
| `Concrete_pascaligo_instruction_tracer of Raw.instruction * abs_error
| `Concrete_pascaligo_program_tracer of Raw.declaration list * abs_error
]
let unsupported_cst_constr p = `Concrete_pascaligo_unsupported_constant_constr p
let unknown_predefined_type name = `Concrete_pascaligo_unknown_predefined_type name
let unsupported_non_var_pattern p = `Concrete_pascaligo_unsupported_non_var_pattern p
let only_constructors p = `Concrete_pascaligo_only_constructors p
let unsupported_pattern_type pl = `Concrete_pascaligo_unsupported_pattern_type pl
let unsupported_tuple_pattern p = `Concrete_pascaligo_unsupported_tuple_pattern p
let unsupported_string_singleton te = `Concrete_pascaligo_unsupported_string_singleton te
let unsupported_deep_some_patterns p = `Concrete_pascaligo_unsupported_deep_some_pattern p
let unsupported_deep_list_patterns cons = `Concrete_pascaligo_unsupported_deep_list_pattern cons
let unknown_built_in name = `Concrete_pascaligo_unknown_built_in name
let michelson_type_wrong texpr name = `Concrete_pascaligo_michelson_type_wrong (texpr,name)
let michelson_type_wrong_arity loc name = `Concrete_pascaligo_michelson_type_wrong_arity (loc,name)
let abstracting_instruction_tracer i err = `Concrete_pascaligo_instruction_tracer (i,err)
let program_tracer decl err = `Concrete_pascaligo_program_tracer (decl,err)
let rec error_ppformat : display_format:string display_format ->
Format.formatter -> abs_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Concrete_pascaligo_unknown_predefined_type type_name ->
Format.fprintf f
"@[<hv>%a@Unknown predefined type \"%s\"@]"
Location.pp_lift type_name.Region.region
type_name.Region.value
| `Concrete_pascaligo_unsupported_pattern_type pl ->
Format.fprintf f
"@[<hv>%a@Currently, only booleans, lists, options, and constructors are supported in patterns@]"
Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl)
| `Concrete_pascaligo_unsupported_tuple_pattern p ->
Format.fprintf f
"@[<hv>%a@The following tuple pattern is not supported yet:@\"%s\"@]"
Location.pp_lift (Raw.pattern_to_region p)
(Parser_pascaligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p)
| `Concrete_pascaligo_unsupported_constant_constr p ->
Format.fprintf f
"@[<hv>%a@Constant constructors are not supported yet@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_pascaligo_unsupported_non_var_pattern p ->
Format.fprintf f
"@[<hv>%a@Non-variable patterns in constructors are not supported yet@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_pascaligo_unsupported_string_singleton te ->
Format.fprintf f
"@[<hv>%a@Unsupported singleton string type@]"
Location.pp_lift (Raw.type_expr_to_region te)
| `Concrete_pascaligo_unsupported_deep_some_pattern p ->
Format.fprintf f
"@[<hv>%a@Currently, only variables in Some constructors are supported@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_pascaligo_unsupported_deep_list_pattern cons ->
Format.fprintf f
"@[<hv>%a@Currently, only empty lists and x::y are supported in list patterns@]"
Location.pp_lift @@ cons.Region.region
| `Concrete_pascaligo_only_constructors p ->
Format.fprintf f
"@[<hv>%a@Currently, only constructors are supported in patterns@]"
Location.pp_lift (Raw.pattern_to_region p)
| `Concrete_pascaligo_unknown_built_in bi ->
Format.fprintf f "Unknown built-in function %s" bi
| `Concrete_pascaligo_michelson_type_wrong (texpr,name) ->
Format.fprintf f
"@[<hv>%a@Argument %s of %s must be a string singleton@]"
Location.pp_lift (Raw.type_expr_to_region texpr)
(Parser_pascaligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr)
name
| `Concrete_pascaligo_michelson_type_wrong_arity (loc,name) ->
Format.fprintf f
"@[<hv>%a@%s does not have the right number of argument@]"
Location.pp loc
name
| `Concrete_pascaligo_instruction_tracer (inst,err) ->
Format.fprintf f
"@[<hv>%a@Abstracting instruction:@\"%s\"@%a@]"
Location.pp_lift (Raw.instr_to_region inst)
(Parser_pascaligo.ParserLog.instruction_to_string ~offsets:true ~mode:`Point inst)
(error_ppformat ~display_format) err
| `Concrete_pascaligo_program_tracer (decl,err) ->
Format.fprintf f
"@[<hv>%a@Abstracting program@%a@]"
Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl)
(error_ppformat ~display_format) err
)
let rec error_jsonformat : abs_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Concrete_pascaligo_unknown_predefined_type type_name ->
let message = `String "Unknown predefined type" in
let t = `String type_name.Region.value in
let loc = Format.asprintf "%a" Location.pp_lift type_name.Region.region in
let content = `Assoc [
("message", message );
("location", `String loc);
("type", t ) ] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_pattern_type pl ->
let loc = Format.asprintf "%a"
Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl) in
let message = `String "Currently, only booleans, lists, options, and constructors are supported in patterns" in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_tuple_pattern p ->
let message = `String "The following tuple pattern is not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let pattern = Parser_pascaligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p in
let content = `Assoc [
("message", message );
("location", `String loc);
("pattern", `String pattern); ] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_constant_constr p ->
let message = `String "Constant constructors are not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_non_var_pattern p ->
let message = `String "Non-variable patterns in constructors are not supported yet" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_string_singleton te ->
let message = `String "Unsupported singleton string type" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region te) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_deep_some_pattern p ->
let message = `String "Currently, only variables in Some constructors are supported" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_unsupported_deep_list_pattern cons ->
let message = `String "Currently, only empty lists and x::y are supported in list patterns" in
let loc = Format.asprintf "%a" Location.pp_lift @@ cons.Region.region in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_only_constructors p ->
let message = `String "Currently, only constructors are supported in patterns" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
let content = `Assoc [
("message", message );
("location", `String loc);] in
json_error ~stage ~content
| `Concrete_pascaligo_unknown_built_in bi ->
let message = Format.asprintf "Unknown built-in function %s" bi in
let content = `Assoc [
("message", `String message ); ] in
json_error ~stage ~content
| `Concrete_pascaligo_michelson_type_wrong (texpr,name) ->
let message = Format.asprintf "Argument %s of %s must be a string singleton"
(Parser_pascaligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr) name in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region texpr) in
let content = `Assoc [
("message", `String message );
("location", `String loc); ] in
json_error ~stage ~content
| `Concrete_pascaligo_michelson_type_wrong_arity (loc,name) ->
let message = Format.asprintf "%s does not have the right number of argument" name in
let loc = Format.asprintf "%a" Location.pp loc in
let content = `Assoc [
("message", `String message );
("location", `String loc); ] in
json_error ~stage ~content
| `Concrete_pascaligo_instruction_tracer (inst,err) ->
let message = `String "Abstracting instruction" in
let loc = Format.asprintf "%a" Location.pp_lift (Raw.instr_to_region inst) in
let expr = Parser_pascaligo.ParserLog.instruction_to_string ~offsets:true ~mode:`Point inst in
let children = error_jsonformat err in
let content = `Assoc [
("message", message );
("location", `String loc);
("instruction", `String expr);
("children", children) ] in
json_error ~stage ~content
| `Concrete_pascaligo_program_tracer (decl,err) ->
let message = `String "Abstracting program" in
let loc = Format.asprintf "%a"
Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl) in
let children = error_jsonformat err in
let content = `Assoc [
("message", message );
("location", `String loc);
("children", children) ] in
json_error ~stage ~content

195
src/passes/02-concrete_to_imperative/pascaligo.ml
View File

@ -1,9 +1,10 @@
open Errors_pascaligo
open Trace
open Ast_imperative
module Raw = Parser.Pascaligo.AST
module SMap = Map.String
module ParserLog = Parser_pascaligo.ParserLog
(* module ParserLog = Parser_pascaligo.ParserLog *)
open Combinators
@ -14,114 +15,6 @@ let pseq_to_list = function
| Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
module Errors = struct
let unsupported_cst_constr p =
let title () = "" in
let message () =
Format.asprintf "\nConstant constructors are not supported yet.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let unknown_predefined_type name =
let title () = "\nType constants" in
let message () =
Format.asprintf "Unknown predefined type \"%s\".\n" name.Region.value in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)
] in
error ~data title message
let unsupported_non_var_pattern p =
let title () = "" in
let message () =
Format.asprintf "\nNon-variable patterns in constructors \
are not supported yet.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let only_constructors p =
let title () = "" in
let message () =
Format.asprintf "\nCurrently, only constructors \
are supported in patterns.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let unsupported_tuple_pattern p =
let title () = "" in
let message () =
Format.asprintf "\nTuple patterns are not supported yet.\n" in
let pattern_loc = Raw.pattern_to_region p in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ;
(** TODO: The labelled arguments should be flowing from the CLI. *)
("pattern",
fun () -> ParserLog.pattern_to_string
~offsets:true ~mode:`Point p)
] in
error ~data title message
let unsupported_deep_Some_patterns pattern =
let title () = "" in
let message () =
Format.asprintf "\nCurrently, only variables in constructors \
\"Some\" in patterns are supported.\n" in
let pattern_loc = Raw.pattern_to_region pattern in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
] in
error ~data title message
let unsupported_deep_list_patterns cons =
let title () = "" in
let message () =
Format.asprintf "\nCurrently, only empty lists and x::y \
are supported in patterns.\n" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ cons.Region.region)
] in
error ~data title message
(* Logging *)
let abstracting_instruction t =
let title () = "\nSimplifiying instruction" in
let message () = "" in
(** TODO: The labelled arguments should be flowing from the CLI. *)
let data = [
("instruction",
fun () -> ParserLog.instruction_to_string
~offsets:true ~mode:`Point t)
] in
error ~data title message
let unknown_built_in name =
let title () = "\n Unknown built-in function" in
let message () = "" in
let data = [
("built-in", fun () -> name);
] in
error ~data title message
end
open Errors
open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split
@ -156,7 +49,7 @@ let get_t_string_singleton_opt = function
| _ -> None
let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let rec compile_type_expression (t:Raw.type_expr) : (type_expression , (abs_error)) result =
match t with
TPar x -> compile_type_expression x.value.inside
| TVar v -> (
@ -181,31 +74,31 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
(match lst with
| [a ; b ; c ; d ] -> (
let%bind b' =
trace_option (simple_error "second argument of michelson_or must be a string singleton") @@
trace_option (michelson_type_wrong t name.value) @@
get_t_string_singleton_opt b in
let%bind d' =
trace_option (simple_error "fourth argument of michelson_or must be a string singleton") @@
trace_option (michelson_type_wrong t name.value) @@
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d'
)
| _ -> simple_fail "michelson_or does not have the right number of argument")
| _ -> fail @@ michelson_type_wrong_arity loc name.value)
| "michelson_pair" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
let%bind b' =
trace_option (simple_error "second argument of michelson_pair must be a string singleton") @@
trace_option (michelson_type_wrong t name.value) @@
get_t_string_singleton_opt b in
let%bind d' =
trace_option (simple_error "fourth argument of michelson_pair must be a string singleton") @@
trace_option (michelson_type_wrong t name.value) @@
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d'
)
| _ -> simple_fail "michelson_pair does not have the right number of argument")
| _ -> fail @@ michelson_type_wrong_arity loc name.value)
| _ ->
let lst = npseq_to_list tuple.value.inside in
let%bind lst =
@ -213,7 +106,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let%bind cst =
trace_option (unknown_predefined_type name) @@
type_operators name.value in
ok @@ t_operator ~loc cst lst)
ok @@ t_operator ~loc cst lst )
| TProd p ->
let%bind tpl = compile_list_type_expression
@@ npseq_to_list p.value in
@ -252,9 +145,9 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
@@ npseq_to_list s in
let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TString _s -> simple_fail "we don't support singleton string type"
| TString _s -> fail @@ unsupported_string_singleton t
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
and compile_list_type_expression (lst:Raw.type_expr list) : (type_expression , (abs_error)) result =
match lst with
| [] -> ok @@ t_unit ()
| [hd] -> compile_type_expression hd
@ -278,7 +171,7 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
ok @@ e_accessor ~loc var path'
let rec compile_expression (t:Raw.expr) : expr result =
let rec compile_expression (t:Raw.expr) : (expr , (abs_error)) result =
let return x = ok x in
match t with
| EAnnot a -> (
@ -423,7 +316,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
let (mi , loc) = r_split mi in
let%bind lst =
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, (abs_error)) result =
fun b ->
let%bind src = compile_expression b.source in
let%bind dst = compile_expression b.image in
@ -435,7 +328,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
let (mi , loc) = r_split mi in
let%bind lst =
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, (abs_error)) result =
fun b ->
let%bind src = compile_expression b.source in
let%bind dst = compile_expression b.image in
@ -481,7 +374,7 @@ and compile_update (u: Raw.update Region.reg) =
ok @@ e_update ~loc ur (Access_record var :: path) expr
in bind_fold_list aux record updates'
and compile_logic_expression (t:Raw.logic_expr) : expression result =
and compile_logic_expression (t:Raw.logic_expr) : (expression , (abs_error)) result =
match t with
| BoolExpr (False reg) ->
ok @@ e_bool ~loc:(Location.lift reg) false
@ -506,7 +399,7 @@ and compile_logic_expression (t:Raw.logic_expr) : expression result =
| CompExpr (Neq c) ->
compile_binop "NEQ" c
and compile_list_expression (t:Raw.list_expr) : expression result =
and compile_list_expression (t:Raw.list_expr) : (expression , (abs_error)) result =
let return x = ok x in
match t with
ECons c ->
@ -521,7 +414,7 @@ and compile_list_expression (t:Raw.list_expr) : expression result =
let loc = Location.lift reg in
return @@ e_list ~loc []
and compile_set_expression (t:Raw.set_expr) : expression result =
and compile_set_expression (t:Raw.set_expr) : (expression , (abs_error)) result =
match t with
| SetMem x -> (
let (x' , loc) = r_split x in
@ -536,7 +429,7 @@ and compile_set_expression (t:Raw.set_expr) : expression result =
ok @@ e_set ~loc elements'
)
and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : (expression , (abs_error)) result =
let return x = ok x in
let (t , loc) = r_split t in
let%bind a = compile_expression t.arg1 in
@ -544,14 +437,14 @@ and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result
let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ; b ]
and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : (expression , (abs_error)) result =
let return x = ok x in
let (t , loc) = r_split t in
let%bind a = compile_expression t.arg in
let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ]
and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
and compile_tuple_expression ?loc (lst:Raw.expr list) : (expression , (abs_error)) result =
let return x = ok x in
match lst with
| [] -> return @@ e_literal Literal_unit
@ -593,7 +486,7 @@ and compile_data_declaration : Raw.data_decl -> _ result =
in return_let_in ~loc binder inline expr
and compile_param :
Raw.param_decl -> (string * type_expression) result =
Raw.param_decl -> (string * type_expression, (abs_error)) result =
fun t ->
match t with
| ParamConst c ->
@ -609,7 +502,7 @@ and compile_param :
and compile_fun_decl :
loc:_ -> Raw.fun_decl ->
((expression_variable * type_expression option) * expression) result =
((expression_variable * type_expression option) * expression , (abs_error)) result =
fun ~loc x ->
let open! Raw in
let {kwd_recursive;fun_name; param; ret_type; block_with;
@ -686,7 +579,7 @@ and compile_fun_decl :
)
and compile_fun_expression :
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
loc:_ -> Raw.fun_expr -> (type_expression option * expression , (abs_error)) result =
fun ~loc x ->
let open! Raw in
let {param; ret_type; return; _} : fun_expr = x in
@ -768,7 +661,7 @@ and compile_statement_list statements =
hook (compile_data_declaration d :: acc) statements
in bind_list @@ hook [] (List.rev statements)
and compile_single_instruction : Raw.instruction -> (_ -> expression result) result =
and compile_single_instruction : Raw.instruction -> ((_ -> (expression , (abs_error)) result), (abs_error)) result =
fun t ->
match t with
| ProcCall x -> (
@ -996,7 +889,7 @@ and compile_selection : Raw.selection -> access = function
FieldName property -> Access_record property.value
| Component index -> Access_tuple (snd index.value)
and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
and compile_cases : (Raw.pattern * expression) list -> (matching_expr , (abs_error)) result = fun t ->
let open Raw in
let get_var (t:Raw.pattern) =
match t with
@ -1009,8 +902,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
let get_single (t: Raw.pattern) =
let t' = get_tuple t in
let%bind () =
trace_strong (unsupported_tuple_pattern t) @@
Assert.assert_list_size t' 1 in
Assert.assert_list_size (unsupported_tuple_pattern t) t' 1 in
ok (List.hd t') in
let get_toplevel (t : Raw.pattern) =
match t with
@ -1052,7 +944,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
let (_, v) = v.value in
let%bind v = match v.value.inside with
| PVar v -> ok v.value
| p -> fail @@ unsupported_deep_Some_patterns p in
| p -> fail @@ unsupported_deep_some_patterns p in
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some) }
)
| [(PList PCons c, cons) ; (PList (PNil _), nil)]
@ -1068,33 +960,23 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
in
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil}
| lst ->
trace (simple_info "currently, only booleans, options, lists and \
user-defined constructors are supported in patterns") @@
let%bind constrs =
trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let aux (x , y) =
let error =
let title () = "Pattern" in
(* TODO: The labelled arguments should be flowing from the CLI. *)
let content () =
Printf.sprintf "Pattern : %s"
(ParserLog.pattern_to_string
~offsets:true ~mode:`Point x) in
error title content in
let%bind x' =
trace error @@
get_constr x in
ok (x' , y) in
bind_map_list aux lst in
ok @@ ez_match_variant constrs
and compile_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> trace (abstracting_instruction t) @@ compile_single_instruction t
and compile_instruction : Raw.instruction -> ((_ -> (expression, (abs_error)) result) , (abs_error)) result =
fun t -> trace (abstracting_instruction_tracer t) @@ compile_single_instruction t
and compile_statements : Raw.statements -> (_ -> expression result) result =
and compile_statements : Raw.statements -> ((_ -> (expression,(abs_error)) result) , (abs_error)) result =
fun statements ->
let lst = npseq_to_list statements in
let%bind fs = compile_statement_list lst in
let aux : _ -> (expression option -> expression result) -> _ =
let aux : _ -> (expression option -> (expression, (abs_error)) result) -> _ =
fun prec cur ->
let%bind res = cur prec
in ok @@ Some res in
@ -1102,11 +984,11 @@ and compile_statements : Raw.statements -> (_ -> expression result) result =
let%bind ret = bind_fold_right_list aux expr' fs in
ok @@ Option.unopt_exn ret
and compile_block : Raw.block -> (_ -> expression result) result =
and compile_block : Raw.block -> ((_ -> (expression , (abs_error)) result) , (abs_error)) result =
fun t -> compile_statements t.statements
and compile_declaration_list declarations : declaration Location.wrap list result =
and compile_declaration_list declarations : (declaration Location.wrap list, (abs_error)) result =
let open Raw in
let rec hook acc = function
[] -> acc
@ -1169,5 +1051,8 @@ and compile_declaration_list declarations : declaration Location.wrap list resul
hook (bind_list_cons res acc) declarations
in hook (ok @@ []) (List.rev declarations)
let compile_program : Raw.ast -> program result =
fun t -> compile_declaration_list @@ nseq_to_list t.decl
let compile_program : Raw.ast -> (program , (abs_error)) result =
fun t ->
let declarations = nseq_to_list t.decl in
trace (program_tracer declarations) @@
compile_declaration_list declarations

4
src/passes/02-concrete_to_imperative/pascaligo.mli
View File

@ -8,8 +8,8 @@ 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
val compile_expression : Raw.expr -> (expr , Errors_pascaligo.abs_error) result
(** Convert a concrete PascaLIGO program AST to the miperative program
AST used by the compiler. *)
val compile_program : Raw.ast -> program result
val compile_program : Raw.ast -> (program, Errors_pascaligo.abs_error) result

13
src/passes/03-self_ast_imperative/entrypoints_length_limit.ml
View File

@ -1,23 +1,16 @@
open Errors
open Ast_imperative
open Trace
open Stage_common.Helpers
module Errors = struct
let bad_string_timestamp name () =
let title = thunk @@ Format.asprintf ("Too long constructor '%s'") name in
let message () = "names length is limited to 32 (tezos limitation)" in
error title message ()
end
open Errors
let peephole_type_expression : type_expression -> type_expression result = fun e ->
let peephole_type_expression : type_expression -> (type_expression , self_ast_imperative_error) result = fun e ->
let return type_content = ok {type_content; location=e.location } in
match e.type_content with
| T_sum cmap ->
let%bind _uu = bind_map_cmapi
(fun k _ ->
let (Constructor name) = k in
if (String.length name >= 32) then fail @@ bad_string_timestamp name
if (String.length name >= 32) then fail @@ too_long_constructor name e
else ok ()
)
cmap in

151
src/passes/03-self_ast_imperative/errors.ml Normal file
View File

@ -0,0 +1,151 @@
open Simple_utils.Display
open Ast_imperative
open Trace
let stage = "self_ast_imperative"
type self_ast_imperative_error = [
| `Self_ast_imperative_long_constructor of (string * type_expression)
| `Self_ast_imperative_bad_timestamp of (string * expression)
| `Self_ast_imperative_bad_format_literal of (expression * Proto_alpha_utils.Trace.tezos_alpha_error list)
| `Self_ast_imperative_bad_empty_arity of (constant' * expression)
| `Self_ast_imperative_bad_single_arity of (constant' * expression)
| `Self_ast_imperative_bad_map_param_type of (constant' * expression)
| `Self_ast_imperative_bad_set_param_type of (constant' * expression)
| `Self_ast_imperative_bad_convertion_bytes of expression
]
let too_long_constructor c e = `Self_ast_imperative_long_constructor (c,e)
let bad_timestamp t e = `Self_ast_imperative_bad_timestamp (t,e)
let bad_format e errs = `Self_ast_imperative_bad_format_literal (e,errs)
let bad_empty_arity c e = `Self_ast_imperative_bad_empty_arity (c,e)
let bad_single_arity c e = `Self_ast_imperative_bad_single_arity (c,e)
let bad_map_param_type c e = `Self_ast_imperative_bad_map_param_type (c,e)
let bad_set_param_type c e = `Self_ast_imperative_bad_set_param_type (c,e)
let bad_conversion_bytes e = `Self_ast_imperative_bad_convertion_bytes e
let error_ppformat : display_format:string display_format ->
Format.formatter -> self_ast_imperative_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Self_ast_imperative_long_constructor (c,e) ->
Format.fprintf f
"@[<hv>%a@ Too long constructor '%s'@ names length are limited to 32 (tezos limitation)@]"
Location.pp e.location
c
| `Self_ast_imperative_bad_timestamp (t,e) ->
Format.fprintf f
"@[<hv>%a@ Badly formatted timestamp '%s'@]"
Location.pp e.location
t
| `Self_ast_imperative_bad_format_literal (e,_errs) ->
Format.fprintf f
"@[<hv>%a@ Badly formatted literal: %a@]"
Location.pp e.location
Ast_imperative.PP.expression e
| `Self_ast_imperative_bad_empty_arity (c, e) ->
Format.fprintf f
"@[<hv>%a@ Wrong arity:@%a expects no parameter@]"
Location.pp e.location PP.constant c
| `Self_ast_imperative_bad_single_arity (c, e) ->
Format.fprintf f
"@[<hv>%a@ Wrong arity:@%a expects one parameter@]"
Location.pp e.location PP.constant c
| `Self_ast_imperative_bad_map_param_type (c,e) ->
Format.fprintf f
"@[<hv>%a@ Wrong arity:@%a expects a list of pair parameter@]"
Location.pp e.location PP.constant c
| `Self_ast_imperative_bad_set_param_type (c,e) ->
Format.fprintf f
"@[<hv>%a@ Wrong arity:@%a expects a list of pair parameter@]"
Location.pp e.location PP.constant c
| `Self_ast_imperative_bad_convertion_bytes e ->
Format.fprintf f
"@[<hv>%a@ Bad bytes literal (conversion went wrong)@]"
Location.pp e.location
)
let error_jsonformat : self_ast_imperative_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Self_ast_imperative_long_constructor (c,e) ->
let message = `String "too long constructor (limited to 32)" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let content = `Assoc [
("message", message);
("location", loc);
("value", `String c)
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_timestamp (t,e) ->
let message = `String "badly formatted timestamp" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let content = `Assoc [
("message", message);
("location", loc);
("value", `String t)
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_format_literal (e,_errs) ->
let message = `String "badly formatted literal" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let content = `Assoc [
("message", message);
("location", loc);
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_empty_arity (c, e) ->
let message = `String "constant expects no parameters" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let value = `String (Format.asprintf "%a" PP.constant c) in
let content = `Assoc [
("message", message);
("location", loc);
("value", value);
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_single_arity (c, e) ->
let message = `String "constant expects one parameters" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let value = `String (Format.asprintf "%a" PP.constant c) in
let content = `Assoc [
("message", message);
("location", loc);
("value", value);
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_map_param_type (c,e) ->
let message = `String "constant expects a list of pair as parameter" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let value = `String (Format.asprintf "%a" PP.constant c) in
let content = `Assoc [
("message", message);
("location", loc);
("value", value);
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_set_param_type (c,e) ->
let message = `String "constant expects a list as parameter" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let value = `String (Format.asprintf "%a" PP.constant c) in
let content = `Assoc [
("message", message);
("location", loc);
("value", value);
] in
json_error ~stage ~content
| `Self_ast_imperative_bad_convertion_bytes e ->
let message = `String "Bad bytes literal (conversion went wrong)" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let content = `Assoc [
("message", message);
("location", loc);
] in
json_error ~stage ~content

30
src/passes/03-self_ast_imperative/helpers.ml
View File

@ -16,8 +16,8 @@ let bind_map_lmap_t f map = bind_lmap (
ok {field with field_type })
map)
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
type ('a,'err) folder = 'a -> expression -> ('a, 'err) result
let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a, 'err) result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
@ -112,7 +112,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self res body in
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
and fold_cases : ('a , 'b) folder -> 'a -> matching_expr -> ('a , 'b) result = fun f init m ->
match m with
| Match_variant lst -> (
let aux init' ((_ , _) , e) =
@ -144,12 +144,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
ok res
)
type exp_mapper = expression -> expression result
type ty_exp_mapper = type_expression -> type_expression result
type abs_mapper =
| Expression of exp_mapper
| Type_expression of ty_exp_mapper
let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
type 'err exp_mapper = expression -> (expression , 'err) result
type 'err ty_exp_mapper = type_expression -> (type_expression, 'err) result
type 'err abs_mapper =
| Expression of 'err exp_mapper
| Type_expression of 'err ty_exp_mapper
let rec map_expression : 'err exp_mapper -> expression -> (expression, 'err) result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
@ -263,7 +263,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
| E_literal _ | E_variable _ | E_raw_code _ | 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 : 'err ty_exp_mapper -> type_expression -> (type_expression , _) result = fun f te ->
let self = map_type_expression f in
let%bind te' = f te in
let return type_content = ok { type_content; location=te.location } in
@ -287,7 +287,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
| T_operator _
| T_variable _ | T_constant _ -> ok te'
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
and map_cases : 'err exp_mapper -> matching_expr -> (matching_expr , _) result = fun f m ->
match m with
| Match_variant lst -> (
let aux ((a , b) , e) =
@ -320,7 +320,7 @@ and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
ok @@ Match_variable (name, ty_opt, e')
)
and map_program : abs_mapper -> program -> program result = fun m p ->
and map_program : 'err abs_mapper -> program -> (program , _) result = fun m p ->
let aux = fun (x : declaration) ->
match x,m with
| (Declaration_constant (t , o , i, e), Expression m') -> (
@ -336,8 +336,8 @@ and map_program : abs_mapper -> program -> program result = fun m p ->
in
bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
type ('a, 'err) fold_mapper = 'a -> expression -> ((bool * 'a * expression), 'err) result
let rec fold_map_expression : ('a, 'err) fold_mapper -> 'a -> expression -> ('a * expression , 'err) result = fun f a e ->
let self = fold_map_expression f in
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
@ -452,7 +452,7 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
ok (res, return @@ E_while {condition; body})
| E_literal _ | E_variable _ | E_raw_code _ | 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 , 'err) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr , 'err) result = fun f init m ->
match m with
| Match_variant lst -> (
let aux init ((a , b) , e) =

93
src/passes/03-self_ast_imperative/literals.ml
View File

@ -1,57 +1,9 @@
open Errors
open Ast_imperative
open Trace
open Proto_alpha_utils
module Errors = struct
let bad_format e () =
let title = (thunk ("Badly formatted literal")) in
let message () = Format.asprintf "%a" PP.expression e in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
] in
error ~data title message ()
let bad_empty_arity cst loc () =
let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
let title = thunk @@ "Wrong "^(cst_name ())^" literal arity" in
let message = thunk @@ (cst_name ())^" literal expects no parameter" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let bad_single_arity cst loc () =
let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
let title = thunk @@ "Wrong "^(cst_name ())^" literal arity" in
let message = thunk @@ (cst_name ())^" literal expects a single parameter" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let bad_map_param_type cst loc () =
let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
let title = thunk @@ "Wrong "^(cst_name ())^" literal parameter type" in
let message = thunk @@ (cst_name ())^" literal expects a list of pairs as parameter" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let bad_set_param_type cst loc () =
let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
let title = thunk @@ "Wrong "^(cst_name ())^" literal parameter type" in
let message = thunk @@ (cst_name ())^" literal expects a list as parameter" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
end
open Errors
let peephole_expression : expression -> expression result = fun e ->
let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_literal (Literal_key_hash s) as l -> (
@ -84,76 +36,65 @@ let peephole_expression : expression -> expression result = fun e ->
)
| E_constant {cons_name=C_BIG_MAP_LITERAL as cst; arguments=lst} -> (
let%bind elt =
trace_option (bad_single_arity cst e.location) @@
trace_option (bad_single_arity cst e) @@
List.to_singleton lst
in
let%bind lst =
trace_strong (bad_map_param_type cst e.location) @@
trace_option (bad_map_param_type cst e) @@
get_e_list elt.expression_content
in
let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@
let%bind tpl = get_e_tuple e.expression_content in
let%bind (a , b) =
trace_option (simple_error "of pairs") @@
List.to_pair tpl
in
ok (a , b)
trace_option (bad_map_param_type cst e) @@
Option.(get_e_tuple e.expression_content >>= fun t ->
List.to_pair t)
in
let%bind pairs = bind_map_list aux lst in
return @@ E_big_map pairs
)
| E_constant {cons_name=C_MAP_LITERAL as cst; arguments=lst} -> (
let%bind elt =
trace_option (bad_single_arity cst e.location) @@
trace_option (bad_single_arity cst e) @@
List.to_singleton lst
in
let%bind lst =
trace_strong (bad_map_param_type cst e.location) @@
trace_option (bad_map_param_type cst e) @@
get_e_list elt.expression_content
in
let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@
let%bind tpl = get_e_tuple e.expression_content in
let%bind (a , b) =
trace_option (simple_error "of pairs") @@
List.to_pair tpl
in
ok (a , b)
trace_option (bad_map_param_type cst e) @@
Option.(get_e_tuple e.expression_content >>= fun t ->
List.to_pair t)
in
let%bind pairs = bind_map_list aux lst in
return @@ E_map pairs
)
| E_constant {cons_name=C_BIG_MAP_EMPTY as cst; arguments=lst} -> (
let%bind () =
trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst
Assert.assert_list_empty (bad_empty_arity cst e) lst
in
return @@ E_big_map []
)
| E_constant {cons_name=C_MAP_EMPTY as cst; arguments=lst} -> (
let%bind () =
trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst
Assert.assert_list_empty (bad_empty_arity cst e) lst
in
return @@ E_map []
)
| E_constant {cons_name=C_SET_LITERAL as cst; arguments=lst} -> (
let%bind elt =
trace_option (bad_single_arity cst e.location) @@
trace_option (bad_single_arity cst e) @@
List.to_singleton lst
in
let%bind lst =
trace_strong (bad_set_param_type cst e.location) @@
trace_option (bad_set_param_type cst e) @@
get_e_list elt.expression_content
in
return @@ E_set lst
)
| E_constant {cons_name=C_SET_EMPTY as cst; arguments=lst} -> (
let%bind () =
trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst
Assert.assert_list_empty (bad_empty_arity cst e) lst
in
return @@ E_set []
)

3
src/passes/03-self_ast_imperative/none_variant.ml
View File

@ -1,7 +1,8 @@
open Errors
open Ast_imperative
open Trace
let peephole_expression : expression -> expression result = fun e ->
let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]}

1
src/passes/03-self_ast_imperative/self_ast_imperative.ml
View File

@ -1,4 +1,5 @@
open Trace
module Errors = Errors
let all_expression_mapper = [
Tezos_type_annotation.peephole_expression ;

28
src/passes/03-self_ast_imperative/tezos_type_annotation.ml
View File

@ -1,21 +1,11 @@
open Errors
open Ast_imperative
open Trace
module Errors = struct
let bad_string_timestamp ts loc () =
let title = (thunk ("Badly formatted timestamp \""^ts^"\"")) in
let message () = "" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
end
open Errors
let peephole_expression : expression -> expression result = fun e ->
let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_ascription {anno_expr=e'; type_annotation=t} as e -> (
| E_ascription {anno_expr=e'; type_annotation=t} as ec -> (
match (e'.expression_content , t.type_content) with
| (E_literal (Literal_string s) , T_constant (TC_key_hash)) -> return @@ E_literal (Literal_key_hash (Ligo_string.extract s))
| (E_literal (Literal_string s) , T_constant (TC_signature)) -> return @@ E_literal (Literal_signature (Ligo_string.extract s))
@ -24,16 +14,16 @@ let peephole_expression : expression -> expression result = fun e ->
| (E_literal (Literal_string str) , T_constant (TC_timestamp)) ->
let str = Ligo_string.extract str in
let%bind time =
trace_option (bad_string_timestamp str e'.location)
trace_option (bad_timestamp str e')
@@ Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation str in
let itime = Z.of_int64 @@ Tezos_utils.Time.Protocol.to_seconds time in
return @@ E_literal (Literal_timestamp itime)
| (E_literal (Literal_string str) , T_constant (TC_address)) -> return @@ E_literal (Literal_address (Ligo_string.extract str))
| (E_literal (Literal_string str) , T_constant (TC_bytes)) -> (
let str = Ligo_string.extract str in
let%bind e' = e'_bytes str in
return e'
)
| _ -> return e
let str = Ligo_string.extract str in
let%bind e' = trace_option (bad_conversion_bytes e) @@ e'_bytes str in
return e'
)
| _ -> return ec
)
| e -> return e

38
src/passes/04-imperative_to_sugar/errors.ml Normal file
View File

@ -0,0 +1,38 @@
open Trace
open Simple_utils.Display
let stage = "imperative_to_sugar"
type imperative_to_sugar_error = [
| `Imperative_to_sugar_corner_case of string
]
let corner_case s = `Imperative_to_sugar_corner_case s
let error_ppformat : display_format:string display_format ->
Format.formatter -> imperative_to_sugar_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Imperative_to_sugar_corner_case s ->
Format.fprintf f
"@[<hv>Corner case: %s@]"
s
)
let error_jsonformat : imperative_to_sugar_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Imperative_to_sugar_corner_case s ->
let message = `String "corner case" in
let content = `Assoc [
("message", message);
("value", `String s)
] in
json_error ~stage ~content

53
src/passes/04-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -1,27 +1,8 @@
module Errors = Errors
module I = Ast_imperative
module O = Ast_sugar
open Trace
module Errors = struct
let corner_case loc =
let title () = "corner case" in
let message () = Format.asprintf "corner case, please report to developers\n" in
let data = [
("location",
fun () -> Format.asprintf "%s" loc)
] in
error ~data title message
let bad_collection expr =
let title () = "" in
let message () = Format.asprintf "\nCannot loop over this collection : %a\n" I.PP.expression expr in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp expr.location)
] in
error ~data title message
end
let rec add_to_end (expression: O.expression) to_add =
match expression.expression_content with
| O.E_let_in lt ->
@ -127,7 +108,7 @@ and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.
| Some e -> expr (ef e)
let rec compile_type_expression : I.type_expression -> O.type_expression result =
let rec compile_type_expression : I.type_expression -> (O.type_expression,Errors.imperative_to_sugar_error) result =
fun te ->
let return tc = ok @@ O.make_t ~loc:te.location tc in
match te.type_content with
@ -161,8 +142,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator (TC_michelson_or, [l;r]) ->
let%bind (l, l_ann) = I.get_t_annoted l in
let%bind (r, r_ann) = I.get_t_annoted r in
let%bind (l, l_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted l in
let%bind (r, r_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted r in
let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.constructor' * O.ctor_content) list = [
(O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann ; ctor_decl_pos = 0});
@ -170,8 +151,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
in
return @@ O.T_sum (O.CMap.of_list sum)
| I.T_operator (TC_michelson_pair, [l;r]) ->
let%bind (l, l_ann) = I.get_t_annoted l in
let%bind (r, r_ann) = I.get_t_annoted r in
let%bind (l, l_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted l in
let%bind (r, r_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted r in
let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.label * O.field_content) list = [
(O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann ; field_decl_pos = 0});
@ -183,12 +164,12 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
return @@ T_operator (type_operator, lst)
| I.T_annoted (ty, _) -> compile_type_expression ty
let rec compile_expression : I.expression -> O.expression result =
let rec compile_expression : I.expression -> (O.expression , _) result =
fun e ->
let%bind e = compile_expression' e in
ok @@ e None
and compile_expression' : I.expression -> (O.expression option -> O.expression) result =
and compile_expression' : I.expression -> (O.expression option -> O.expression, Errors.imperative_to_sugar_error) result =
fun e ->
let return expr = ok @@ function
| None -> expr
@ -317,7 +298,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
let%bind w = compile_while w in
ok @@ w
and compile_path : I.access list -> O.access list result =
and compile_path : I.access list -> (O.access list, Errors.imperative_to_sugar_error) result =
fun path ->
let aux a = match a with
| I.Access_record s -> ok @@ O.Access_record s
@ -328,14 +309,14 @@ and compile_path : I.access list -> O.access list result =
in
bind_map_list aux path
and compile_lambda : I.lambda -> O.lambda result =
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 -> Location.t -> (O.expression option -> O.expression) result =
and compile_matching : I.matching -> Location.t -> (O.expression option -> O.expression, Errors.imperative_to_sugar_error) result =
fun {matchee;cases} loc ->
let return expr = ok @@ function
| None -> expr
@ -547,12 +528,12 @@ let compile_declaration : I.declaration Location.wrap -> _ =
let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te)
let compile_program : I.program -> O.program result =
let compile_program : I.program -> (O.program , Errors.imperative_to_sugar_error) result =
fun p ->
bind_map_list compile_declaration p
(* uncompiling *)
let rec uncompile_type_expression : O.type_expression -> I.type_expression result =
let rec uncompile_type_expression : O.type_expression -> (I.type_expression , Errors.imperative_to_sugar_error) result =
fun te ->
let return te = ok @@ I.make_t te in
match te.type_content with
@ -590,7 +571,7 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec uncompile_expression : O.expression -> I.expression result =
let rec uncompile_expression : O.expression -> (I.expression , Errors.imperative_to_sugar_error) result =
fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with
@ -680,7 +661,7 @@ let rec uncompile_expression : O.expression -> I.expression result =
return @@ I.E_sequence {expr1; expr2}
| O.E_skip -> return @@ I.E_skip
and uncompile_path : O.access list -> I.access list result =
and uncompile_path : O.access list -> (I.access list, Errors.imperative_to_sugar_error) result =
fun path -> let aux a = match a with
| O.Access_record s -> ok @@ I.Access_record s
| O.Access_tuple i -> ok @@ I.Access_tuple i
@ -690,13 +671,13 @@ and uncompile_path : O.access list -> I.access list result =
in
bind_map_list aux path
and uncompile_lambda : O.lambda -> I.lambda result =
and uncompile_lambda : O.lambda -> (I.lambda , Errors.imperative_to_sugar_error) 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 =
and uncompile_matching : O.matching_expr -> (I.matching_expr , Errors.imperative_to_sugar_error) result =
fun m ->
match m with
| O.Match_list {match_nil;match_cons} ->

30
src/passes/05-self_ast_sugar/helpers.ml
View File

@ -16,8 +16,8 @@ let bind_map_lmap_t f map = bind_lmap (
ok {field with field_type = field'})
map)
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
type ('a , 'err) folder = 'a -> expression -> ('a , 'err) result
let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a, 'err) result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
@ -98,7 +98,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
and fold_cases : ('a, 'err) folder -> 'a -> matching_expr -> ('a, 'err) result = fun f init m ->
match m with
| Match_variant lst -> (
let aux init' ((_ , _) , e) =
@ -130,12 +130,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
ok res
)
type exp_mapper = expression -> expression result
type ty_exp_mapper = type_expression -> type_expression result
type abs_mapper =
| Expression of exp_mapper
| Type_expression of ty_exp_mapper
let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
type 'err exp_mapper = expression -> (expression, 'err) result
type 'err ty_exp_mapper = type_expression -> (type_expression, 'err) result
type 'err abs_mapper =
| Expression of 'err exp_mapper
| Type_expression of 'err ty_exp_mapper
let rec map_expression : 'err exp_mapper -> expression -> (expression, 'err) result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
@ -233,7 +233,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
)
| E_literal _ | E_variable _ | E_raw_code _ | 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 : 'err ty_exp_mapper -> type_expression -> (type_expression, 'err) result = fun f te ->
let self = map_type_expression f in
let%bind te' = f te in
let return type_content = ok { type_content; location=te.location } in
@ -254,7 +254,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
| T_operator _
| T_variable _ | T_constant _ -> ok te'
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
and map_cases : 'err exp_mapper -> matching_expr -> (matching_expr, 'err) result = fun f m ->
match m with
| Match_variant lst -> (
let aux ((a , b) , e) =
@ -287,7 +287,7 @@ and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
ok @@ Match_variable (name, ty_opt, e')
)
and map_program : abs_mapper -> program -> program result = fun m p ->
and map_program : 'err abs_mapper -> program -> (program, 'err) result = fun m p ->
let aux = fun (x : declaration) ->
match x,m with
| (Declaration_constant (t , o , i, e), Expression m') -> (
@ -303,8 +303,8 @@ and map_program : abs_mapper -> program -> program result = fun m p ->
in
bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
type ('a, 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression, 'err) result
let rec fold_map_expression : ('a, 'err) fold_mapper -> 'a -> expression -> ('a * expression, 'err) result = fun f a e ->
let self = fold_map_expression f in
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
@ -405,7 +405,7 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
)
| E_literal _ | E_variable _ | E_raw_code _ | 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,'err) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr, 'err) result = fun f init m ->
match m with
| Match_variant lst -> (
let aux init ((a , b) , e) =

23
src/passes/06-sugar_to_core/sugar_to_core.ml
View File

@ -2,7 +2,12 @@ module I = Ast_sugar
module O = Ast_core
open Trace
let rec compile_type_expression : I.type_expression -> O.type_expression result =
module Errors = struct
type sugar_to_core_error = []
end
open Errors
let rec compile_type_expression : I.type_expression -> (O.type_expression , sugar_to_core_error) result =
fun te ->
let return tc = ok @@ O.make_t ~loc:te.location tc in
match te.type_content with
@ -45,7 +50,7 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
let%bind lst = bind_map_list compile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec compile_expression : I.expression -> O.expression result =
let rec compile_expression : I.expression -> (O.expression , sugar_to_core_error) result =
fun e ->
let return expr = ok @@ O.make_e ~loc:e.location expr in
match e.expression_content with
@ -183,13 +188,13 @@ let rec compile_expression : I.expression -> O.expression result =
let m = O.LMap.of_list lst in
return @@ O.E_record m
and compile_lambda : I.lambda -> O.lambda result =
and compile_lambda : I.lambda -> (O.lambda , sugar_to_core_error) 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 : Location.t -> O.expression -> I.matching_expr -> O.expression result =
and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expression, sugar_to_core_error) result =
fun loc e m ->
match m with
| I.Match_list {match_nil;match_cons} ->
@ -260,12 +265,12 @@ let compile_declaration : I.declaration Location.wrap -> _ =
let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te)
let compile_program : I.program -> O.program result =
let compile_program : I.program -> (O.program , sugar_to_core_error) result =
fun p ->
bind_map_list compile_declaration p
(* uncompiling *)
let rec uncompile_type_expression : O.type_expression -> I.type_expression result =
let rec uncompile_type_expression : O.type_expression -> (I.type_expression , sugar_to_core_error) result =
fun te ->
let return te = ok @@ I.make_t te in
match te.type_content with
@ -301,7 +306,7 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec uncompile_expression : O.expression -> I.expression result =
let rec uncompile_expression : O.expression -> (I.expression , sugar_to_core_error) result =
fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with
@ -364,13 +369,13 @@ let rec uncompile_expression : O.expression -> I.expression result =
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 =
and uncompile_lambda : O.lambda -> (I.lambda , sugar_to_core_error) 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 =
and uncompile_matching : O.matching_expr -> (I.matching_expr , sugar_to_core_error) result =
fun m ->
match m with
| O.Match_list {match_nil;match_cons} ->

32
src/passes/07-self_ast_core/helpers.ml
View File

@ -19,8 +19,8 @@ let bind_map_lmap_t f map = bind_lmap (
ok {field with field_type = field'})
map)
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
type ('a,'err) folder = 'a -> expression -> ('a, 'err) result
let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a,'err) result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
@ -70,7 +70,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self init' e in
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
and fold_cases : ('a , 'err) folder -> 'a -> matching_expr -> ('a , 'err) result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
let%bind res = fold_expression f init match_nil in
@ -90,12 +90,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
ok res
)
type exp_mapper = expression -> expression result
type ty_exp_mapper = type_expression -> type_expression result
type abs_mapper =
| Expression of exp_mapper
| Type_expression of ty_exp_mapper
let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
type 'err exp_mapper = expression -> (expression , 'err) result
type 'err ty_exp_mapper = type_expression -> (type_expression , 'err) result
type 'err abs_mapper =
| Expression of 'err exp_mapper
| Type_expression of 'err ty_exp_mapper
let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
@ -150,7 +150,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
)
| E_literal _ | E_variable _ | E_raw_code _ as e' -> return e'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f ({type_content ; location ; type_meta} as te) ->
and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression , 'err) result =
fun f ({type_content ; location ; type_meta} as te) ->
let self = map_type_expression f in
let%bind te' = f te in
let return type_content = ok { type_content; location ; type_meta } in
@ -168,7 +169,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
| T_operator _
| T_variable _ | T_constant _ -> ok te'
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
and map_cases : 'err exp_mapper -> matching_expr -> (matching_expr , 'err) result = fun f m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind match_nil = map_expression f match_nil in
@ -189,7 +190,7 @@ and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
ok @@ Match_variant lst'
)
and map_program : abs_mapper -> program -> program result = fun m p ->
and map_program : 'err abs_mapper -> program -> (program , 'err) result = fun m p ->
let aux = fun (x : declaration) ->
match x,m with
| (Declaration_constant (t , o , i, e), Expression m') -> (
@ -205,8 +206,8 @@ and map_program : abs_mapper -> program -> program result = fun m p ->
in
bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
type ('a , 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression , 'err) result
let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a * expression , 'err) result = fun f a e ->
let self = fold_map_expression f in
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
@ -264,7 +265,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
)
| E_literal _ | E_variable _ | E_raw_code _ 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 , 'err) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr , 'err) result =
fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in

753
src/passes/08-typer-common/constant_typers.ml Normal file
View File

@ -0,0 +1,753 @@
open Trace
open Helpers
open Errors
open Ast_typed
(*
Each constant has its own type.
LIGO's type-system is currently too
weak to express the constant's type. For instance:
- "ADD" has a special kind of type of polymorphism. If "ADD" gets two `int`s,
it will return an `int`. If it gets two `nat`s, it will return a `nat`.
Regular polymorphism wouldn't work because "ADD" only accepts `int`s or
`nat`s.
- "NONE" (from Some/None) requires an annotation.
Instead of a LIGO type, constant types are representend as functions. These
functions take as parameters:
- The list of types of the arguments of the constants. When typing `2 + 2`,
the types might be `[ int ; int ]`.
- The expected type of the whole expression. It is optional. When typing
`[] : list(operation)`, it will be `Some ( list (operation) )`. When
typing `2 + 2` (with no additional context), it will be `None`.
The output is the type of the whole expression. An error is returned through
the Trace monad if it doesn't type-check (`"toto" + 42`).
Various helpers are defined bellow.
*)
let none = typer_0 "NONE" @@ fun tv_opt ->
match tv_opt with
| None -> fail not_annotated
| Some t -> ok t
let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> fail not_annotated
| Some t -> ok t
let sub = typer_2 "SUB" @@ fun a b ->
if (eq_1 a (t_int ()) || eq_1 a (t_nat ()))
&& (eq_1 b (t_int ()) || eq_1 b (t_nat ()))
then ok @@ t_int () else
if (eq_2 (a , b) (t_timestamp ()))
then ok @@ t_int () else
if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ()))
then ok @@ t_timestamp () else
if (eq_2 (a , b) (t_mutez ()))
then ok @@ t_mutez () else
fail bad_substraction
let some = typer_1 "SOME" @@ fun a -> ok @@ t_option a ()
let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m ->
let%bind (src , _) = bind_map_or (
(fun m -> trace_option (expected_map m) @@ get_t_map m) ,
(fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
) m in
let%bind () = assert_eq src k in
ok m
let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> fail not_annotated
| Some t ->
let%bind (src, dst) = trace_option (expected_map t) @@ get_t_map t in
ok @@ t_map src dst ()
let big_map_empty = typer_0 "BIG_MAP_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> fail not_annotated
| Some t ->
let%bind (src, dst) = trace_option (expected_big_map t) @@ get_t_big_map t in
ok @@ t_big_map src dst ()
let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
let%bind (src , dst) = bind_map_or (
(fun m -> trace_option (expected_map m) @@ get_t_map m) ,
(fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
) m in
let%bind () = assert_eq src k in
let%bind () = assert_eq dst v in
ok m
let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m ->
let%bind (src , dst) = bind_map_or (
(fun m -> trace_option (expected_map m) @@ get_t_map m) ,
(fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
) m in
let%bind () = assert_eq src k in
let%bind v' = trace_option (expected_option v) @@ get_t_option v in
let%bind () = assert_eq dst v' in
ok m
let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m ->
let%bind (src , _dst) = bind_map_or (
(fun m -> trace_option (expected_map m) @@ get_t_map m) ,
(fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
) m in
let%bind () = assert_eq src k in
ok @@ t_bool ()
let map_find : typer = typer_2 "MAP_FIND" @@ fun k m ->
let%bind (src , dst) = bind_map_or (
(fun m -> trace_option (expected_map m) @@ get_t_map m) ,
(fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
) m in
let%bind () = assert_eq src k in
ok @@ dst
let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m ->
let%bind (src , dst) = bind_map_or (
(fun m -> trace_option (expected_map m) @@ get_t_map m) ,
(fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
) m in
let%bind () = assert_eq src k in
ok @@ t_option dst ()
let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m ->
let%bind (k, v) = trace_option (expected_map m) @@ get_t_map m in
let%bind (arg , res) = trace_option (expected_function f) @@ get_t_function f in
let kv = t_pair k v () in
let unit = t_unit () in
let%bind () = assert_eq arg kv in
let%bind () = assert_eq res unit in
ok @@ t_unit ()
let map_map : typer = typer_2 "MAP_MAP" @@ fun f m ->
let%bind (k, v) = trace_option (expected_map m) @@ get_t_map m in
let%bind (arg , res) = trace_option (expected_function f) @@ get_t_function f in
let kv = t_pair k v () in
let%bind () = assert_eq arg kv in
ok @@ t_map k res ()
let size = typer_1 "SIZE" @@ fun t ->
let%bind () =
Assert.assert_true (wrong_size t) @@
(is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in
ok @@ t_nat ()
let slice = typer_3 "SLICE" @@ fun i j s ->
let t_nat = t_nat () in
let%bind () = assert_eq i t_nat in
let%bind () = assert_eq j t_nat in
if eq_1 s (t_string ())
then ok @@ t_string ()
else if eq_1 s (t_bytes ())
then ok @@ t_bytes ()
else fail @@ typeclass_error
[
[t_nat;t_nat;t_string()] ;
[t_nat;t_nat;t_bytes()] ;
]
[i ; j ; s]
let failwith_ = typer_1_opt "FAILWITH" @@ fun t opt ->
let%bind _ =
if eq_1 t (t_string ())
then ok ()
else if eq_1 t (t_nat ())
then ok ()
else if eq_1 t (t_int ())
then ok ()
else
fail @@ typeclass_error
[
[t_string()] ;
[t_nat()] ;
[t_int()] ;
]
[t] in
let default = t_unit () in
ok @@ Simple_utils.Option.unopt ~default opt
let int : typer = typer_1 "INT" @@ fun t ->
let%bind () = trace_option (expected_nat t) @@ assert_t_nat t in
ok @@ t_int ()
let bytes_pack : typer = typer_1 "PACK" @@ fun _t ->
ok @@ t_bytes ()
let bytes_unpack = typer_1_opt "UNPACK" @@ fun input output_opt ->
let%bind () = trace_option (expected_bytes input) @@ assert_t_bytes input in
trace_option not_annotated @@ output_opt
let hash256 = typer_1 "SHA256" @@ fun t ->
let%bind () = trace_option (expected_bytes t) @@ assert_t_bytes t in
ok @@ t_bytes ()
let hash512 = typer_1 "SHA512" @@ fun t ->
let%bind () = trace_option (expected_bytes t) @@ assert_t_bytes t in
ok @@ t_bytes ()
let blake2b = typer_1 "BLAKE2b" @@ fun t ->
let%bind () = trace_option (expected_bytes t) @@ assert_t_bytes t in
ok @@ t_bytes ()
let hash_key = typer_1 "HASH_KEY" @@ fun t ->
let%bind () = trace_option (expected_key t) @@ assert_t_key t in
ok @@ t_key_hash ()
let check_signature = typer_3 "CHECK_SIGNATURE" @@ fun k s b ->
let%bind () = trace_option (expected_key k) @@ assert_t_key k in
let%bind () = trace_option (expected_signature s) @@ assert_t_signature s in
let%bind () = trace_option (expected_bytes b) @@ assert_t_bytes b in
ok @@ t_bool ()
let sender = constant' "SENDER" @@ t_address ()
let source = constant' "SOURCE" @@ t_address ()
let unit = constant' "UNIT" @@ t_unit ()
let amount = constant' "AMOUNT" @@ t_mutez ()
let balance = constant' "BALANCE" @@ t_mutez ()
let chain_id = constant' "CHAIN_ID" @@ t_chain_id ()
let address = typer_1 "ADDRESS" @@ fun c ->
let%bind () = trace_option (expected_contract c) @@ assert_t_contract c in
ok @@ t_address ()
let self_address = typer_0 "SELF_ADDRESS" @@ fun _ ->
ok @@ t_address ()
let self = typer_1_opt "SELF" @@ fun entrypoint_as_string tv_opt ->
let%bind () = trace_option (expected_string entrypoint_as_string) @@ assert_t_string entrypoint_as_string in
match tv_opt with
| None -> fail not_annotated
| Some t -> ok @@ t
let implicit_account = typer_1 "IMPLICIT_ACCOUNT" @@ fun key_hash ->
let%bind () = trace_option (expected_key_hash key_hash) @@ assert_t_key_hash key_hash in
ok @@ t_contract (t_unit () ) ()
let now = constant' "NOW" @@ t_timestamp ()
let transaction = typer_3 "CALL" @@ fun param amount contract ->
let%bind () = trace_option (expected_mutez amount) @@ assert_t_mutez amount in
let%bind contract_param = trace_option (expected_contract contract) @@ get_t_contract contract in
let%bind () = assert_eq param contract_param in
ok @@ t_operation ()
let create_contract = typer_4 "CREATE_CONTRACT" @@ fun f kh_opt amount init_storage ->
let%bind (args , ret) = trace_option (expected_function f) @@ get_t_function f in
let%bind (_,s) = trace_option (expected_pair args) @@ get_t_pair args in
let%bind (oplist,s') = trace_option (expected_pair ret) @@ get_t_pair ret in
let%bind () = trace_option (expected_mutez amount) @@ assert_t_mutez amount in
let%bind (delegate) = trace_option (expected_option kh_opt) @@ get_t_option kh_opt in
let%bind () = assert_eq s s' in
let%bind () = assert_eq s init_storage in
let%bind () = trace_option (expected_op_list oplist) @@ assert_t_list_operation oplist in
let%bind () = trace_option (expected_key_hash delegate) @@ assert_t_key_hash delegate in
ok @@ t_pair (t_operation ()) (t_address ()) ()
let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt ->
let t_addr = t_address () in
let%bind () = assert_eq addr_tv t_addr in
let%bind tv = trace_option not_annotated tv_opt in
let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
ok @@ t_contract tv' ()
let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt ->
let t_addr = t_address () in
let%bind () = assert_eq addr_tv t_addr in
let%bind tv = trace_option not_annotated tv_opt in
let%bind tv = trace_option (expected_option tv) @@ get_t_option tv in
let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
ok @@ t_option (t_contract tv' ()) ()
let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt ->
let t_string = t_string () in
let t_addr = t_address () in
let%bind () = assert_eq entry_tv t_string in
let%bind () = assert_eq addr_tv t_addr in
let%bind tv = trace_option not_annotated tv_opt in
let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
ok @@ t_contract tv' ()
let get_entrypoint_opt = typer_2_opt "CONTRACT_ENTRYPOINT_OPT" @@ fun entry_tv addr_tv tv_opt ->
let t_string = t_string () in
let t_addr = t_address () in
let%bind () = assert_eq entry_tv t_string in
let%bind () = assert_eq addr_tv t_addr in
let%bind tv = trace_option not_annotated tv_opt in
let%bind tv = trace_option (expected_option tv) @@ get_t_option tv in
let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
ok @@ t_option (t_contract tv' ())()
let set_delegate = typer_1 "SET_DELEGATE" @@ fun delegate_opt ->
let kh_opt = (t_option (t_key_hash ()) ()) in
let%bind () = assert_eq delegate_opt kh_opt in
ok @@ t_operation ()
let abs = typer_1 "ABS" @@ fun t ->
let%bind () = trace_option (expected_int t) @@ assert_t_int t in
ok @@ t_nat ()
let is_nat = typer_1 "ISNAT" @@ fun t ->
let%bind () = trace_option (expected_int t) @@ assert_t_int t in
ok @@ t_option (t_nat ()) ()
let neg = typer_1 "NEG" @@ fun t ->
let%bind () = Assert.assert_true (wrong_neg t) @@ (eq_1 t (t_nat ()) || eq_1 t (t_int ())) in
ok @@ t_int ()
let assertion = typer_1 "ASSERT" @@ fun a ->
let%bind () = trace_option (expected_bool a) @@ assert_t_bool a in
ok @@ t_unit ()
let times = typer_2 "TIMES" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_nat () else
if eq_2 (a , b) (t_int ())
then ok @@ t_int () else
if (eq_1 a (t_nat ()) && eq_1 b (t_mutez ())) || (eq_1 b (t_nat ()) && eq_1 a (t_mutez ()))
then ok @@ t_mutez () else
fail @@ typeclass_error
[
[t_nat();t_nat()] ;
[t_int();t_int()] ;
[t_nat();t_mutez()] ;
[t_mutez();t_nat()] ;
]
[a; b]
let ediv = typer_2 "EDIV" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_option (t_pair (t_nat ()) (t_nat ()) ()) () else
if eq_2 (a , b) (t_int ())
then ok @@ t_option (t_pair (t_int ()) (t_nat ()) ()) () else
if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
then ok @@ t_option (t_pair (t_nat ()) (t_mutez ()) ()) () else
if eq_1 a (t_mutez ()) && eq_1 b (t_nat ())
then ok @@ t_option (t_pair (t_mutez ()) (t_mutez ()) ()) () else
fail @@ typeclass_error
[
[t_nat();t_nat()] ;
[t_int();t_int()] ;
[t_mutez();t_nat()] ;
[t_mutez();t_mutez()] ;
]
[a; b]
let div = typer_2 "DIV" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_nat () else
if eq_2 (a , b) (t_int ())
then ok @@ t_int () else
if eq_1 a (t_mutez ()) && eq_1 b (t_nat ())
then ok @@ t_mutez () else
if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
then ok @@ t_nat () else
fail @@ typeclass_error
[
[t_nat();t_nat()] ;
[t_int();t_int()] ;
[t_mutez();t_nat()] ;
[t_mutez();t_mutez()] ;
]
[a; b]
let mod_ = typer_2 "MOD" @@ fun a b ->
if (eq_1 a (t_nat ()) || eq_1 a (t_int ())) && (eq_1 b (t_nat ()) || eq_1 b (t_int ()))
then ok @@ t_nat () else
if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
then ok @@ t_mutez () else
fail @@ typeclass_error
[
[t_nat();t_nat()] ;
[t_nat();t_int()] ;
[t_int();t_nat()] ;
[t_int();t_int()] ;
[t_mutez();t_mutez()] ;
]
[a; b]
let add = typer_2 "ADD" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_nat () else
if eq_2 (a , b) (t_int ())
then ok @@ t_int () else
if eq_2 (a , b) (t_mutez ())
then ok @@ t_mutez () else
if (eq_1 a (t_nat ()) && eq_1 b (t_int ())) || (eq_1 b (t_nat ()) && eq_1 a (t_int ()))
then ok @@ t_int () else
if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) || (eq_1 b (t_timestamp ()) && eq_1 a (t_int ()))
then ok @@ t_timestamp () else
fail @@ typeclass_error
[
[t_nat();t_nat()] ;
[t_int();t_int()] ;
[t_mutez();t_mutez()] ;
[t_nat();t_int()] ;
[t_int();t_nat()] ;
[t_timestamp();t_int()] ;
[t_int();t_timestamp()] ;
]
[a; b]
let set_mem = typer_2 "SET_MEM" @@ fun elt set ->
let%bind key = trace_option (expected_set set) @@ get_t_set set in
let%bind () = assert_eq elt key in
ok @@ t_bool ()
let set_add = typer_2 "SET_ADD" @@ fun elt set ->
let%bind key = trace_option (expected_set set) @@ get_t_set set in
let%bind () = assert_eq elt key in
ok set
let set_remove = typer_2 "SET_REMOVE" @@ fun elt set ->
let%bind key = trace_option (expected_set set) @@ get_t_set set in
let%bind () = assert_eq elt key in
ok set
let set_iter = typer_2 "SET_ITER" @@ fun body set ->
let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
let%bind () = assert_eq res (t_unit ()) in
let%bind key = trace_option (expected_set set) @@ get_t_set set in
let%bind () = assert_eq key arg in
ok (t_unit ())
let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> fail not_annotated
| Some t -> ok t
let list_iter = typer_2 "LIST_ITER" @@ fun body lst ->
let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
let%bind () = assert_eq res (t_unit ()) in
let%bind key = trace_option (expected_list lst) @@ get_t_list lst in
let%bind () = assert_eq key arg in
ok (t_unit ())
let list_map = typer_2 "LIST_MAP" @@ fun body lst ->
let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
let%bind key = trace_option (expected_list lst) @@ get_t_list lst in
let%bind () = assert_eq key arg in
ok (t_list res ())
let list_fold = typer_3 "LIST_FOLD" @@ fun body lst init ->
let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
let%bind (prec , cur) = trace_option (expected_pair arg) @@ get_t_pair arg in
let%bind key = trace_option (expected_list lst) @@ get_t_list lst in
trace bad_list_fold_tracer @@
let%bind () = assert_eq key cur in
let%bind () = assert_eq prec res in
let%bind () = assert_eq res init in
ok res
let set_fold = typer_3 "SET_FOLD" @@ fun body lst init ->
let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
let%bind (prec , cur) = trace_option (expected_pair arg) @@ get_t_pair arg in
let%bind key = trace_option (expected_set lst) @@ get_t_set lst in
trace bad_set_fold_tracer @@
let%bind () = assert_eq key cur in
let%bind () = assert_eq prec res in
let%bind () = assert_eq res init in
ok res
let map_fold = typer_3 "MAP_FOLD" @@ fun body map init ->
let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
let%bind (prec , cur) = trace_option (expected_pair arg) @@ get_t_pair arg in
let%bind (key , value) = trace_option (expected_map map) @@ get_t_map map in
let kv = t_pair key value () in
trace bad_map_fold_tracer @@
let%bind () = assert_eq kv cur in
let%bind () = assert_eq prec res in
let%bind () = assert_eq res init in
ok res
(** FOLD_WHILE is a fold operation that takes an initial value of a certain type
and then iterates on it until a condition is reached. The auxillary function
that does the fold returns either boolean true or boolean false to indicate
whether the fold should continue or not. Necessarily then the initial value
must match the input parameter of the auxillary function, and the auxillary
should return type (bool * input) *)
let fold_while = typer_2 "FOLD_WHILE" @@ fun body init ->
let%bind (arg, result) = trace_option (expected_function body) @@ get_t_function body in
let%bind () = assert_eq arg init in
let%bind () = assert_eq (t_pair (t_bool ()) init ()) result
in ok init
(* Continue and Stop are just syntactic sugar for building a pair (bool * a') *)
let continue = typer_1 "CONTINUE" @@ fun arg ->
ok @@ t_pair (t_bool ()) arg ()
let stop = typer_1 "STOP" @@ fun arg ->
ok (t_pair (t_bool ()) arg ())
let not_ = typer_1 "NOT" @@ fun elt ->
if eq_1 elt (t_bool ())
then ok @@ t_bool ()
else if eq_1 elt (t_nat ()) || eq_1 elt (t_int ())
then ok @@ t_int ()
else fail @@ wrong_not elt
let or_ = typer_2 "OR" @@ fun a b ->
if eq_2 (a , b) (t_bool ())
then ok @@ t_bool ()
else if eq_2 (a , b) (t_nat ())
then ok @@ t_nat ()
else fail @@ typeclass_error
[
[t_bool();t_bool()] ;
[t_nat();t_nat()] ;
]
[a; b]
let xor = typer_2 "XOR" @@ fun a b ->
if eq_2 (a , b) (t_bool ())
then ok @@ t_bool ()
else if eq_2 (a , b) (t_nat ())
then ok @@ t_nat ()
else fail @@ typeclass_error
[
[t_bool();t_bool()] ;
[t_nat();t_nat()] ;
]
[a; b]
let and_ = typer_2 "AND" @@ fun a b ->
if eq_2 (a , b) (t_bool ())
then ok @@ t_bool ()
else if eq_2 (a , b) (t_nat ()) || (eq_1 b (t_nat ()) && eq_1 a (t_int ()))
then ok @@ t_nat ()
else fail @@ typeclass_error
[
[t_bool();t_bool()] ;
[t_nat();t_nat()] ;
[t_int();t_nat()] ;
]
[a; b]
let lsl_ = typer_2 "LSL" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_nat ()
else fail @@ typeclass_error
[
[t_nat();t_nat()] ;
]
[a; b]
let lsr_ = typer_2 "LSR" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_nat ()
else fail @@ typeclass_error
[
[t_nat();t_nat()] ;
]
[a; b]
let concat = typer_2 "CONCAT" @@ fun a b ->
if eq_2 (a , b) (t_string ())
then ok @@ t_string ()
else if eq_2 (a , b) (t_bytes ())
then ok @@ t_bytes ()
else fail @@ typeclass_error
[
[t_string();t_string()] ;
[t_bytes();t_bytes()] ;
]
[a; b]
let cons = typer_2 "CONS" @@ fun hd tl ->
let%bind elt = trace_option (expected_list tl) @@ get_t_list tl in
let%bind () = assert_eq hd elt in
ok tl
let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun t ->
match t.type_content with
| T_record lmap ->
let kvl = LMap.to_kv_list lmap in
let%bind () = Michelson_type_converter.record_checks kvl t.location in
let pair = Michelson_type_converter.convert_pair_to_right_comb kvl in
ok {t with type_content = pair}
| T_sum cmap ->
let kvl = CMap.to_kv_list cmap in
let%bind () = Michelson_type_converter.variant_checks kvl t.location in
let michelson_or = Michelson_type_converter.convert_variant_to_right_comb kvl in
ok {t with type_content = michelson_or}
| _ -> fail @@ wrong_converter t
let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun t ->
match t.type_content with
| T_record lmap ->
let kvl = LMap.to_kv_list lmap in
let%bind () = Michelson_type_converter.record_checks kvl t.location in
let pair = Michelson_type_converter.convert_pair_to_left_comb kvl in
ok {t with type_content = pair}
| T_sum cmap ->
let kvl = CMap.to_kv_list cmap in
let%bind () = Michelson_type_converter.variant_checks kvl t.location in
let michelson_or = Michelson_type_converter.convert_variant_to_left_comb kvl in
ok {t with type_content = michelson_or}
| _ -> fail @@ wrong_converter t
let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun t opt ->
let%bind dst_t = trace_option not_annotated opt in
match t.type_content with
| T_record src_lmap ->
let%bind dst_lmap = trace_option (expected_record dst_t) @@ get_t_record dst_t in
let%bind record = Michelson_type_converter.convert_pair_from_right_comb src_lmap dst_lmap in
ok {t with type_content = record}
| T_sum src_cmap ->
let%bind dst_cmap = trace_option (expected_variant dst_t) @@ get_t_sum dst_t in
let%bind variant = Michelson_type_converter.convert_variant_from_right_comb src_cmap dst_cmap in
ok {t with type_content = variant}
| _ -> fail @@ wrong_converter t
let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun t opt ->
let%bind dst_t = trace_option not_annotated opt in
match t.type_content with
| T_record src_lmap ->
let%bind dst_lmap = trace_option (expected_record dst_t) @@ get_t_record dst_t in
let%bind record = Michelson_type_converter.convert_pair_from_left_comb src_lmap dst_lmap in
ok {t with type_content = record}
| T_sum src_cmap ->
let%bind dst_cmap = trace_option (expected_variant dst_t) @@ get_t_sum dst_t in
let%bind variant = Michelson_type_converter.convert_variant_from_left_comb src_cmap dst_cmap in
ok {t with type_content = variant}
| _ -> fail @@ wrong_converter t
let simple_comparator : string -> typer = fun s -> typer_2 s @@ fun a b ->
let%bind () =
Assert.assert_true (uncomparable_types a b) @@
List.exists (eq_2 (a , b)) [
t_int () ;
t_nat () ;
t_bool () ;
t_mutez () ;
t_string () ;
t_bytes () ;
t_address () ;
t_timestamp () ;
t_key_hash () ;
] in
ok @@ t_bool ()
let rec pair_comparator : string -> typer = fun s -> typer_2 s @@ fun a b ->
let%bind () =
Assert.assert_true (uncomparable_types a b) @@ eq_1 a b
in
let%bind (a_k, a_v) =
trace_option (comparator_composed a) @@
get_t_pair a in
let%bind (b_k, b_v) = trace_option (expected_pair b) @@ get_t_pair b in
let%bind _ = simple_comparator s [a_k;b_k] None
in
comparator s [a_v;b_v] None
and comparator : string -> typer = fun s -> typer_2 s @@ fun a b ->
bind_or (simple_comparator s [a;b] None, pair_comparator s [a;b] None)
let constant_typers c : (typer , typer_error) result = match c with
| C_INT -> ok @@ int ;
| C_UNIT -> ok @@ unit ;
| C_NOW -> ok @@ now ;
| C_IS_NAT -> ok @@ is_nat ;
| C_SOME -> ok @@ some ;
| C_NONE -> ok @@ none ;
| C_ASSERTION -> ok @@ assertion ;
| C_FAILWITH -> ok @@ failwith_ ;
(* LOOPS *)
| C_FOLD_WHILE -> ok @@ fold_while ;
| C_FOLD_CONTINUE -> ok @@ continue ;
| C_FOLD_STOP -> ok @@ stop ;
(* MATH *)
| C_NEG -> ok @@ neg ;
| C_ABS -> ok @@ abs ;
| C_ADD -> ok @@ add ;
| C_SUB -> ok @@ sub ;
| C_MUL -> ok @@ times ;
| C_EDIV -> ok @@ ediv ;
| C_DIV -> ok @@ div ;
| C_MOD -> ok @@ mod_ ;
(* LOGIC *)
| C_NOT -> ok @@ not_ ;
| C_AND -> ok @@ and_ ;
| C_OR -> ok @@ or_ ;
| C_XOR -> ok @@ xor ;
| C_LSL -> ok @@ lsl_;
| C_LSR -> ok @@ lsr_;
(* COMPARATOR *)
| C_EQ -> ok @@ comparator "EQ" ;
| C_NEQ -> ok @@ comparator "NEQ" ;
| C_LT -> ok @@ comparator "LT" ;
| C_GT -> ok @@ comparator "GT" ;
| C_LE -> ok @@ comparator "LE" ;
| C_GE -> ok @@ comparator "GE" ;
(* BYTES / STRING *)
| C_SIZE -> ok @@ size ;
| C_CONCAT -> ok @@ concat ;
| C_SLICE -> ok @@ slice ;
| C_BYTES_PACK -> ok @@ bytes_pack ;
| C_BYTES_UNPACK -> ok @@ bytes_unpack ;
(* SET *)
| C_SET_EMPTY -> ok @@ set_empty ;
| C_SET_ADD -> ok @@ set_add ;
| C_SET_REMOVE -> ok @@ set_remove ;
| C_SET_ITER -> ok @@ set_iter ;
| C_SET_FOLD -> ok @@ set_fold ;
| C_SET_MEM -> ok @@ set_mem ;
(* LIST *)
| C_CONS -> ok @@ cons ;
| C_LIST_EMPTY -> ok @@ list_empty ;
| C_LIST_ITER -> ok @@ list_iter ;
| C_LIST_MAP -> ok @@ list_map ;
| C_LIST_FOLD -> ok @@ list_fold ;
(* MAP *)
| C_MAP_EMPTY -> ok @@ map_empty ;
| C_BIG_MAP_EMPTY -> ok @@ big_map_empty ;
| C_MAP_ADD -> ok @@ map_add ;
| C_MAP_REMOVE -> ok @@ map_remove ;
| C_MAP_UPDATE -> ok @@ map_update ;
| C_MAP_ITER -> ok @@ map_iter ;
| C_MAP_MAP -> ok @@ map_map ;
| C_MAP_FOLD -> ok @@ map_fold ;
| C_MAP_MEM -> ok @@ map_mem ;
| C_MAP_FIND -> ok @@ map_find ;
| C_MAP_FIND_OPT -> ok @@ map_find_opt ;
(* BIG MAP *)
(* CRYPTO *)
| C_SHA256 -> ok @@ hash256 ;
| C_SHA512 -> ok @@ hash512 ;
| C_BLAKE2b -> ok @@ blake2b ;
| C_HASH_KEY -> ok @@ hash_key ;
| C_CHECK_SIGNATURE -> ok @@ check_signature ;
| C_CHAIN_ID -> ok @@ chain_id ;
(*BLOCKCHAIN *)
| C_CONTRACT -> ok @@ get_contract ;
| C_CONTRACT_OPT -> ok @@ get_contract_opt ;
| C_CONTRACT_ENTRYPOINT -> ok @@ get_entrypoint ;
| C_CONTRACT_ENTRYPOINT_OPT -> ok @@ get_entrypoint_opt ;
| C_AMOUNT -> ok @@ amount ;
| C_BALANCE -> ok @@ balance ;
| C_CALL -> ok @@ transaction ;
| C_SENDER -> ok @@ sender ;
| C_SOURCE -> ok @@ source ;
| C_ADDRESS -> ok @@ address ;
| C_SELF -> ok @@ self;
| C_SELF_ADDRESS -> ok @@ self_address;
| C_IMPLICIT_ACCOUNT -> ok @@ implicit_account;
| C_SET_DELEGATE -> ok @@ set_delegate ;
| C_CREATE_CONTRACT -> ok @@ create_contract ;
| C_CONVERT_TO_RIGHT_COMB -> ok @@ convert_to_right_comb ;
| C_CONVERT_TO_LEFT_COMB -> ok @@ convert_to_left_comb ;
| C_CONVERT_FROM_RIGHT_COMB -> ok @@ convert_from_right_comb ;
| C_CONVERT_FROM_LEFT_COMB -> ok @@ convert_from_left_comb ;
| _ -> fail (corner_case "typer not implemented for constant")

182
src/passes/08-typer-common/constant_typers_new.ml Normal file
View File

@ -0,0 +1,182 @@
open Errors
open Ast_typed
open Trace
module Operators_types = struct
open Typesystem.Shorthands
let tc_subarg a b c = tc "arguments for (-)" [a;b;c] [ (*TODO…*) ]
let tc_sizearg a = tc "arguments for size" [a] [ [int] ]
let tc_packable a = tc "packable" [a] [ [int] ; [string] ; [bool] (*TODO…*) ]
let tc_timargs a b c = tc "arguments for ( * )" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
let tc_edivargs a b c = tc "arguments for ediv" [a;b;c] [ (*TODO…*) ]
let tc_divargs a b c = tc "arguments for div" [a;b;c] [ (*TODO…*) ]
let tc_modargs a b c = tc "arguments for mod" [a;b;c] [ (*TODO…*) ]
let tc_addargs a b c = tc "arguments for (+)" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
let tc_comparable a = tc "comparable" [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ]
let tc_concatable a = tc "concatenable" [a] [ [string] ; [bytes] ]
let tc_storable a = tc "storable" [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
let t_none = forall "a" @@ fun a -> option a
let t_sub = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_some = forall "a" @@ fun a -> a --> option a
let t_map_remove = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst
let t_map_add = forall2 "src" "dst" @@ fun src dst -> tuple3 src dst (map src dst) --> map src dst
let t_map_update = forall2 "src" "dst" @@ fun src dst -> tuple3 src (option dst) (map src dst) --> map src dst
let t_map_mem = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> bool
let t_map_find = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst
let t_map_find_opt = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> option dst
let t_map_fold = forall3 "src" "dst" "acc" @@ fun src dst acc -> tuple3 ( ( (src * dst) * acc ) --> acc ) (map src dst) acc --> acc
let t_map_map = forall3 "k" "v" "result" @@ fun k v result -> tuple2 ((k * v) --> result) (map k v) --> map k result
(* TODO: the type of map_map_fold might be wrong, check it. *)
let t_map_map_fold = forall4 "k" "v" "acc" "dst" @@ fun k v acc dst -> tuple3 ( ((k * v) * acc) --> acc * dst ) (map k v) (k * v) --> (map k dst * acc)
let t_map_iter = forall2 "k" "v" @@ fun k v -> tuple2 ( (k * v) --> unit ) (map k v) --> unit
let t_size = forall_tc "c" @@ fun c -> [tc_sizearg c] => tuple1 c --> nat (* TYPECLASS *)
let t_slice = tuple3 nat nat string --> string
let t_failwith = tuple1 string --> unit
let t_get_force = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst
let t_int = tuple1 nat --> int
let t_bytes_pack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 a --> bytes (* TYPECLASS *)
let t_bytes_unpack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 bytes --> a (* TYPECLASS *)
let t_hash256 = tuple1 bytes --> bytes
let t_hash512 = tuple1 bytes --> bytes
let t_blake2b = tuple1 bytes --> bytes
let t_hash_key = tuple1 key --> key_hash
let t_is_nat = tuple1 int --> bool
let t_check_signature = tuple3 key signature bytes --> bool
let t_chain_id = tuple0 --> chain_id
let t_sender = tuple0 --> address
let t_source = tuple0 --> address
let t_unit = tuple0 --> unit
let t_amount = tuple0 --> mutez
let t_balance = tuple0 --> mutez
let t_address = tuple0 --> address
let t_now = tuple0 --> timestamp
let t_transaction = forall "a" @@ fun a -> tuple3 a mutez (contract a) --> operation
let t_get_contract = forall "a" @@ fun a -> tuple0 --> contract a
let t_abs = tuple1 int --> nat
let t_cons = forall "a" @@ fun a -> tuple2 a (list a) --> list a
let t_assertion = tuple1 bool --> unit
let t_times = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_ediv = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_edivargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_div = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_mod = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_add = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_set_mem = forall "a" @@ fun a -> tuple2 a (set a) --> bool
let t_set_add = forall "a" @@ fun a -> tuple2 a (set a) --> set a
let t_set_remove = forall "a" @@ fun a -> tuple2 a (set a) --> set a
let t_not = tuple1 bool --> bool
let t_continuation = forall "a" @@ fun a -> tuple2 bool a --> pair bool a
let t_fold_while = forall "a" @@ fun a -> tuple2 (a --> pair bool a) a --> a
let t_neg = tuple1 int --> int
let t_and = tuple2 bool bool --> bool
let t_or = tuple2 bool bool --> bool
let t_xor = tuple2 bool bool --> bool
let t_lsl = tuple2 nat nat --> nat
let t_lsr = tuple2 nat nat --> nat
let t_comp = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple2 a a --> bool
let t_concat = forall_tc "a" @@ fun a -> [tc_concatable a] => tuple2 a a --> a
let t_set_empty = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple0 --> set a
let t_set_iter = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple2 (a --> unit) (set a) --> unit
(* TODO: check that the implementation has this type *)
let t_set_fold = forall2_tc "a" "b" @@ fun a b -> [tc_comparable b] => tuple3 (pair a b --> a) (set b) a --> a
let t_list_iter = forall "a" @@ fun a -> tuple2 (a --> unit) (list a) --> unit
let t_list_map = forall "a" @@ fun a -> tuple2 (a --> a) (list a) --> (list a)
(* TODO: check that the implementation has this type *)
let t_list_fold = forall2 "a" "b" @@ fun a b -> tuple3 (pair a b --> a) (list b) a --> a
let t_self_address = tuple0 --> address
let t_implicit_account = forall_tc "a" @@ fun a -> [tc_storable a] => tuple1 key_hash --> contract a
let t_set_delegate = tuple1 (option key_hash) --> operation
let constant_type : constant' -> (Typesystem.Core.type_value, typer_error) result = function
| C_INT -> ok @@ t_int ;
| C_UNIT -> ok @@ t_unit ;
| C_NOW -> ok @@ t_now ;
| C_IS_NAT -> ok @@ t_is_nat ;
| C_SOME -> ok @@ t_some ;
| C_NONE -> ok @@ t_none ;
| C_ASSERTION -> ok @@ t_assertion ;
| C_FAILWITH -> ok @@ t_failwith ;
(* LOOPS *)
| C_FOLD_WHILE -> ok @@ t_fold_while ;
| C_FOLD_CONTINUE -> ok @@ t_continuation ;
| C_FOLD_STOP -> ok @@ t_continuation ;
(* MATH *)
| C_NEG -> ok @@ t_neg ;
| C_ABS -> ok @@ t_abs ;
| C_ADD -> ok @@ t_add ;
| C_SUB -> ok @@ t_sub ;
| C_MUL -> ok @@ t_times ;
| C_EDIV -> ok @@ t_ediv ;
| C_DIV -> ok @@ t_div ;
| C_MOD -> ok @@ t_mod ;
(* LOGIC *)
| C_NOT -> ok @@ t_not ;
| C_AND -> ok @@ t_and ;
| C_OR -> ok @@ t_or ;
| C_XOR -> ok @@ t_xor ;
| C_LSL -> ok @@ t_lsl ;
| C_LSR -> ok @@ t_lsr ;
(* COMPARATOR *)
| C_EQ -> ok @@ t_comp ;
| C_NEQ -> ok @@ t_comp ;
| C_LT -> ok @@ t_comp ;
| C_GT -> ok @@ t_comp ;
| C_LE -> ok @@ t_comp ;
| C_GE -> ok @@ t_comp ;
(* BYTES / STRING *)
| C_SIZE -> ok @@ t_size ;
| C_CONCAT -> ok @@ t_concat ;
| C_SLICE -> ok @@ t_slice ;
| C_BYTES_PACK -> ok @@ t_bytes_pack ;
| C_BYTES_UNPACK -> ok @@ t_bytes_unpack ;
| C_CONS -> ok @@ t_cons ;
(* SET *)
| C_SET_EMPTY -> ok @@ t_set_empty ;
| C_SET_ADD -> ok @@ t_set_add ;
| C_SET_REMOVE -> ok @@ t_set_remove ;
| C_SET_ITER -> ok @@ t_set_iter ;
| C_SET_FOLD -> ok @@ t_set_fold ;
| C_SET_MEM -> ok @@ t_set_mem ;
(* LIST *)
| C_LIST_ITER -> ok @@ t_list_iter ;
| C_LIST_MAP -> ok @@ t_list_map ;
| C_LIST_FOLD -> ok @@ t_list_fold ;
(* MAP *)
| C_MAP_ADD -> ok @@ t_map_add ;
| C_MAP_REMOVE -> ok @@ t_map_remove ;
| C_MAP_UPDATE -> ok @@ t_map_update ;
| C_MAP_ITER -> ok @@ t_map_iter ;
| C_MAP_MAP -> ok @@ t_map_map ;
| C_MAP_FOLD -> ok @@ t_map_fold ;
| C_MAP_MEM -> ok @@ t_map_mem ;
| C_MAP_FIND -> ok @@ t_map_find ;
| C_MAP_FIND_OPT -> ok @@ t_map_find_opt ;
(* BIG MAP *)
(* CRYPTO *)
| C_SHA256 -> ok @@ t_hash256 ;
| C_SHA512 -> ok @@ t_hash512 ;
| C_BLAKE2b -> ok @@ t_blake2b ;
| C_HASH_KEY -> ok @@ t_hash_key ;
| C_CHECK_SIGNATURE -> ok @@ t_check_signature ;
| C_CHAIN_ID -> ok @@ t_chain_id ;
(*BLOCKCHAIN *)
| C_CONTRACT -> ok @@ t_get_contract ;
| C_CONTRACT_ENTRYPOINT -> ok @@ failwith "t_get_entrypoint" ;
| C_AMOUNT -> ok @@ t_amount ;
| C_BALANCE -> ok @@ t_balance ;
| C_CALL -> ok @@ t_transaction ;
| C_SENDER -> ok @@ t_sender ;
| C_SOURCE -> ok @@ t_source ;
| C_ADDRESS -> ok @@ t_address ;
| C_SELF_ADDRESS -> ok @@ t_self_address;
| C_IMPLICIT_ACCOUNT -> ok @@ t_implicit_account;
| C_SET_DELEGATE -> ok @@ t_set_delegate ;
| c -> fail (corner_case (Format.asprintf "Typer not implemented for constant %a" Ast_typed.PP.constant c))
end

14
src/passes/08-typer-common/dune Normal file
View File

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

1155
src/passes/08-typer-common/errors.ml Normal file
View File

File diff suppressed because it is too large Load Diff

89
src/passes/08-typer-common/helpers.ml Normal file
View File

@ -0,0 +1,89 @@
open Errors
open Ast_typed
open Trace
let assert_type_expression_eq ((tv',tv):type_expression * type_expression) : (unit,typer_error) result =
trace_option (assert_equal tv' tv) @@
assert_type_expression_eq (tv' , tv)
type typer = type_expression list -> type_expression option -> (type_expression, typer_error) result
let typer_0 : string -> (type_expression option -> (type_expression, typer_error) result) -> typer = fun s f lst tv_opt ->
match lst with
| [] -> (
let%bind tv' = f tv_opt in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 0 lst
let typer_1 : string -> (type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
match lst with
| [ a ] -> (
let%bind tv' = f a in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 1 lst
let typer_1_opt : string -> (type_expression -> type_expression option -> (type_expression , typer_error) result) -> typer = fun s f lst tv_opt ->
match lst with
| [ a ] -> (
let%bind tv' = f a tv_opt in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 1 lst
let typer_2 : string -> (type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ] -> (
let%bind tv' = f a b in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 2 lst
let typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> (type_expression, typer_error) result) -> typer = fun s f lst tv_opt ->
match lst with
| [ a ; b ] -> (
let%bind tv' = f a b tv_opt in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 2 lst
let typer_3 : string -> (type_expression -> type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ] -> (
let%bind tv' = f a b c in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 3 lst
let typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> (type_expression , typer_error) result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ] -> (
let%bind tv' = f a b c d in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 4 lst
let typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ; e ] -> (
let%bind tv' = f a b c d e in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 5 lst
let typer_6 : string
-> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ; e ; f_ ] -> (
let%bind tv' = f a b c d e f_ in
ok (tv')
)
| _ -> fail @@ wrong_param_number s 6 lst
let constant' name cst = typer_0 name (fun _ -> ok cst)
let eq_1 a cst = type_expression_eq (a , cst)
let eq_2 (a , b) cst = type_expression_eq (a , cst) && type_expression_eq (b , cst)
let assert_eq_1 a b = if eq_1 a b then Some () else None
let assert_eq a b = trace_option (not_matching a b) @@ assert_eq_1 a b

179
src/passes/08-typer-common/michelson_type_converter.ml Normal file
View File

@ -0,0 +1,179 @@
open Errors
open Ast_typed
open Trace
let record_checks kvl loc =
let%bind () = Assert.assert_true
(too_small_record loc)
(List.length kvl >=2) in
let all_undefined = List.for_all (fun (_,{field_decl_pos;_}) -> field_decl_pos = 0) kvl in
let%bind () = Assert.assert_true
(declaration_order_record loc)
(not all_undefined) in
ok ()
let variant_checks kvl loc =
let%bind () = Assert.assert_true
(too_small_variant loc)
(List.length kvl >=2) in
let all_undefined = List.for_all (fun (_,{ctor_decl_pos;_}) -> ctor_decl_pos = 0) kvl in
let%bind () = Assert.assert_true
(declaration_order_variant loc)
(not all_undefined) in
ok ()
let annotate_field (field:field_content) (ann:string) : field_content =
{field with michelson_annotation=Some ann}
let annotate_ctor (ctor:ctor_content) (ann:string) : ctor_content =
{ctor with michelson_annotation=Some ann}
let comb_pair (t:type_content) : field_content =
let field_type = {
type_content = t ;
type_meta = None ;
location = Location.generated ; } in
{field_type ; michelson_annotation = Some "" ; field_decl_pos = 0}
let comb_ctor (t:type_content) : ctor_content =
let ctor_type = {
type_content = t ;
type_meta = None ;
location = Location.generated ; } in
{ctor_type ; michelson_annotation = Some "" ; ctor_decl_pos = 0}
let rec to_right_comb_pair l new_map =
match l with
| [] -> new_map
| [ (Label ann_l, field_content_l) ; (Label ann_r, field_content_r) ] ->
LMap.add_bindings [
(Label "0" , annotate_field field_content_l ann_l) ;
(Label "1" , annotate_field field_content_r ann_r) ] new_map
| (Label ann, field)::tl ->
let new_map' = LMap.add (Label "0") (annotate_field field ann) new_map in
LMap.add (Label "1") (comb_pair (T_record (to_right_comb_pair tl new_map'))) new_map'
let rec to_right_comb_variant l new_map =
match l with
| [] -> new_map
| [ (Constructor ann_l, field_content_l) ; (Constructor ann_r, field_content_r) ] ->
CMap.add_bindings [
(Constructor "M_left" , annotate_ctor field_content_l ann_l) ;
(Constructor "M_right" , annotate_ctor field_content_r ann_r) ] new_map
| (Constructor ann, field)::tl ->
let new_map' = CMap.add (Constructor "M_left") (annotate_ctor field ann) new_map in
CMap.add (Constructor "M_right") (comb_ctor (T_sum (to_right_comb_variant tl new_map'))) new_map'
let rec to_left_comb_pair' first l new_map =
match l with
| [] -> new_map
| (Label ann_l, field_content_l) :: (Label ann_r, field_content_r) ::tl when first ->
let new_map' = LMap.add_bindings [
(Label "0" , annotate_field field_content_l ann_l) ;
(Label "1" , annotate_field field_content_r ann_r) ] LMap.empty in
to_left_comb_pair' false tl new_map'
| (Label ann, field)::tl ->
let new_map' = LMap.add_bindings [
(Label "0" , comb_pair (T_record new_map)) ;
(Label "1" , annotate_field field ann ) ;] LMap.empty in
to_left_comb_pair' first tl new_map'
let to_left_comb_pair = to_left_comb_pair' true
let rec to_left_comb_variant' first l new_map =
match l with
| [] -> new_map
| (Constructor ann_l, ctor_content_l) :: (Constructor ann_r, ctor_content_r) ::tl when first ->
let new_map' = CMap.add_bindings [
(Constructor "M_left" , annotate_ctor ctor_content_l ann_l) ;
(Constructor "M_right" , annotate_ctor ctor_content_r ann_r) ] CMap.empty in
to_left_comb_variant' false tl new_map'
| (Constructor ann, ctor)::tl ->
let new_map' = CMap.add_bindings [
(Constructor "M_left" , comb_ctor (T_sum new_map)) ;
(Constructor "M_right" , annotate_ctor ctor ann ) ;] CMap.empty in
to_left_comb_variant' first tl new_map'
let to_left_comb_variant = to_left_comb_variant' true
let rec from_right_comb_pair (l:field_content label_map) (size:int) : (field_content list , typer_error) result =
let l' = List.rev @@ LMap.to_kv_list l in
match l' , size with
| [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
| [ (_,l) ; (_,{field_type=tr;_}) ], _ ->
let%bind comb_lmap = trace_option (expected_record tr) @@ get_t_record tr in
let%bind next = from_right_comb_pair comb_lmap (size-1) in
ok (l :: next)
| _ -> fail (corner_case "Could not convert michelson_pair_right_comb pair to a record")
let rec from_left_comb_pair (l:field_content label_map) (size:int) : (field_content list , typer_error) result =
let l' = List.rev @@ LMap.to_kv_list l in
match l' , size with
| [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
| [ (_,{field_type=tl;_}) ; (_,r) ], _ ->
let%bind comb_lmap = trace_option (expected_record tl) @@ get_t_record tl in
let%bind next = from_left_comb_pair comb_lmap (size-1) in
ok (List.append next [r])
| _ -> fail (corner_case "Could not convert michelson_pair_left_comb pair to a record")
let rec from_right_comb_variant (l:ctor_content constructor_map) (size:int) : (ctor_content list , typer_error) result =
let l' = List.rev @@ CMap.to_kv_list l in
match l' , size with
| [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
| [ (_,l) ; (_,{ctor_type=tr;_}) ], _ ->
let%bind comb_cmap = trace_option (expected_variant tr) @@ get_t_sum tr in
let%bind next = from_right_comb_variant comb_cmap (size-1) in
ok (l :: next)
| _ -> fail (corner_case "Could not convert michelson_or right comb to a variant")
let rec from_left_comb_variant (l:ctor_content constructor_map) (size:int) : (ctor_content list , typer_error) result =
let l' = List.rev @@ CMap.to_kv_list l in
match l' , size with
| [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
| [ (_,{ctor_type=tl;_}) ; (_,r) ], _ ->
let%bind comb_cmap = trace_option (expected_variant tl) @@ get_t_sum tl in
let%bind next = from_left_comb_variant comb_cmap (size-1) in
ok (List.append next [r])
| _ -> fail (corner_case "Could not convert michelson_or left comb to a record")
let convert_pair_to_right_comb l =
let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
T_record (to_right_comb_pair l' LMap.empty)
let convert_pair_to_left_comb l =
let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
T_record (to_left_comb_pair l' LMap.empty)
let convert_pair_from_right_comb (src: field_content label_map) (dst: field_content label_map) : (type_content , typer_error) result =
let%bind fields = from_right_comb_pair src (LMap.cardinal dst) in
let labels = List.map (fun (l,_) -> l) @@
List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@
LMap.to_kv_list dst in
ok @@ (T_record (LMap.of_list @@ List.combine labels fields))
let convert_pair_from_left_comb (src: field_content label_map) (dst: field_content label_map) : (type_content , typer_error) result =
let%bind fields = from_left_comb_pair src (LMap.cardinal dst) in
let labels = List.map (fun (l,_) -> l) @@
List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@
LMap.to_kv_list dst in
ok @@ (T_record (LMap.of_list @@ List.combine labels fields))
let convert_variant_to_right_comb l =
let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
T_sum (to_right_comb_variant l' CMap.empty)
let convert_variant_to_left_comb l =
let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
T_sum (to_left_comb_variant l' CMap.empty)
let convert_variant_from_right_comb (src: ctor_content constructor_map) (dst: ctor_content constructor_map) : (type_content , typer_error) result =
let%bind ctors = from_right_comb_variant src (CMap.cardinal dst) in
let ctors_name = List.map (fun (l,_) -> l) @@
List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b ) @@
CMap.to_kv_list dst in
ok @@ (T_sum (CMap.of_list @@ List.combine ctors_name ctors))
let convert_variant_from_left_comb (src: ctor_content constructor_map) (dst: ctor_content constructor_map) : (type_content , typer_error) result =
let%bind ctors = from_left_comb_variant src (CMap.cardinal dst) in
let ctors_name = List.map (fun (l,_) -> l) @@
List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b ) @@
CMap.to_kv_list dst in
ok @@ (T_sum (CMap.of_list @@ List.combine ctors_name ctors))

5
src/passes/08-typer-common/typer_common.ml Normal file
View File

@ -0,0 +1,5 @@
module Errors = Errors
module Michelson_type_converter = Michelson_type_converter
module Constant_typers = Constant_typers
module Constant_typers_new = Constant_typers_new
module Helpers = Helpers

1
src/passes/08-typer-new/dune
View File

@ -9,6 +9,7 @@
operators
UnionFind
environment
typer_common
)
(preprocess
(pps ppx_let)

157
src/passes/08-typer-new/errors.ml
View File

@ -1,157 +0,0 @@
open Trace
module I = Ast_core
module O = Ast_typed
module Environment = O.Environment
type environment = Environment.t
let unbound_type_variable (e:environment) (tv:I.type_variable) (loc:Location.t) () =
let title = (thunk "unbound type variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
("in" , fun () -> Format.asprintf "%a" Environment.PP.environment e)
] in
error ~data title message ()
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
let name () = Format.asprintf "%a" I.PP.expression_variable n in
let title = (thunk ("unbound variable "^(name ()))) in
let message () = "" in
let data = [
("variable" , name) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_empty_variant : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "match with no cases") in
let message () = "" in
let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_missing_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_redundant_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "redundant case in match") in
let message () = "" in
let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let unbound_constructor (e:environment) (c:I.constructor') (loc:Location.t) () =
let title = (thunk "unbound constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in
let message () = "" in
let data = [
("function" , fun () -> Format.asprintf "%s" n) ;
("expected" , fun () -> Format.asprintf "%d" expected) ;
("actual" , fun () -> Format.asprintf "%d" actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
let title () = "matching tuple of different size" in
let message () = "" in
let data = [
("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ;
("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
(* TODO: this should be a trace_info? *)
let program_error (p:I.program) () =
let message () = "" in
let title = (thunk "typing program") in
let data = [
("program" , fun () -> Format.asprintf "%a" I.PP.program p)
] in
error ~data title message ()
let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
let title = (thunk "typing constant declaration") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ; (* Todo : remove Stage_common*)
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
None -> "(no annotation for the expected type)"
| Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in
error ~data title message ()
let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
(* let needs_annotation (e : I.expression) (case : string) () =
* let title = (thunk "this expression must be annotated with its type") in
* let message () = Format.asprintf "%s needs an annotation" case in
* let data = [
* ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
* ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
* ] in
* error ~data title message () *)
(* let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
* let title = (thunk "type error") in
* let message () = msg in
* let data = [
* ("expected" , fun () -> Format.asprintf "%s" expected);
* ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual);
* ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
* ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
* ] in
* error ~data title message () *)
let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
let title = (thunk "type error") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
let message () = "" in
error title message

2
src/passes/08-typer-new/solver.ml
View File

@ -67,7 +67,7 @@ let select_and_propagate_all' : ex_propagator_state list -> type_constraint_simp
(* Takes a list of constraints, applies all selector+propagator pairs
to each in turn. *)
let rec select_and_propagate_all : typer_state -> type_constraint selector_input list -> typer_state result =
let rec select_and_propagate_all : typer_state -> type_constraint selector_input list -> (typer_state,_) result =
fun { already_selected_and_propagators ; structured_dbs } new_constraints ->
match new_constraints with
| [] -> ok { already_selected_and_propagators ; structured_dbs }

173
src/passes/08-typer-new/typer.ml
View File

@ -7,16 +7,20 @@ module DEnv = Environment
module Environment = O.Environment
module Solver = Solver
type environment = Environment.t
module Errors = Errors
module Errors = Typer_common.Errors
open Errors
module Map = RedBlackTrees.PolyMap
open Todo_use_fold_generator
let assert_type_expression_eq ((tv',tv):O.type_expression * O.type_expression) : (unit,typer_error) result =
trace_option (assert_equal tv' tv) @@
O.assert_type_expression_eq (tv' , tv)
(*
Extract pairs of (name,type) in the declaration and add it to the environment
*)
let rec type_declaration env state : I.declaration -> (environment * O'.typer_state * O.declaration option) result = function
let rec type_declaration env state : I.declaration -> (environment * O'.typer_state * O.declaration option, typer_error) result = function
| Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
@ -27,17 +31,17 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st
*)
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind (expr , state') =
trace (constant_declaration_error binder expression tv'_opt) @@
trace (constant_declaration_tracer binder expression tv'_opt) @@
type_expression env state expression in
let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
)
and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state) result =
fun e state t i ae loc -> match i with
and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result =
fun e state t i _ae loc -> match i with
| Match_option {match_none ; match_some} ->
let%bind tv =
trace_strong (match_error ~expected:i ~actual:t loc)
trace_option (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind (match_none , state') = type_expression e state match_none in
let (opt, b) = match_some in
@ -46,7 +50,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
| Match_list {match_nil ; match_cons} ->
let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc)
trace_option (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in
let%bind (match_nil , state') = type_expression e state match_nil in
let (hd, tl, b) = match_cons in
@ -62,38 +66,31 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
Environment.get_constructor constructor_name e in
let%bind acc = match acc with
| None -> ok (Some variant)
| Some variant' -> (
trace (type_error
~msg:"in match variant"
~expected:variant
~actual:variant'
~expression:ae
loc
) @@
Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
| Some variant' ->
let%bind () = trace_option (not_matching variant variant') @@
Ast_typed.assert_type_expression_eq (variant , variant') in
ok (Some variant)
) in
in
ok acc in
trace (simple_info "in match variant") @@
trace (in_match_variant_tracer i) @@
bind_fold_list aux None lst in
let%bind variant =
trace_option (match_empty_variant i loc) @@
variant_opt in
let%bind () =
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
trace_option (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
Assert.assert_true (corner_case "match case") (List.mem c match_cases)
in
let%bind () =
trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in
let%bind () =
trace_strong (match_redundant_case i loc) @@
Assert.assert_true List.(length variant_cases = length match_cases) in
let%bind () = Assert.assert_true (match_redundant_case i loc) @@
List.(length variant_cases = length match_cases) in
ok ()
in
let%bind (state'' , cases) =
@ -113,7 +110,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
Recursively search the type_expression and return a result containing the
type_value at the leaves
*)
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
match t.type_content with
| T_arrow {type1;type2} ->
@ -146,40 +143,63 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| T_constant cst ->
return (T_constant (convert_type_constant cst))
| T_operator (op, lst) ->
let%bind opt = match op,lst with
( match op,lst with
| TC_set, [s] ->
let%bind s = evaluate_type e s in
ok @@ O.TC_set (s)
return @@ T_operator (O.TC_set s)
| TC_option, [o] ->
let%bind o = evaluate_type e o in
ok @@ O.TC_option (o)
return @@ T_operator (O.TC_option o)
| TC_list, [l] ->
let%bind l = evaluate_type e l in
ok @@ O.TC_list (l)
return @@ T_operator (O.TC_list l)
| TC_map, [k;v] ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map {k;v}
return @@ T_operator (O.TC_map {k;v})
| TC_big_map, [k;v] ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_big_map {k;v}
return @@ T_operator (O.TC_big_map {k;v})
| TC_map_or_big_map, [k;v] ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map_or_big_map {k;v}
return @@ T_operator (O.TC_map_or_big_map {k;v})
| TC_contract, [c] ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
| TC_michelson_pair_right_comb, _c | TC_michelson_pair_left_comb, _c
| TC_michelson_or_right_comb, _c | TC_michelson_or_left_comb, _c ->
(* not really sure what to do in the new typer, should be converted to a pair using functions defined in Helpers.Typer.Converter *)
simple_fail "to be implemented"
| _ -> fail @@ bad_type_operator t
in
return (T_operator (opt))
return @@ T_operator (O.TC_contract c)
| TC_michelson_pair_right_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in
let record = Typer_common.Michelson_type_converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_pair_left_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in
let record = Typer_common.Michelson_type_converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_or_right_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in
let pair = Typer_common.Michelson_type_converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
return @@ pair
| TC_michelson_or_left_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in
let pair = Typer_common.Michelson_type_converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
return @@ pair
| _ -> fail @@ unrecognized_type_op t
)
and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result = fun e state ?tv_opt ae ->
and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result = fun e state ?tv_opt ae ->
let () = ignore tv_opt in (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
let open Solver in
let module L = Logger.Stateful() in
@ -190,16 +210,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
let expr' = make_e ~location expr tv in
ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error =
let title () = "typing expression" in
let content () = "" in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("location" , fun () -> Format.asprintf "%a" Location.pp @@ ae.location) ;
("misc" , fun () -> L.get ()) ;
] in
error ~data title content in
trace main_error @@
trace (expression_tracer ae) @@
match ae.expression_content with
(* TODO: this file should take care only of the order in which program fragments
@ -271,19 +282,10 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
(* Sum *)
| E_constructor {constructor;element} ->
let%bind (c_tv, sum_tv) =
let error =
let title () = "no such constructor" in
let content () =
Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor constructor
O.Environment.PP.environment e
in
error title content in
trace_option error @@
let%bind (c_tv, sum_tv) = trace_option (unbound_constructor e constructor ae.location) @@
Environment.get_constructor constructor e in
let%bind (expr' , state') = type_expression e state element in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
let%bind _assert = assert_type_expression_eq (expr'.type_expression, c_tv) in
let wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
let constructor = convert_constructor' constructor in
return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped
@ -312,7 +314,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
)
| _ -> failwith "Update an expression which is not a record"
in
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
let%bind () = assert_type_expression_eq (tv, get_type_expression update) in
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *)
| E_application {lamb;args} ->
@ -381,7 +383,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
| E_constant {cons_name=name; arguments=lst} ->
let name = convert_constant' name in
let%bind t = Operators.Typer.Operators_types.constant_type name in
let%bind t = Typer_common.Constant_typers_new.Operators_types.constant_type name in
let aux acc expr =
let (lst , state) = acc in
let%bind (expr, state') = type_expression e state expr in
@ -416,14 +418,14 @@ and type_lambda e state {
let wrapped = Wrap.lambda fresh input_type' output_type' result.type_expression in
ok (({binder;result}:O.lambda),state',wrapped)
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression, Typer_common.Errors.typer_error) result =
let name = convert_constant' name in
let%bind typer = Operators.Typer.constant_typers name in
let%bind typer = Typer_common.Constant_typers.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
(* Apply type_declaration on every node of the AST_core from the root p *)
let type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program) result =
let type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program, Typer_common.Errors.typer_error) result =
let aux ((e : environment), (s : O'.typer_state) , (ds : O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
let%bind (e' , s' , d'_opt) = type_declaration e s (Location.unwrap d) in
let ds' = match d'_opt with
@ -433,12 +435,14 @@ let type_program_returns_state ((env, state, p) : environment * O'.typer_state *
ok (e' , s' , ds')
in
let%bind (env' , state' , declarations) =
trace (fun () -> program_error p ()) @@
trace (program_error_tracer p) @@
bind_fold_list aux (env , state , []) p in
let declarations = List.rev declarations in (* Common hack to have O(1) append: prepend and then reverse *)
ok (env', state', declarations)
let type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : 'b Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b) Trace.result) : ('b * O'.typer_state) result =
let type_and_subst_xyz
(env_state_node : environment * O'.typer_state * 'a) (apply_substs : ('b, Typer_common.Errors.typer_error) Typesystem.Misc.Substitution.Pattern.w)
(type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b, typer_error) Trace.result) : ('b * O'.typer_state, typer_error) result =
let%bind (env, state, node) = type_xyz_returns_state env_state_node in
let subst_all =
let aliases = state.structured_dbs.aliases in
@ -446,15 +450,16 @@ let type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (app
let substs : variable: I.type_variable -> _ = fun ~variable ->
to_option @@
let%bind root =
trace_option (simple_error (Format.asprintf "can't find alias root of variable %a" Var.pp variable)) @@
trace_option (corner_case (Format.asprintf "can't find alias root of variable %a" Var.pp variable)) @@
(* TODO: after upgrading UnionFind, this will be an option, not an exception. *)
try Some (Solver.UF.repr variable aliases) with Not_found -> None in
let%bind assignment =
trace_option (simple_error (Format.asprintf "can't find assignment for root %a" Var.pp root)) @@
trace_option (corner_case (Format.asprintf "can't find assignment for root %a" Var.pp root)) @@
(Map.find_opt root assignments) in
let O.{ tv ; c_tag ; tv_list } = assignment in
let () = ignore tv (* I think there is an issue where the tv is stored twice (as a key and in the element itself) *) in
let%bind (expr : O.type_content) = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.t_variable s ()) tv_list)) in
let%bind (expr : O.type_content) = trace_option (corner_case "wrong constant tag") @@
Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.t_variable s ()) tv_list)) in
ok @@ expr
in
let p = apply_substs ~substs node in
@ -463,17 +468,17 @@ let type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (app
let () = ignore env in (* TODO: shouldn't we use the `env` somewhere? *)
ok (node, state)
let type_program (p : I.program) : (O.program * O'.typer_state) result =
let type_program (p : I.program) : (O.program * O'.typer_state, typer_error) result =
let empty_env = DEnv.default in
let empty_state = Solver.initial_state in
type_and_subst_xyz (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
let type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression) Trace.result =
let type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) result =
fun (env, state, e) ->
let%bind (e , state) = type_expression env state e in
ok (env, state, e)
let type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state) result =
let type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state , typer_error) result =
let () = ignore tv_opt in (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
type_and_subst_xyz (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
@ -481,14 +486,14 @@ let untype_type_expression = Untyper.untype_type_expression
let untype_expression = Untyper.untype_expression
(* These aliases are just here for quick navigation during debug, and can safely be removed later *)
let [@warning "-32"] (*rec*) type_declaration _env _state : I.declaration -> (environment * O'.typer_state * O.declaration option) result = type_declaration _env _state
and [@warning "-32"] type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state) result = type_match
and [@warning "-32"] evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result = evaluate_type e t
and [@warning "-32"] type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result = type_expression
let [@warning "-32"] (*rec*) type_declaration _env _state : I.declaration -> (environment * O'.typer_state * O.declaration option, typer_error) result = type_declaration _env _state
and [@warning "-32"] type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result = type_match
and [@warning "-32"] evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result = evaluate_type e t
and [@warning "-32"] type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result = type_expression
and [@warning "-32"] type_lambda e state lam = type_lambda e state lam
and [@warning "-32"] type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result = type_constant name lst tv_opt
let [@warning "-32"] type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program) result = type_program_returns_state (env, state, p)
let [@warning "-32"] type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : 'b Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b) Trace.result) : ('b * O'.typer_state) result = type_and_subst_xyz env_state_node apply_substs type_xyz_returns_state
let [@warning "-32"] type_program (p : I.program) : (O.program * O'.typer_state) result = type_program p
let [@warning "-32"] type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression) Trace.result = type_expression_returns_state
let [@warning "-32"] type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state) result = type_expression_subst env state ?tv_opt e
and [@warning "-32"] type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression, typer_error) result = type_constant name lst tv_opt
let [@warning "-32"] type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program, typer_error) result = type_program_returns_state (env, state, p)
let [@warning "-32"] type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : ('b,typer_error) Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b, typer_error) result) : ('b * O'.typer_state, typer_error) result = type_and_subst_xyz env_state_node apply_substs type_xyz_returns_state
let [@warning "-32"] type_program (p : I.program) : (O.program * O'.typer_state, typer_error) result = type_program p
let [@warning "-32"] type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) Trace.result = type_expression_returns_state
let [@warning "-32"] type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state, typer_error) result = type_expression_subst env state ?tv_opt e

47
src/passes/08-typer-new/typer.mli
View File

@ -1,5 +1,7 @@
open Trace
open Typer_common.Errors
module Errors = Typer_common.Errors
module I = Ast_core
module O = Ast_typed
module O' = Typesystem.Solver_types
@ -10,41 +12,12 @@ module Solver = Solver
type environment = Environment.t
module Errors : sig
(*
val unbound_type_variable : environment -> string -> unit -> error
val unbound_variable : environment -> string -> Location.t -> unit -> error
val match_empty_variant : 'a I.matching -> Location.t -> unit -> error
val match_missing_case : 'a I.matching -> Location.t -> unit -> error
val match_redundant_case : 'a I.matching -> Location.t -> unit -> error
val unbound_constructor : environment -> string -> Location.t -> unit -> error
val unrecognized_constant : string -> Location.t -> unit -> error
*)
val wrong_arity : string -> int -> int -> Location.t -> unit -> error
(*
val match_tuple_wrong_arity : 'a list -> 'b list -> Location.t -> unit -> error
val type_program : I.program -> (O.program * O'.typer_state, typer_error) result
val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration option, typer_error) result
val evaluate_type : environment -> I.type_expression -> (O.type_expression, typer_error) result
val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression, typer_error) result
(* TODO: this should be a trace_info? *)
val program_error : I.program -> unit -> error
val constant_declaration_error : string -> I.expr -> O.type_value option -> unit -> error
val match_error : ?msg:string -> expected:'a I.matching -> actual:O.type_value -> Location.t -> unit -> error
val needs_annotation : I.expression -> string -> unit -> error
val type_error_approximate : ?msg:string -> expected:string -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
val type_error : ?msg:string -> expected:O.type_value -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
val bad_tuple_index : int -> I.expression -> O.type_value -> Location.t -> unit -> error
val bad_record_access : string -> I.expression -> O.type_value -> Location.t -> unit -> error
val not_supported_yet : string -> I.expression -> unit -> error
val not_supported_yet_untranspile : string -> O.expression -> unit -> error
val constant_error : Location.t -> O.type_value list -> O.type_value option -> unit -> error
*)
end
val type_program : I.program -> (O.program * O'.typer_state) result
val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration option) result
val evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
val untype_type_expression : O.type_expression -> I.type_expression result
val untype_expression : O.expression -> I.expression result
val untype_type_expression : O.type_expression -> (I.type_expression, typer_error) result
val untype_expression : O.expression -> (I.expression, typer_error) result

17
src/passes/08-typer-new/untyper.ml
View File

@ -1,4 +1,5 @@
open Trace
open Typer_common.Errors
module I = Ast_core
module O = Ast_typed
@ -140,15 +141,15 @@ let unconvert_constant' : O.constant' -> I.constant' = function
| C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
| C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB
let untype_type_value (t:O.type_expression) : (I.type_expression) result =
let untype_type_value (t:O.type_expression) : (I.type_expression, typer_error) result =
match t.type_meta with
| Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type"
| _ -> fail @@ corner_case "trying to untype generated type"
(*
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, typer_error) result =
(* TODO: or should we use t.core if present? *)
let%bind t = match t.type_content with
| O.T_sum x ->
@ -213,7 +214,7 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
(*
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, typer_error) result =
let open I in
match l with
| Literal_unit -> ok Literal_unit
@ -234,7 +235,7 @@ let untype_literal (l:O.literal) : I.literal result =
(*
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, typer_error) result =
let open I in
let return e = ok e in
match e.expression_content with
@ -290,8 +291,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind fun_type = untype_type_expression fun_type in
return @@ e_recursive fun_name fun_type lambda
and untype_lambda ty {binder; result} : I.lambda result =
let%bind io = get_t_function ty in
and untype_lambda ty {binder; result} : (I.lambda, typer_error) result =
let%bind io = trace_option (corner_case "TODO") @@ get_t_function ty in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression result in
ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda)
@ -299,7 +300,7 @@ and untype_lambda ty {binder; result} : I.lambda result =
(*
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, typer_error) result) -> O.matching_expr -> (I.matching_expr, typer_error) result = fun f m ->
let open I in
match m with
| Match_option {match_none ; match_some = {opt; body;tv=_}} ->

16
src/passes/08-typer-new/wrap.ml
View File

@ -1,4 +1,3 @@
open Trace
open Ast_typed.Misc
module Core = Typesystem.Core
@ -6,21 +5,6 @@ module I = Ast_core
module T = Ast_typed
module O = Core
module Errors = struct
let unknown_type_constructor (ctor : string) (te : T.type_expression) () =
let title = (thunk "unknown type constructor") in
(* TODO: sanitize the "ctor" argument before displaying it. *)
let message () = ctor in
let data = [
("ctor" , fun () -> ctor) ;
("expression" , fun () -> Format.asprintf "%a" T.PP.type_expression te) ;
(* ("location" , fun () -> Format.asprintf "%a" Location.pp te.location) *) (* TODO *)
] in
error ~data title message ()
end
type constraints = O.type_constraint list
(* let add_type state t = *)

1
src/passes/08-typer-old/dune
View File

@ -2,6 +2,7 @@
(name typer_old)
(public_name ligo.typer_old)
(libraries
typer_common
simple-utils
tezos-utils
ast_core

351
src/passes/08-typer-old/typer.ml
View File

@ -1,4 +1,5 @@
open Trace
open Typer_common.Errors
module I = Ast_core
module O = Ast_typed
@ -12,220 +13,7 @@ module Solver = Typer_new.Solver
type environment = Environment.t
module Errors = struct
let michelson_comb_no_record (loc:Location.t) () =
let title = (thunk "bad michelson_pair_right_comb type parameter") in
let message () = "michelson_pair_right_comb type operator must be used on a record type" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let michelson_comb_no_variant (loc:Location.t) () =
let title = (thunk "bad michelson_or_right_comb type parameter") in
let message () = "michelson_or_right_comb type operator must be used on a variant type" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let unbound_type_variable (e:environment) (tv:I.type_variable) (loc:Location.t) () =
let name = Var.to_name tv in
let suggestion = match name with
| "integer" -> "int"
| "str" -> "string"
| "boolean" -> "bool"
| _ -> "no suggestion" in
let title = (thunk "unbound type variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
("in" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
("did_you_mean" , fun () -> suggestion)
] in
error ~data title message ()
let unbound_variable (e:environment) (n:I.expression_variable) () =
let name () = Format.asprintf "%a" I.PP.expression_variable n in
let title = (thunk ("unbound variable "^(name ()))) in
let message () = "" in
let data = [
("variable" , name) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
] in
error ~data title message ()
let match_empty_variant : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "match with no cases") in
let message () = "" in
let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_missing_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let match_redundant_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "redundant case in match") in
let message () = "" in
let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let unbound_constructor (e:environment) (c:I.constructor') (loc:Location.t) () =
let title = (thunk "unbound constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let redundant_constructor (e:environment) (c:I.constructor') () =
let title = (thunk "redundant constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
] in
error ~data title message ()
let michelson_or (c:I.constructor') loc () =
let title = (thunk "michelson_or types must be annotated") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in
let message () = "" in
let data = [
("function" , fun () -> Format.asprintf "%s" n) ;
("expected" , fun () -> Format.asprintf "%d" expected) ;
("actual" , fun () -> Format.asprintf "%d" actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
(* TODO: this should be a trace_info? *)
let program_error (p:I.program) () =
let message () = "" in
let title = (thunk "typing program") in
let data = [
("program" , fun () -> Format.asprintf "%a" I.PP.program p)
] in
error ~data title message ()
let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
let title = (thunk "typing constant declaration") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ;
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
None -> "(no annotation for the expected type)"
| Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in
error ~data title message ()
let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let needs_annotation (e : I.expression) (case : string) () =
let title = (thunk "this expression must be annotated with its type") in
let message () = Format.asprintf "%s needs an annotation" case in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
] in
error ~data title message ()
let fvs_in_create_contract_lambda (e : I.expression) (fvar : Ast_typed.expression_variable) () =
let title = (thunk "No free variable allowed in this lambda") in
let message () = Format.asprintf "variable '%a'" Var.pp fvar in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
] in
error ~data title message ()
let create_contract_lambda (cst : I.constant') (e : I.expression) () =
let title () = Format.asprintf "%a first argument must be inlined" I.PP.constant cst in
let message () = Format.asprintf "contract code can be inlined using a lambda" in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
] in
error ~data title message ()
let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
let title = (thunk "type error") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%s" expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let _type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
let title = (thunk "type error") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_expression) (loc:Location.t) () =
let title = (thunk "invalid record field") in
let message () = "" in
let data = [
("field" , fun () -> Format.asprintf "%a" I.PP.label field) ;
("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_expression t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
let message () = "" in
error title message
end
open Errors
let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq
let convert_constructor' (I.Constructor c) = O.Constructor c
let unconvert_constructor' (O.Constructor c) = I.Constructor c
@ -484,7 +272,7 @@ let unconvert_constant' : O.constant' -> I.constant' = function
| C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
| C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB
let rec type_program (p:I.program) : (O.program * O'.typer_state) result =
let rec type_program (p:I.program) : (O.program * O'.typer_state, typer_error) result =
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in
let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in
@ -492,11 +280,12 @@ let rec type_program (p:I.program) : (O.program * O'.typer_state) result =
ok (e', loc ed' d' :: acc)
in
let%bind (_, lst) =
trace (fun () -> program_error p ()) @@
trace (program_error_tracer p) @@
bind_fold_list aux (DEnv.default, []) p in
ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ()))
and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state) : I.declaration -> (environment * O'.typer_state * O.declaration) result = function
and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state) : I.declaration -> (environment * O'.typer_state * O.declaration, typer_error) result = function
| Declaration_type (type_binder , type_expr) ->
let%bind tv = evaluate_type env type_expr in
let env' = Environment.add_type (type_binder) tv env in
@ -504,17 +293,17 @@ and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state)
| Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@
trace (constant_declaration_error_tracer binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
)
and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
and type_match : (environment -> I.expression -> (O.expression , typer_error) result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr, typer_error) result =
fun f e t i _ae loc -> match i with
| Match_option {match_none ; match_some} ->
let%bind tv =
trace_strong (match_error ~expected:i ~actual:t loc)
trace_option (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind match_none = f e match_none in
let (opt, b) = match_some in
@ -523,7 +312,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
| Match_list {match_nil ; match_cons} ->
let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc)
trace_option (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in
let%bind match_nil = f e match_nil in
let (hd, tl, b) = match_cons in
@ -533,19 +322,18 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
| Match_variant lst ->
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
trace_option (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum t in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
Assert.assert_true (corner_case "match case") (List.mem c match_cases)
in
let%bind () =
trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in
let%bind () =
trace_strong (match_redundant_case i loc) @@
Assert.assert_true List.(length variant_cases = length match_cases) in
Assert.assert_true (match_redundant_case i loc) List.(length variant_cases = length match_cases) in
let%bind cases =
let aux ((constructor_name , pattern) , b) =
let%bind {ctor_type=constructor;_} =
@ -559,7 +347,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
bind_map_list aux lst in
ok (O.Match_variant { cases ; tv=t })
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
match t.type_content with
| T_arrow {type1;type2} ->
@ -574,7 +362,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| Some _ ->
if I.CMap.mem (Constructor "M_left") m || I.CMap.mem (Constructor "M_right") m then
ok ()
else fail (redundant_constructor e k)
else fail (redundant_constructor e k t.location)
| None -> ok () in
let v' : O.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
ok @@ O.CMap.add (convert_constructor' k) v' prev'
@ -627,61 +415,52 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in
let record = Operators.Typer.Converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
let record = Typer_common.Michelson_type_converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_pair_left_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in
let record = Operators.Typer.Converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
let record = Typer_common.Michelson_type_converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
return @@ record
| TC_michelson_or_right_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in
let pair = Operators.Typer.Converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
let pair = Typer_common.Michelson_type_converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
return @@ pair
| TC_michelson_or_left_comb, [c] ->
let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in
let pair = Operators.Typer.Converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
let pair = Typer_common.Michelson_type_converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
return @@ pair
| _ -> fail @@ bad_type_operator t
| _ -> fail @@ unrecognized_type_op t
)
and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ()))
and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae ->
and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> (O.expression, typer_error) result = fun e ?tv_opt ae ->
let module L = Logger.Stateful() in
let return expr tv =
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , tv) in
| Some tv' -> assert_type_expression_eq (tv' , tv) in
let location = ae.location in
ok @@ make_e ~location expr tv in
let main_error =
let title () = "typing expression" in
let content () = "" in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) ;
("misc" , fun () -> L.get ()) ;
] in
error ~data title content in
trace main_error @@
trace (expression_tracer ae) @@
match ae.expression_content with
(* Basic *)
| E_variable name ->
let%bind tv' =
trace_option (unbound_variable e name)
trace_option (unbound_variable e name ae.location)
@@ Environment.get_opt name e in
return (E_variable name) tv'.type_value
| E_literal Literal_unit ->
@ -713,49 +492,41 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (e_operation op) (t_operation ())
| E_record_accessor {record;path} ->
let%bind e' = type_expression' e record in
let aux (prev:O.expression) (a:I.label) : O.expression result =
let aux (prev:O.expression) (a:I.label) : (O.expression , typer_error) result =
let property = a in
let%bind r_tv = get_t_record prev.type_expression in
let%bind r_tv = trace_option (bad_record_access property ae prev.type_expression ae.location) @@
get_t_record prev.type_expression in
let%bind tv =
generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in
trace_option (bad_record_access property ae prev.type_expression ae.location) @@
O.LMap.find_opt (convert_label property) r_tv in
let location = ae.location in
ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv
ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv.field_type
in
let%bind ae =
trace (simple_info "accessing") @@ aux e' path in
trace (record_access_tracer e') @@ aux e' path in
(* check type annotation of the final accessed element *)
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in
| Some tv' -> assert_type_expression_eq (tv' , ae.type_expression) in
ok(ae)
| E_constructor {constructor = Constructor s ; element} when String.equal s "M_left" || String.equal s "M_right" -> (
let%bind t = trace_option (Errors.michelson_or (Constructor s) ae.location) @@ tv_opt in
let%bind t = trace_option (michelson_or (Constructor s) ae.location) @@ tv_opt in
let%bind expr' = type_expression' e element in
( match t.type_content with
| T_sum c ->
let {ctor_type ; _} : O.ctor_content = O.CMap.find (O.Constructor s) c in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, ctor_type) in
let%bind () = assert_type_expression_eq (expr'.type_expression, ctor_type) in
return (E_constructor {constructor = Constructor s; element=expr'}) t
| _ -> simple_fail "ll"
| _ -> fail (michelson_or (Constructor s) ae.location)
)
)
(* Sum *)
| E_constructor {constructor; element} ->
let%bind (c_tv, sum_tv) =
let error =
let title () = "no such constructor" in
let content () =
Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor constructor
O.Environment.PP.environment e
in
error title content in
trace_option error @@
let%bind (c_tv, sum_tv) = trace_option (unbound_constructor e constructor ae.location) @@
Environment.get_constructor constructor e in
let%bind expr' = type_expression' e element in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
let%bind _assert = assert_type_expression_eq (expr'.type_expression, c_tv) in
let constructor = convert_constructor' constructor in
return (E_constructor {constructor; element=expr'}) sum_tv
(* Record *)
@ -765,9 +536,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
ok (O.LMap.add (convert_label k) expr' prev)
in
let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok O.LMap.empty) m in
(* let () = match tv_opt with
Some _ -> Format.printf "YES"
| None -> Format.printf "NO" in *)
let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None; field_decl_pos=0}:O.field_content)) m' in
return (E_record m') (t_record lmap ())
| E_record_update {record; path; update} ->
@ -785,7 +553,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
)
| _ -> failwith "Update an expression which is not a record"
in
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
let%bind () = assert_type_expression_eq (tv, get_type_expression update) in
return (E_record_update {record; path; update}) wrapped
(* Data-structure *)
| E_lambda lambda ->
@ -801,7 +569,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
collect ;
init_record ;
]} ->
(* this special case is here force annotation of the untyped lambda
(* this special case is here to force annotation of the untyped lambda
generated by pascaligo's for_collect loop *)
let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in
let tv_col = get_type_expression v_col in (* this is the type of the collection *)
@ -809,10 +577,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind input_type = match tv_col.type_content with
| O.T_operator ( TC_list t | TC_set t) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",t)])
| O.T_operator ( TC_map {k;v}| TC_big_map {k;v}) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])])
| _ ->
let wtype = Format.asprintf
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in
fail @@ simple_error wtype in
| _ -> fail @@ bad_collect_loop tv_col ae.location in
let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_expression in
@ -896,14 +661,12 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind args' = type_expression' e args in
let%bind tv = match lamb'.type_expression.type_content with
| T_arrow {type1;type2} ->
let%bind _ = O.assert_type_expression_eq (type1, args'.type_expression) in
let%bind _ = assert_type_expression_eq (type1, args'.type_expression) in
ok type2
| _ ->
fail @@ type_error_approximate
~expected:"should be a function type"
~expression:lamb
~actual:lamb'.type_expression
lamb'.location
in
return (E_application {lamb=lamb'; args=args'}) tv
(* Advanced *)
@ -921,7 +684,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind () =
match prec with
| None -> ok ()
| Some cur' -> Ast_typed.assert_type_expression_eq (cur , cur') in
| Some cur' -> assert_type_expression_eq (cur , cur') in
ok (Some cur) in
let%bind tv_opt = bind_fold_list aux None tvs in
let%bind tv =
@ -937,7 +700,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind let_result = type_expression' e' let_result in
return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
| E_raw_code {language;code} ->
let%bind (code,type_expression) = I.get_e_ascription code.expression_content in
let%bind (code,type_expression) = trace_option (expected_ascription code) @@
I.get_e_ascription code.expression_content in
let%bind code = type_expression' e code in
let%bind type_expression = evaluate_type e type_expression in
let code = {code with type_expression} in
@ -951,15 +715,16 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind tv = evaluate_type e type_annotation in
let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in
let%bind type_annotation =
trace_option (corner_case "merge_annotations (Some ...) (Some ...) failed") @@
O.merge_annotation
(Some tv)
(Some expr'.type_expression)
(internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in
O.assert_type_expression_eq in
(* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , type_annotation) in
| Some tv' -> assert_type_expression_eq (tv' , type_annotation) in
ok {expr' with type_expression=type_annotation}
and type_lambda e {
@ -999,18 +764,18 @@ and type_lambda e {
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression , typer_error) result =
let name = convert_constant' name in
let%bind typer = Operators.Typer.constant_typers name in
let%bind typer = Typer_common.Constant_typers.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
ok (name, tv)
let untype_type_expression (t:O.type_expression) : (I.type_expression) result =
let untype_type_expression (t:O.type_expression) : (I.type_expression , typer_error) result =
match t.type_meta with
| Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type"
| _ -> fail @@ corner_case "Trying to untype generated type"
let untype_literal (l:O.literal) : I.literal result =
let untype_literal (l:O.literal) : (I.literal , typer_error) result =
let open I in
match l with
| Literal_unit -> ok Literal_unit
@ -1029,9 +794,9 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_address s -> ok (Literal_address s)
| Literal_operation s -> ok (Literal_operation s)
let rec untype_expression (e:O.expression) : (I.expression) result =
let rec untype_expression (e:O.expression) : (I.expression , typer_error) result =
untype_expression_content e.type_expression e.expression_content
and untype_expression_content ty (ec:O.expression_content) : (I.expression) result =
and untype_expression_content ty (ec:O.expression_content) : (I.expression , typer_error) result =
let open I in
let return e = ok e in
match ec with
@ -1048,7 +813,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind arg' = untype_expression args in
return (e_application f' arg')
| E_lambda {binder ; result} -> (
let%bind io = get_t_function ty in
let io = get_t_function_exn ty in
let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in
let%bind result = untype_expression result in
return (e_lambda (binder) (Some input_type) (Some output_type) result)
@ -1087,7 +852,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let lambda = match unty_expr.expression_content with I.E_lambda l -> l | _ -> failwith "impossible case" in
return @@ e_recursive fun_name fun_type lambda
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
and untype_matching : (O.expression -> (I.expression , typer_error) result) -> O.matching_expr -> (I.matching_expr , typer_error) result = fun f m ->
let open I in
match m with
| Match_option {match_none ; match_some = {opt; body ; tv=_}} ->

43
src/passes/08-typer-old/typer.mli
View File

@ -1,3 +1,4 @@
open Typer_common.Errors
open Trace
module I = Ast_core
@ -10,46 +11,16 @@ module Solver : module type of Typer_new.Solver
type environment = Environment.t
module Errors : sig
(*
val unbound_type_variable : environment -> string -> unit -> error
val unbound_variable : environment -> string -> Location.t -> unit -> error
val match_empty_variant : 'a I.matching -> Location.t -> unit -> error
val match_missing_case : 'a I.matching -> Location.t -> unit -> error
val match_redundant_case : 'a I.matching -> Location.t -> unit -> error
val unbound_constructor : environment -> string -> Location.t -> unit -> error
val unrecognized_constant : string -> Location.t -> unit -> error
*)
val wrong_arity : string -> int -> int -> Location.t -> unit -> error
(*
val match_tuple_wrong_arity : 'a list -> 'b list -> Location.t -> unit -> error
(* TODO: this should be a trace_info? *)
val program_error : I.program -> unit -> error
val constant_declaration_error : string -> I.expr -> O.type_value option -> unit -> error
val match_error : ?msg:string -> expected:'a I.matching -> actual:O.type_value -> Location.t -> unit -> error
val needs_annotation : I.expression -> string -> unit -> error
val type_error_approximate : ?msg:string -> expected:string -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
val type_error : ?msg:string -> expected:O.type_value -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
val bad_tuple_index : int -> I.expression -> O.type_value -> Location.t -> unit -> error
val bad_record_access : string -> I.expression -> O.type_value -> Location.t -> unit -> error
val not_supported_yet : string -> I.expression -> unit -> error
val not_supported_yet_untranspile : string -> O.expression -> unit -> error
val constant_error : Location.t -> O.type_value list -> O.type_value option -> unit -> error
*)
end
val type_program : I.program -> (O.program * O'.typer_state) result
val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration) result
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
val type_program : I.program -> (O.program * O'.typer_state , typer_error) result
val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration , typer_error) result
val evaluate_type : environment -> I.type_expression -> (O.type_expression , typer_error) result
val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state , typer_error) result
val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression , typer_error) result
(*
val untype_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result
*)
val untype_expression : O.expression -> I.expression result
val untype_expression : O.expression -> (I.expression , typer_error) result
(*
val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
*)

6
src/passes/08-typer/typer.ml
View File

@ -3,6 +3,7 @@ let use_new_typer = false
module I = Ast_core
module O = Ast_typed
module O' = Typesystem.Solver_types
module Errors = Typer_common.Errors
module Environment = O.Environment
@ -10,6 +11,9 @@ module Solver = Typer_new.Solver (* Both the old typer and the new typer use the
type environment = Environment.t
let type_program = if use_new_typer then Typer_new.type_program else Typer_old.type_program
(* let type_program = if use_new_typer then Typer_new.type_program else Typer_old.type_program *)
let type_program = Typer_old.type_program
let type_expression_subst = if use_new_typer then Typer_new.type_expression_subst else Typer_old.type_expression (* the old typer does not have unification variables that would need substitution, so no need to "subst" anything. *)
let untype_expression = if use_new_typer then Typer_new.untype_expression else Typer_old.untype_expression
let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq

10
src/passes/08-typer/typer.mli
View File

@ -5,13 +5,15 @@ open Trace
module I = Ast_core
module O = Ast_typed
module O' = Typesystem.Solver_types
module Environment = O.Environment
module Errors = Typer_common.Errors
module Solver = Typer_new.Solver
type environment = Environment.t
val type_program : I.program -> (O.program * O'.typer_state) result
val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
val untype_expression : O.expression -> I.expression result
val type_program : I.program -> (O.program * O'.typer_state, Errors.typer_error) result
val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state , Errors.typer_error) result
val untype_expression : O.expression -> (I.expression , Errors.typer_error) result
val assert_type_expression_eq : O.type_expression * O.type_expression -> (unit, Errors.typer_error) result

40
src/passes/09-self_ast_typed/contract_passes.ml
View File

@ -1,3 +1,4 @@
open Errors
open Ast_typed.Types
open Trace
@ -6,41 +7,6 @@ type contract_pass_data = {
main_name : string ;
}
module Errors = struct
let bad_self_type expected got loc () =
let title = thunk "bad self type" in
let message () = Format.asprintf "expected %a but got %a" Ast_typed.PP.type_expression expected Ast_typed.PP.type_expression got in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_format_entrypoint_ann ep loc () =
let title = thunk "bad entrypoint format" in
let message () = Format.asprintf "entrypoint \"%s\" is badly formatted. We expect \"%%bar\" for entrypoint Bar and \"%%default\" when no entrypoint used" ep in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let entrypoint_annotation_not_literal loc () =
let title = thunk "entrypoint annotation must be a string literal" in
let message () = Format.asprintf "" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
let unmatched_entrypoint loc () =
let title = thunk "No constructor matches the entrypoint annotation" in
let message () = Format.asprintf "" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
] in
error ~data title message ()
end
let check_entrypoint_annotation_format ep (exp: expression) =
match String.split_on_char '%' ep with
| [ "" ; ep'] ->
@ -50,7 +16,7 @@ let check_entrypoint_annotation_format ep (exp: expression) =
| _ -> fail @@ Errors.bad_format_entrypoint_ann ep exp.location
let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression) result = fun dat e ->
let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression , self_ast_typed_error) result = fun dat e ->
let bad_self_err () = Errors.bad_self_type
e.type_expression
{e.type_expression with type_content = T_operator (TC_contract dat.contract_type.parameter)}
@ -68,7 +34,7 @@ let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data
ok ctor_type
| t -> ok {dat.contract_type.parameter with type_content = t} in
let%bind () =
trace_strong (bad_self_err ()) @@
trace_option (bad_self_err ()) @@
Ast_typed.assert_type_expression_eq (entrypoint_t , t) in
ok (true, dat, e)
| _ -> ok (true,dat,e)

257
src/passes/09-self_ast_typed/errors.ml Normal file
View File

@ -0,0 +1,257 @@
open Simple_utils.Display
open Trace
let stage = "self_ast_typed"
type self_ast_typed_error = [
| `Self_ast_typed_rec_call of Ast_typed.expression_variable * Location.t
| `Self_ast_typed_bad_self_type of Ast_typed.type_expression * Ast_typed.type_expression * Location.t
| `Self_ast_typed_format_entrypoint_ann of string * Location.t
| `Self_ast_typed_entrypoint_ann_not_literal of Location.t
| `Self_ast_typed_unmatched_entrypoint of Location.t
| `Self_ast_typed_nested_big_map of Location.t
| `Self_ast_typed_corner_case of string
| `Self_ast_typed_contract_io of string * Ast_typed.expression
| `Self_ast_typed_contract_list_ops of string * Ast_typed.type_expression * Ast_typed.expression
| `Self_ast_typed_expected_same_entry of
string * Ast_typed.type_expression * Ast_typed.type_expression * Ast_typed.expression
| `Self_ast_typed_pair_in of Location.t
| `Self_ast_typed_pair_out of Location.t
]
let recursive_call_is_only_allowed_as_the_last_operation name loc =
`Self_ast_typed_rec_call (name,loc)
let bad_self_type expected got loc =
`Self_ast_typed_bad_self_type (expected,got,loc)
let bad_format_entrypoint_ann ep loc =
`Self_ast_typed_format_entrypoint_ann (ep,loc)
let entrypoint_annotation_not_literal loc =
`Self_ast_typed_entrypoint_ann_not_literal loc
let unmatched_entrypoint loc =
`Self_ast_typed_unmatched_entrypoint loc
let nested_bigmap loc = `Self_ast_typed_nested_big_map loc
let corner_case s = `Self_ast_typed_corner_case s
let bad_contract_io entrypoint e = `Self_ast_typed_contract_io (entrypoint, e)
let expected_list_operation entrypoint got e =
`Self_ast_typed_contract_list_ops (entrypoint, got, e)
let expected_same entrypoint t1 t2 e =
`Self_ast_typed_expected_same_entry (entrypoint,t1,t2,e)
let expected_pair_in loc = `Self_ast_typed_pair_in loc
let expected_pair_out loc = `Self_ast_typed_pair_out loc
let error_ppformat : display_format:string display_format ->
Format.formatter -> self_ast_typed_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Self_ast_typed_rec_call (_name,loc) ->
Format.fprintf f
"@[<hv>%a@ Recursion must be achieved through tail-calls only@]"
Location.pp loc
| `Self_ast_typed_bad_self_type (expected,got,loc) ->
Format.fprintf f
"@[<hv>%a@ Bad self type@ expected %a@ got %a@]"
Location.pp loc
Ast_typed.PP.type_expression expected
Ast_typed.PP.type_expression got
| `Self_ast_typed_format_entrypoint_ann (ep,loc) ->
Format.fprintf f
"@[<hv>%a@ Bad entrypoint format '%s'@ We expect '%%bar' for entrypoint Bar and '%%default' when no entrypoint used"
Location.pp loc
ep
| `Self_ast_typed_entrypoint_ann_not_literal loc ->
Format.fprintf f
"@[<hv>%a@ Entrypoint annotation must be a string literal@]"
Location.pp loc
| `Self_ast_typed_unmatched_entrypoint loc ->
Format.fprintf f
"@[<hv>%a@ No constructor matches the entrypoint annotation@]"
Location.pp loc
| `Self_ast_typed_nested_big_map loc ->
Format.fprintf f
"@[<hv>%a@ It looks like you have nested a big map inside another big map, this is not supported@]"
Location.pp loc
| `Self_ast_typed_corner_case desc ->
Format.fprintf f
"@[<hv>Internal error: %s @]"
desc
| `Self_ast_typed_contract_io (_entrypoint, e) ->
Format.fprintf f
"@[<hv>%a@ Badly typed contract:@ unexpected entrypoint type %a@]"
Location.pp e.location
Ast_typed.PP.type_expression e.type_expression
| `Self_ast_typed_contract_list_ops (_entrypoint, got, e) ->
Format.fprintf f
"@[<hv>%a@ Badly typed contract:@ expected %a but got %a@]"
Location.pp e.location
Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}
Ast_typed.PP.type_expression got
| `Self_ast_typed_expected_same_entry (entrypoint,t1,t2,e) ->
Format.fprintf f
"@[<hv>%a@ Badly typed contract %s:@ expected storage type as right member of a pair in the input and output, \
but got:@ - %a in the input@ - %a in the output @]"
Location.pp e.location
entrypoint
Ast_typed.PP.type_expression t1
Ast_typed.PP.type_expression t2
| `Self_ast_typed_pair_in loc ->
Format.fprintf f
"@[<hv>%a@ Badly typed contract:@ expected a pair as parameter@]"
Location.pp loc
| `Self_ast_typed_pair_out loc ->
Format.fprintf f
"@[<hv>%a@ Badly typed contract:@ expected a pair as return type@]"
Location.pp loc
)
let error_jsonformat : self_ast_typed_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Self_ast_typed_rec_call (name,loc) ->
let message = `String "recursion must be achieved through tail-calls only" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let fn = `String (Format.asprintf "%a" Ast_typed.PP.expression_variable name) in
let content = `Assoc [
("message", message);
("location", loc);
("function", fn);
]
in
json_error ~stage ~content
| `Self_ast_typed_bad_self_type (expected,got,loc) ->
let message = `String "bad self type" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let expected = `String (Format.asprintf "%a" Ast_typed.PP.type_expression expected) in
let actual = `String (Format.asprintf "%a" Ast_typed.PP.type_expression got) in
let content = `Assoc [
("message", message);
("location", loc);
("expected", expected);
("actual", actual);
]
in
json_error ~stage ~content
| `Self_ast_typed_format_entrypoint_ann (ep,loc) ->
let message = `String "bad entrypoint format" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let entrypoint = `String ep in
let hint = `String "we expect '%%bar' for entrypoint Bar and '%%default' when no entrypoint used" in
let content = `Assoc [
("message", message);
("location", loc);
("hint", hint);
("entrypoint", entrypoint);
]
in
json_error ~stage ~content
| `Self_ast_typed_entrypoint_ann_not_literal loc ->
let message = `String "entrypoint annotation must be a string literal" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let content = `Assoc [
("message", message);
("location", loc);
]
in
json_error ~stage ~content
| `Self_ast_typed_unmatched_entrypoint loc ->
let message = `String "no constructor matches the entrypoint annotation" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let content = `Assoc [
("message", message);
("location", loc);
]
in
json_error ~stage ~content
| `Self_ast_typed_nested_big_map loc ->
let message = `String "it looks like you have nested a big map inside another big map, this is not supported" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let content = `Assoc [
("message", message);
("location", loc);
]
in
json_error ~stage ~content
| `Self_ast_typed_corner_case desc ->
let message = `String "internal error" in
let description = `String desc in
let content = `Assoc [
("message", message);
("description", description);
]
in
json_error ~stage ~content
| `Self_ast_typed_contract_io (entrypoint, e) ->
let message = `String "badly typed contract" in
let description = `String "unexpected entrypoint type" in
let entrypoint = `String entrypoint in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let eptype = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression) in
let content = `Assoc [
("message", message);
("description", description);
("entrypoint", entrypoint);
("location", loc);
("type", eptype);
]
in
json_error ~stage ~content
| `Self_ast_typed_contract_list_ops (entrypoint, got, e) ->
let entrypoint = `String entrypoint in
let message = `String "badly typed contract" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let actual = `String (Format.asprintf "%a"
Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}) in
let expected = `String (Format.asprintf "%a" Ast_typed.PP.type_expression got) in
let content = `Assoc [
("message", message);
("entrypoint", entrypoint);
("location", loc);
("expected", expected);
("actual", actual);
]
in
json_error ~stage ~content
| `Self_ast_typed_expected_same_entry (entrypoint,t1,t2,e) ->
let entrypoint = `String entrypoint in
let message = `String "badly typed contract" in
let description = `String "expected storages" in
let loc = `String (Format.asprintf "%a" Location.pp e.location) in
let t1 = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t1) in
let t2 = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t2) in
let content = `Assoc [
("entrypoint", entrypoint);
("message", message);
("location", loc);
("description", description);
("type1", t1);
("type2", t2);
]
in
json_error ~stage ~content
| `Self_ast_typed_pair_in loc ->
let message = `String "badly typed contract" in
let description = `String "expected a pair as parameter" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let content = `Assoc [
("message", message);
("location", loc);
("description", description);
]
in
json_error ~stage ~content
| `Self_ast_typed_pair_out loc ->
let message = `String "badly typed contract" in
let description = `String "expected a pair as return type" in
let loc = `String (Format.asprintf "%a" Location.pp loc) in
let content = `Assoc [
("message", message);
("location", loc);
("description", description);
]
in
json_error ~stage ~content

77
src/passes/09-self_ast_typed/helpers.ml
View File

@ -1,9 +1,10 @@
open Errors
open Ast_typed
open Trace
open Ast_typed.Helpers
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun f init e ->
type ('a ,'err) folder = 'a -> expression -> ('a , 'err) result
let rec fold_expression : ('a , self_ast_typed_error) folder -> 'a -> expression -> ('a , self_ast_typed_error) result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
@ -51,7 +52,7 @@ let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun
ok res
)
and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
and fold_cases : ('a , 'err) folder -> 'a -> matching_expr -> ('a , 'err) result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = {hd=_; tl=_ ; body; tv=_} } -> (
let%bind res = fold_expression f init match_nil in
@ -71,8 +72,8 @@ and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init
ok res
)
type mapper = expression -> expression result
let rec map_expression : mapper -> expression -> expression result = fun f e ->
type 'err mapper = expression -> (expression , 'err) result
let rec map_expression : self_ast_typed_error mapper -> expression -> (expression , self_ast_typed_error) result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
@ -124,7 +125,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
| E_literal _ | E_variable _ | E_raw_code _ as e' -> return e'
and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
and map_cases : self_ast_typed_error mapper -> matching_expr -> (matching_expr , self_ast_typed_error) result = fun f m ->
match m with
| Match_list { match_nil ; match_cons = {hd ; tl ; body ; tv} } -> (
let%bind match_nil = map_expression f match_nil in
@ -145,7 +146,7 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
ok @@ Match_variant {cases ; tv}
)
and map_program : mapper -> program -> program result = fun m p ->
and map_program : self_ast_typed_error mapper -> program -> (program, self_ast_typed_error) result = fun m p ->
let aux = fun (x : declaration) ->
match x with
| Declaration_constant {binder; expr ; inline} -> (
@ -156,8 +157,8 @@ and map_program : mapper -> program -> program result = fun m p ->
in
bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
type ('a , 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression , 'err) result
let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a * expression , 'err) result = fun f a e ->
let self = fold_map_expression f in
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
@ -211,7 +212,7 @@ let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * e
)
| E_literal _ | E_variable _ | E_raw_code _ as e' -> ok (init', return e')
and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
and fold_map_cases : ('a , self_ast_typed_error) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr , self_ast_typed_error) result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = { hd ; tl ; body ; tv } } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
@ -232,7 +233,7 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin
ok @@ (init, Match_variant {cases ; tv})
)
and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
and fold_map_program : ('a, self_ast_typed_error) fold_mapper -> 'a -> program -> ('a * program , self_ast_typed_error) result = fun m init p ->
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with
| Declaration_constant {binder ; expr ; inline} -> (
@ -247,50 +248,12 @@ and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) re
in
bind_fold_list aux (init,[]) p
module Errors = struct
let bad_contract_io entrypoint (e:expression) () =
let title = thunk "badly typed contract" in
let message () = Format.asprintf "unexpected entrypoint type" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
("entrypoint" , fun () -> entrypoint);
("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression)
] in
error ~data title message ()
let expected_list_operation entrypoint got (e:expression) () =
let title = thunk "bad return type" in
let message () = Format.asprintf "expected %a, got %a"
Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}
Ast_typed.PP.type_expression got
in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
("entrypoint" , fun () -> entrypoint)
] in
error ~data title message ()
let expected_same entrypoint t1 t2 (e:expression) () =
let title = thunk "badly typed contract" in
let message () = Format.asprintf "expected {%a} and {%a} to be the same in the entrypoint type"
Ast_typed.PP.type_expression t1
Ast_typed.PP.type_expression t2
in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
("entrypoint" , fun () -> entrypoint);
("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression)
] in
error ~data title message ()
end
type contract_type = {
parameter : Ast_typed.type_expression ;
storage : Ast_typed.type_expression ;
}
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program ->
let aux declt = match Location.unwrap declt with
| Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
if String.equal (Var.to_name binder) main_fname
@ -300,7 +263,7 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f
in
let main_decl_opt = List.find_map aux @@ List.rev program in
let%bind main_decl =
trace_option (simple_error ("Entrypoint '"^main_fname^"' does not exist")) @@
trace_option (corner_case ("Entrypoint '"^main_fname^"' does not exist")) @@
main_decl_opt
in
let { binder=_ ; expr ; inline=_ } = main_decl in
@ -308,14 +271,14 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f
| T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
let%bind (parameter,storage) = trace_option (expected_pair_in expr.location) @@ Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = trace_option (expected_pair_out expr.location) @@ Ast_typed.Helpers.get_pair tout in
let%bind () = trace_option (expected_list_operation main_fname listop expr) @@
Ast_typed.assert_t_list_operation listop in
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
let%bind () = trace_option (expected_same main_fname storage storage' expr) @@
Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *)
ok { parameter ; storage }
| _ -> fail @@ Errors.bad_contract_io main_fname expr
| _ -> fail @@ bad_contract_io main_fname expr
)
| _ -> fail @@ Errors.bad_contract_io main_fname expr
| _ -> fail @@ bad_contract_io main_fname expr

23
src/passes/09-self_ast_typed/michelson_layout.ml
View File

@ -1,3 +1,4 @@
open Errors
open Ast_typed
open Trace
@ -145,7 +146,7 @@ let rec from_left_comb_record
let from_left_comb prev src_lmap dst_kvl conv_map =
from_left_comb_record prev src_lmap (List.rev dst_kvl) conv_map
let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : expression result =
let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : (expression, self_ast_typed_error) result =
match matchee_t , bodies with
| [m] , bl::br::[] ->
let cases = [
@ -166,9 +167,9 @@ let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bod
pattern = Var.of_name "x";
body } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
| _ -> simple_fail "corner case"
| _ -> fail @@ corner_case "from_right_comb conversion"
let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : expression result =
let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : (expression , self_ast_typed_error) result =
match matchee_t , bodies with
| [m] , bl::br::[] ->
let cases = [
@ -189,14 +190,14 @@ let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodi
pattern = Var.of_name "x";
body } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
| _ -> simple_fail "corner case"
| _ -> fail @@ corner_case "from_left_comb conversion"
(**
converts pair/record of a given layout to record/pair to another
- foo = (a,(b,(c,d))) -> foo_converted = { a=foo.0 ; b=foo.1.0 ; c=foo.1.1.0 ; d=foo.1.1.1 }
- foo = M_left(a) -> foo_converted = match foo with M_left x -> Foo x | M_right x -> Bar x
**)
let peephole_expression : expression -> expression result = fun e ->
let peephole_expression : expression -> (expression , self_ast_typed_error) result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_constant {cons_name= (C_CONVERT_TO_LEFT_COMB);arguments= [ to_convert ] } -> (
@ -205,7 +206,7 @@ let peephole_expression : expression -> expression result = fun e ->
let src_kvl = to_sorted_kv_list_l src_lmap in
return @@ E_record (to_left_comb_record to_convert src_kvl LMap.empty)
| T_sum src_cmap ->
let%bind dst_cmap = get_t_sum e.type_expression in
let%bind dst_cmap = trace_option (corner_case "to_left_comb conversion") @@ get_t_sum e.type_expression in
let src_kvl = to_sorted_kv_list_c src_cmap in
let bodies = left_comb_variant_combination e dst_cmap src_kvl in
let to_cases ((constructor,{ctor_type=_;_}),body) =
@ -225,7 +226,7 @@ let peephole_expression : expression -> expression result = fun e ->
let src_kvl = to_sorted_kv_list_l src_lmap in
return @@ E_record (to_right_comb_record to_convert src_kvl LMap.empty)
| T_sum src_cmap ->
let%bind dst_cmap = get_t_sum e.type_expression in
let%bind dst_cmap = trace_option (corner_case "to_right_comb conversion") @@ get_t_sum e.type_expression in
let src_kvl = to_sorted_kv_list_c src_cmap in
let bodies = right_comb_variant_combination e dst_cmap src_kvl in
let to_cases ((constructor,{ctor_type=_;_}),body) =
@ -242,11 +243,11 @@ let peephole_expression : expression -> expression result = fun e ->
| E_constant {cons_name= (C_CONVERT_FROM_RIGHT_COMB); arguments= [ to_convert ] } -> (
match to_convert.type_expression.type_content with
| T_record src_lmap ->
let%bind dst_lmap = get_t_record e.type_expression in
let%bind dst_lmap = trace_option (corner_case "from_right_comb conversion") @@ get_t_record e.type_expression in
let dst_kvl = to_sorted_kv_list_l dst_lmap in
return @@ E_record (from_right_comb_record to_convert src_lmap dst_kvl LMap.empty)
| T_sum src_cmap ->
let%bind dst_lmap = get_t_sum e.type_expression in
let%bind dst_lmap = trace_option (corner_case "from_right_comb conversion") @@ get_t_sum e.type_expression in
let dst_kvl = to_sorted_kv_list_c dst_lmap in
let intermediary_types i = descend_types "M_right" src_cmap i in
let matchee = to_convert :: (List.map (fun t -> match_var t) @@ intermediary_types ((List.length dst_kvl)-2)) in
@ -260,11 +261,11 @@ let peephole_expression : expression -> expression result = fun e ->
| E_constant {cons_name= (C_CONVERT_FROM_LEFT_COMB); arguments= [ to_convert ] } -> (
match to_convert.type_expression.type_content with
| T_record src_lmap ->
let%bind dst_lmap = get_t_record e.type_expression in
let%bind dst_lmap = trace_option (corner_case "from_left_comb conversion") @@ get_t_record e.type_expression in
let dst_kvl = to_sorted_kv_list_l dst_lmap in
return @@ E_record (from_left_comb to_convert src_lmap dst_kvl LMap.empty)
| T_sum src_cmap ->
let%bind dst_lmap = get_t_sum e.type_expression in
let%bind dst_lmap = trace_option (corner_case "from_left_comb conversion") @@ get_t_sum e.type_expression in
let dst_kvl = to_sorted_kv_list_c dst_lmap in
let intermediary_types i = descend_types "M_left" src_cmap i in
let matchee = to_convert :: (List.map (fun t -> match_var t) @@ intermediary_types ((List.length dst_kvl)-2)) in

15
src/passes/09-self_ast_typed/no_nested_big_map.ml
View File

@ -1,22 +1,13 @@
open Errors
open Ast_typed
open Trace
type contract_pass_data = Contract_passes.contract_pass_data
module Errors = struct
let no_nested_bigmap () =
let title = (thunk ("It looks like you have nested a big map inside another big map. This is not supported. ")) in
let message () = "" in
let data = [
(* ("location" , fun () -> Format.asprintf "%a" Location.pp loc) TODO once types have an actual location *)
] in
error ~data title message ()
end
let rec check_no_nested_bigmap is_in_bigmap e =
match e.type_content with
| T_operator (TC_big_map _) when is_in_bigmap ->
fail @@ Errors.no_nested_bigmap
fail @@ nested_bigmap e.location
| T_operator (TC_big_map {k ; v}) ->
let%bind _ = check_no_nested_bigmap false k in
let%bind _ = check_no_nested_bigmap true v in
@ -51,6 +42,6 @@ let rec check_no_nested_bigmap is_in_bigmap e =
| T_constant _ ->
ok ()
let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression) result = fun dat el ->
let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression , self_ast_typed_error) result = fun dat el ->
let%bind _ = check_no_nested_bigmap false el.type_expression in
ok (true, dat, el)

1
src/passes/09-self_ast_typed/self_ast_typed.ml
View File

@ -1,4 +1,5 @@
open Trace
module Errors = Errors
let all_passes = [
Tail_recursion.peephole_expression ;

21
src/passes/09-self_ast_typed/tail_recursion.ml
View File

@ -1,27 +1,16 @@
open Errors
open Ast_typed
open Trace
module Errors = struct
let recursive_call_is_only_allowed_as_the_last_operation name loc () =
let title = (thunk ("Recursion must be achieved through tail-calls only")) in
let message () = "" in
let data = [
("function" , fun () -> Format.asprintf "%a" PP.expression_variable name);
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
end
open Errors
let rec check_recursive_call : expression_variable -> bool -> expression -> unit result = fun n final_path e ->
let rec check_recursive_call : expression_variable -> bool -> expression -> (unit, self_ast_typed_error) result = fun n final_path e ->
match e.expression_content with
| E_literal _ -> ok ()
| E_constant c ->
let%bind _ = bind_map_list (check_recursive_call n false) c.arguments in
ok ()
| E_variable v -> (
let%bind _ = trace_strong (recursive_call_is_only_allowed_as_the_last_operation n e.location) @@
Assert.assert_true (final_path || n <> v) in
let%bind _ = Assert.assert_true (recursive_call_is_only_allowed_as_the_last_operation n e.location)
(final_path || n <> v) in
ok ()
)
| E_application {lamb;args} ->
@ -78,7 +67,7 @@ and check_recursive_call_in_matching = fun n final_path c ->
ok ()
let peephole_expression : expression -> expression result = fun e ->
let peephole_expression : expression -> (expression, self_ast_typed_error) result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_recursive {fun_name; lambda} as e-> (

40
src/passes/10-interpreter/interpreter.ml
View File

@ -5,8 +5,11 @@ include Ast_typed.Types
module Env = Ligo_interpreter.Environment
(*TODO, maybe the interpreter should never fail ?*)
type interpreter_error = []
let apply_comparison : Ast_typed.constant' -> value list -> value result =
let apply_comparison : Ast_typed.constant' -> value list -> (value , interpreter_error) result =
fun c operands -> match (c,operands) with
| ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] )
| ( comp , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] )
@ -49,10 +52,10 @@ let apply_comparison : Ast_typed.constant' -> value list -> value result =
ok @@ v_bool (f_op a' b')
| _ ->
let () = List.iter (fun el -> Format.printf "%s" (Ligo_interpreter.PP.pp_value el)) operands in
simple_fail "unsupported comparison"
failwith "unsupported comparison"
(* applying those operators does not involve extending the environment *)
let rec apply_operator : Ast_typed.constant' -> value list -> value result =
let rec apply_operator : Ast_typed.constant' -> value list -> (value, interpreter_error) result =
fun c operands ->
let return_ct v = ok @@ V_Ct v in
let return_none () = ok @@ v_none () in
@ -160,9 +163,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
aux @@ v_pair (v_bool true,init)
(* tertiary *)
| ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) ->
generic_try (simple_error "bad slice") @@ (fun () ->
V_Ct (C_string (String.sub s (Z.to_int st) (Z.to_int ed)))
)
ok @@ V_Ct (C_string (String.sub s (Z.to_int st) (Z.to_int ed)))
| ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List elts ; init ] ) ->
bind_fold_list
(fun prev elt ->
@ -188,7 +189,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| ( C_MAP_UPDATE , [ k ; V_Construct (option,v) ; V_Map kvs] ) -> (match option with
| "Some" -> ok @@ V_Map ((k,v)::(List.remove_assoc k kvs))
| "None" -> ok @@ V_Map (List.remove_assoc k kvs)
| _ -> simple_fail "update without an option"
| _ -> failwith "update without an option"
)
| ( C_SET_EMPTY, []) -> ok @@ V_Set ([])
| ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l))
@ -212,7 +213,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| _ ->
let () = Format.printf "%a\n" Ast_typed.PP.constant c in
let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in
simple_fail "Unsupported constant op"
failwith "Unsupported constant op"
)
(* TODO
@ -253,7 +254,7 @@ C_STEPS_TO_QUOTA
*)
(*interpreter*)
and eval_literal : Ast_typed.literal -> value result = function
and eval_literal : Ast_typed.literal -> (value , _) result = function
| Literal_unit -> ok @@ V_Ct (C_unit)
| Literal_int i -> ok @@ V_Ct (C_int i)
| Literal_nat n -> ok @@ V_Ct (C_nat n)
@ -267,9 +268,9 @@ and eval_literal : Ast_typed.literal -> value result = function
| Literal_key_hash s -> ok @@ V_Ct (C_key_hash s)
| Literal_chain_id s -> ok @@ V_Ct (C_key_hash s)
| Literal_operation o -> ok @@ V_Ct (C_operation o)
| Literal_void -> simple_fail "iguess ?"
| Literal_void -> failwith "iguess ?"
and eval : Ast_typed.expression -> env -> value result
and eval : Ast_typed.expression -> env -> (value , _) result
= fun term env ->
match term.expression_content with
| E_application ({lamb = f; args}) -> (
@ -283,7 +284,7 @@ and eval : Ast_typed.expression -> env -> value result
let f_env' = Env.extend f_env (arg_names, args') in
let f_env'' = Env.extend f_env' (fun_name, f') in
eval body f_env''
| _ -> simple_fail "trying to apply on something that is not a function"
| _ -> failwith "trying to apply on something that is not a function"
)
| E_lambda {binder; result;} ->
ok @@ V_Func_val (binder,result,env)
@ -306,10 +307,9 @@ and eval : Ast_typed.expression -> env -> value result
let%bind record' = eval record env in
match record' with
| V_Record recmap ->
let%bind a = trace_option (simple_error "unknown record field") @@
LMap.find_opt path recmap in
let a = LMap.find path recmap in
ok a
| _ -> simple_fail "trying to access a non-record"
| _ -> failwith "trying to access a non-record"
)
| E_record_update {record ; path ; update} -> (
let%bind record' = eval record env in
@ -319,8 +319,8 @@ and eval : Ast_typed.expression -> env -> value result
let%bind field' = eval update env in
ok @@ V_Record (LMap.add path field' recmap)
else
simple_fail "field l does not exist in record"
| _ -> simple_fail "this expression isn't a record"
failwith "field l does not exist in record"
| _ -> failwith "this expression isn't a record"
)
| E_constant {cons_name ; arguments} -> (
let%bind operands' = bind_map_list
@ -360,14 +360,14 @@ and eval : Ast_typed.expression -> env -> value result
eval body env'
| Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
eval cases.match_none env
| _ -> simple_fail "not yet supported case"
| _ -> failwith "not yet supported case"
(* ((ctor,name),body) *)
)
| E_recursive {fun_name; fun_type=_; lambda} ->
ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env)
| E_raw_code _ -> simple_fail "Can't evaluate a raw code insertion"
| E_raw_code _ -> failwith "Can't evaluate a raw code insertion"
let dummy : Ast_typed.program -> string result =
let eval : Ast_typed.program -> (string , _) result =
fun prg ->
let aux (pp,top_env) el =
match Location.unwrap el with

3
src/passes/10-interpreter/interpreter.mli
View File

@ -1,3 +1,4 @@
open Trace
val dummy : Ast_typed.program -> string result
type interpreter_error = []
val eval : Ast_typed.program -> (string, interpreter_error) result

146
src/passes/10-transpiler/errors.ml Normal file
View File

@ -0,0 +1,146 @@
open Trace
open Simple_utils.Display
type transpiler_error = [
| `Transpiler_corner_case of string * string
| `Transpiler_no_type_variable of Stage_common.Types.type_variable
| `Transpiler_unsupported_pattern_matching of Location.t
| `Transpiler_unsupported_iterator of Location.t
| `Transpiler_unsupported_recursive_function of Ast_typed.expression_variable
| `Transpiler_tracer of Location.t * transpiler_error
| `Transpiler_wrong_mini_c_value of Ast_typed.type_expression * Mini_c.value
| `Transpiler_bad_untranspile of Mini_c.value
]
let stage = "transpiler"
let translation_tracer loc err = `Transpiler_tracer (loc , err)
let corner_case ~loc desc = `Transpiler_corner_case (loc, desc)
let corner_case_message () =
"we don't have a good error message for this case. we are
striving find ways to better report them and find the use-cases that generate
them. please report this to the developers."
let no_type_variable name = `Transpiler_no_type_variable name
let unsupported_tuple_pattern_matching location =
`Transpiler_unsupported_pattern_matching location
let unsupported_iterator location =
`Transpiler_unsupported_iterator location
let unsupported_recursive_function expression_variable =
`Transpiler_unsupported_recursive_function expression_variable
let wrong_mini_c_value expected actual =
`Transpiler_wrong_mini_c_value (expected , actual)
let bad_untranspile bad_type =
`Transpiler_bad_untranspile bad_type
let rec error_ppformat : display_format:string display_format ->
Format.formatter -> transpiler_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Transpiler_tracer (loc,err) ->
Format.fprintf f
"@[<hv>%a@Translating expression@%a@]"
Location.pp loc
(error_ppformat ~display_format) err
| `Transpiler_corner_case (loc,desc) ->
let s = Format.asprintf "%s\n corner case: %s\n%s" loc desc (corner_case_message ()) in
Format.pp_print_string f s
| `Transpiler_no_type_variable tv ->
let s = Format.asprintf "type variables can't be transpiled : %a" Var.pp tv in
Format.pp_print_string f s
| `Transpiler_unsupported_pattern_matching loc ->
let s = Format.asprintf "%a\n unsupported pattern-matching: tuple patterns aren't supported yet" Location.pp loc in
Format.pp_print_string f s
| `Transpiler_unsupported_iterator loc ->
let s = Format.asprintf "%a\n unsupported iterator: only lambda are supported as iterators" Location.pp loc in
Format.pp_print_string f s
| `Transpiler_unsupported_recursive_function var ->
let s = Format.asprintf "Recursive functions with only one variable are supported : %a"
Ast_typed.PP.expression_variable var in
Format.pp_print_string f s
| `Transpiler_wrong_mini_c_value (expected , actual) ->
let s = Format.asprintf "illed typed intermediary value: expected %a got %a"
Ast_typed.PP.type_expression expected
Mini_c.PP.value actual in
Format.pp_print_string f s
| `Transpiler_bad_untranspile bad ->
let s = Format.asprintf "can not untranspile %a"
Mini_c.PP.value bad in
Format.pp_print_string f s
)
let rec error_jsonformat : transpiler_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Transpiler_tracer (loc, err) ->
let loc' = Format.asprintf "%a" Location.pp loc in
let children = error_jsonformat err in
let content = `Assoc [
("location", `String loc');
("children", children) ]
in
json_error ~stage ~content
| `Transpiler_corner_case (loc, desc) ->
let content = `Assoc [
("location", `String loc);
("description", `String desc);
("message", `String (corner_case_message ()) ); ]
in
json_error ~stage ~content
| `Transpiler_no_type_variable tv ->
let tv' = Format.asprintf "%a" Var.pp tv in
let content = `Assoc [
("description", `String "type variables can't be transpiled");
("type_variable", `String tv'); ]
in
json_error ~stage ~content
| `Transpiler_unsupported_pattern_matching loc ->
let loc' = Format.asprintf "%a" Location.pp loc in
let content = `Assoc [
("location", `String loc');
("message", `String "unsupported tuple in pattern-matching"); ]
in
json_error ~stage ~content
| `Transpiler_unsupported_iterator loc ->
let loc' = Format.asprintf "%a" Location.pp loc in
let content = `Assoc [
("location", `String loc');
("message", `String "unsupported iterator"); ]
in
json_error ~stage ~content
| `Transpiler_unsupported_recursive_function var ->
let var' = Format.asprintf "%a" Ast_typed.PP.expression_variable var in
let content = `Assoc [
("message", `String "Recursive functions with only one variable are supported");
("value", `String var'); ]
in
json_error ~stage ~content
| `Transpiler_wrong_mini_c_value (expected , actual) ->
let expected' = Format.asprintf "%a" Ast_typed.PP.type_expression expected in
let actual' = Format.asprintf "%a" Mini_c.PP.value actual in
let content = `Assoc [
("message", `String "illed type of intermediary value does not match what was expected");
("expected", `String expected');
("actual", `String actual'); ]
in
json_error ~stage ~content
| `Transpiler_bad_untranspile bad ->
let var' = Format.asprintf "%a" Mini_c.PP.value bad in
let content = `Assoc [
("message", `String "untranspiling bad value");
("value", `String var'); ]
in
json_error ~stage ~content

19
src/passes/10-transpiler/helpers.ml
View File

@ -1,3 +1,4 @@
open Errors
module AST = Ast_typed
module Append_tree = Tree.Append
@ -23,40 +24,40 @@ let map_of_kv_list lst =
let open Map.String in
List.fold_left (fun prev (k, v) -> add k v prev) empty lst
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression , transpiler_error) result =
let open Append_tree in
let rec aux tv : (string * value * AST.type_expression) result=
let rec aux tv : (string * value * AST.type_expression , transpiler_error) result=
match tv with
| Leaf (Ast_typed.Constructor k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v)
| Node {b}, D_right v -> aux (b, v)
| _ -> fail @@ internal_assertion_failure "bad constructor path"
| _ -> fail @@ corner_case ~loc:__LOC__ "bad constructor path"
in
let%bind (s, v, t) = aux (tree, v) in
ok (s, v, t)
let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list , transpiler_error) result =
let open Append_tree in
let rec aux tv : ((value * AST.type_expression) list) result =
let rec aux tv : ((value * AST.type_expression) list , transpiler_error) result =
match tv with
| Leaf t, v -> ok @@ [v, t]
| Node {a;b}, D_pair (va, vb) ->
let%bind a' = aux (a, va) in
let%bind b' = aux (b, vb) in
ok (a' @ b')
| _ -> fail @@ internal_assertion_failure "bad tuple path"
| _ -> fail @@ corner_case ~loc:__LOC__ "bad tuple path"
in
aux (tree, v)
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list , transpiler_error) result =
let open Append_tree in
let rec aux tv : ((AST.label * (value * AST.type_expression)) list) result =
let rec aux tv : ((AST.label * (value * AST.type_expression)) list , transpiler_error) result =
match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) ->
let%bind a' = aux (a, va) in
let%bind b' = aux (b, vb) in
ok (a' @ b')
| _ -> fail @@ internal_assertion_failure "bad record path"
| _ -> fail @@ corner_case ~loc:__LOC__ "bad record path"
in
aux (tree, v)

211
src/passes/10-transpiler/transpiler.ml
View File

@ -4,6 +4,8 @@ For more info, see back-end.md: https://gitlab.com/ligolang/ligo/blob/dev/gitlab
open Trace
open Helpers
module Errors = Errors
open Errors
module AST = Ast_typed
module Append_tree = Tree.Append
@ -15,96 +17,6 @@ let untranspile = Untranspiler.untranspile
let temp_unwrap_loc = Location.unwrap
let temp_unwrap_loc_list = List.map Location.unwrap
module Errors = struct
let corner_case ~loc message =
let title () = "corner case" in
let content () = "we don't have a good error message for this case. we are
striving find ways to better report them and find the use-cases that generate
them. please report this to the developers." in
let data = [
("location" , fun () -> loc) ;
("message" , fun () -> message) ;
] in
error ~data title content
let no_type_variable name =
let title () = "type variables can't be transpiled" in
let content () = Format.asprintf "%a" Var.pp name in
error title content
let not_functional_main location =
let title () = "not functional main" in
let content () = "main should be a function" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title content
let bad_big_map location =
let title () = "bad arguments for main" in
let content () = "only one big_map per program which must appear
on the left hand side of a pair in the contract's storage" in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
] in
error ~data title content
let missing_entry_point name =
let title () = "missing entry point" in
let content () = "no entry point with the given name" in
let data = [
("name" , fun () -> name) ;
] in
error ~data title content
let wrong_mini_c_value expected_type actual =
let title () = "transpiler: illed typed intermediary value" in
let content () = "type of intermediary value doesn't match what was expected" in
let data = [
("expected_type" , fun () -> expected_type) ;
("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
] in
error ~data title content
let bad_untranspile bad_type value =
let title () = "untranspiling bad value" in
let content () = Format.asprintf "can not untranspile %s" bad_type in
let data = [
("bad_type" , fun () -> bad_type) ;
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
] in
error ~data title content
let unknown_untranspile unknown_type value =
let title () = "untranspiling unknown value" in
let content () = Format.asprintf "can not untranspile %s" unknown_type in
let data = [
("unknown_type" , fun () -> unknown_type) ;
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
] in
error ~data title content
let unsupported_recursive_function expression_variable =
let title () = "unsupported recursive function yet" in
let content () = "only fuction with one variable are supported" in
let data = [
("value" , fun () -> Format.asprintf "%a" AST.PP.expression_variable expression_variable) ;
] in
error ~data title content
let language_backend_mismatch language backend =
let title () = "Language insert - Backend Mismatch" in
let content () = "only provide code insertion in the language you are compiling to" in
let data = [
("Code Insertion Language", fun () -> language);
("Target backend", fun () -> backend);
] in
error ~data title content
end
open Errors
let transpile_constant' : AST.constant' -> constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
@ -224,7 +136,7 @@ let transpile_constant' : AST.constant' -> constant' = function
| C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
| C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB
let rec transpile_type (t:AST.type_expression) : type_expression result =
let rec transpile_type (t:AST.type_expression) : (type_expression, transpiler_error) result =
let return tc = ok @@ Expression.make_t ~loc:t.location @@ tc in
match t.type_content with
| T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> return (T_base TB_bool)
@ -266,7 +178,7 @@ let rec transpile_type (t:AST.type_expression) : type_expression result =
return (T_option o')
| T_sum m when Ast_typed.Helpers.is_michelson_or m ->
let node = Append_tree.of_list @@ kv_list_of_cmap m in
let aux a b : type_expression annotated result =
let aux a b : (type_expression annotated , transpiler_error) result =
let%bind a = a in
let%bind b = b in
let%bind t = return @@ T_or (a,b) in
@ -280,7 +192,7 @@ let rec transpile_type (t:AST.type_expression) : type_expression result =
ok @@ snd m'
| T_sum m ->
let node = Append_tree.of_list @@ kv_list_of_cmap m in
let aux a b : type_expression annotated result =
let aux a b : (type_expression annotated , transpiler_error) result =
let%bind a = a in
let%bind b = b in
let%bind t = return @@ T_or (a,b) in
@ -294,7 +206,7 @@ let rec transpile_type (t:AST.type_expression) : type_expression result =
ok @@ snd m'
| T_record m when Ast_typed.Helpers.is_michelson_pair m ->
let node = Append_tree.of_list @@ Ast_typed.Helpers.tuple_of_record m in
let aux a b : type_expression annotated result =
let aux a b : (type_expression annotated , transpiler_error) result =
let%bind a = a in
let%bind b = b in
let%bind t = return @@ T_pair (a, b) in
@ -315,7 +227,7 @@ let rec transpile_type (t:AST.type_expression) : type_expression result =
List.rev @@ Ast_typed.Types.LMap.to_kv_list m
)
in
let aux a b : type_expression annotated result =
let aux a b : (type_expression annotated, transpiler_error) result =
let%bind a = a in
let%bind b = b in
let%bind t = return @@ T_pair (a, b) in
@ -338,7 +250,7 @@ let rec transpile_type (t:AST.type_expression) : type_expression result =
return @@ (T_function (param',result'))
)
let record_access_to_lr : type_expression -> type_expression AST.label_map -> AST.label -> (type_expression * [`Left | `Right]) list result = fun ty tym ind ->
let record_access_to_lr : type_expression -> type_expression AST.label_map -> AST.label -> ((type_expression * [`Left | `Right]) list , transpiler_error) result = fun ty tym ind ->
let tys = Ast_typed.Helpers.kv_list_of_record_or_tuple tym in
let node_tv = Append_tree.of_list tys in
let%bind path =
@ -349,7 +261,7 @@ let record_access_to_lr : type_expression -> type_expression AST.label_map -> AS
let%bind (_ , lst) =
let aux = fun (ty , acc) cur ->
let%bind (a , b) =
trace_strong (corner_case ~loc:__LOC__ "record access pair") @@
trace_option (corner_case ~loc:__LOC__ "record access pair") @@
Mini_c.get_t_pair ty in
match cur with
| `Left -> ok (a , acc @ [(a , `Left)])
@ -373,19 +285,17 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_unit -> D_unit
| Literal_void -> D_none
and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in
and tree_of_sum : AST.type_expression -> ((AST.constructor' * AST.type_expression) Append_tree.t, transpiler_error) result = fun t ->
let%bind map_tv =
trace_option (corner_case ~loc:__LOC__ "getting lr tree") @@
get_t_sum t in
let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in
ok @@ Append_tree.of_list kt_list
and transpile_annotated_expression (ae:AST.expression) : expression result =
and transpile_annotated_expression (ae:AST.expression) : (expression , transpiler_error) result =
let%bind tv = transpile_type ae.type_expression in
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl ~loc:ae.location (expr, tv) in
let info =
let title () = "translating expression" in
let content () = Format.asprintf "%a" Location.pp ae.location in
info title content in
trace info @@
trace (translation_tracer ae.location) @@
match ae.expression_content with
| E_let_in {let_binder; rhs; let_result; inline} ->
let%bind rhs' = transpile_annotated_expression rhs in
@ -407,17 +317,17 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind node_tv =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum ae.type_expression in
let leaf (k, tv) : (expression_content option * type_expression) result =
let leaf (k, tv) : (expression_content option * type_expression , transpiler_error) result =
if k = constructor then (
let%bind _ =
trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
trace_option (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
@@ AST.assert_type_expression_eq (tv, element.type_expression) in
ok (Some (param'_expr), param'_tv)
) else (
let%bind tv = transpile_type tv in
ok (None, tv)
) in
let node a b : (expression_content option * type_expression) result =
let node a b : (expression_content option * type_expression , transpiler_error) result =
let%bind a = a in
let%bind b = b in
match (a, b) with
@ -434,7 +344,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
)
| E_record m -> (
let node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in
let aux a b : expression result =
let aux a b : (expression , transpiler_error) result =
let%bind a = a in
let%bind b = b in
let a_ty = Combinators.Expression.get_type a in
@ -448,12 +358,10 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
| E_record_accessor {record; path} ->
let%bind ty' = transpile_type (get_type_expression record) in
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
trace_option (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_expression record) in
let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap_t transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap path in
let%bind path = record_access_to_lr ty' ty'_lmap path in
let aux = fun pred (ty, lr) ->
let c = match lr with
| `Left -> C_CAR
@ -468,7 +376,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let rec aux res (r,p,up) =
let ty = get_type_expression r in
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
trace_option (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (ty) in
let%bind ty' = transpile_type (ty) in
let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap_t transpile_type ty_lmap in
@ -495,7 +403,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
| E_constant {cons_name=name; arguments=lst} -> (
let iterator_generator iterator_name =
let expression_to_iterator_body (f : AST.expression) =
let%bind (input , output) = AST.get_t_function f.type_expression in
let%bind (input , output) = trace_option (corner_case ~loc:__LOC__ "expected function type") @@ AST.get_t_function f.type_expression in
let%bind f' = transpile_annotated_expression f in
let%bind input' = transpile_type input in
let%bind output' = transpile_type output in
@ -533,7 +441,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
)
)
| E_lambda l ->
let%bind io = AST.get_t_function ae.type_expression in
let%bind io = trace_option (corner_case ~loc:__LOC__ "expected function type") @@
AST.get_t_function ae.type_expression in
transpile_lambda l io
| E_recursive r ->
transpile_recursive r
@ -598,13 +507,13 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
let%bind a_ty = get_t_left tv in
let%bind a_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_left tv in
let left_var = Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok ((left_var , a_ty) , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let%bind b_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_right tv in
let right_var = Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok ((right_var , b_ty) , e)
@ -618,12 +527,13 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
| E_raw_code { language; code} ->
let backend = "Michelson" in
let%bind () =
trace_strong (language_backend_mismatch language backend) @@
Assert.assert_true (String.equal language backend)
Assert.assert_true
(corner_case ~loc:__LOC__ "Language insert - backend mismatch only provide code insertion in the language you are compiling to")
(String.equal language backend)
in
let type_anno = get_type_expression code in
let%bind type_anno' = transpile_type type_anno in
let%bind code = get_a_string code in
let%bind code = trace_option (corner_case ~loc:__LOC__ "could not get a string") @@ get_a_string code in
return ~tv:type_anno' @@ E_raw_michelson code
and transpile_lambda l (input_type , output_type) =
@ -637,7 +547,7 @@ and transpile_lambda l (input_type , output_type) =
ok @@ Combinators.Expression.make_tpl ~loc:result.location (closure , tv)
and transpile_recursive {fun_name; fun_type; lambda} =
let rec map_lambda : AST.expression_variable -> type_expression -> AST.expression -> (expression * expression_variable list) result = fun fun_name loop_type e ->
let rec map_lambda : AST.expression_variable -> type_expression -> AST.expression -> (expression * expression_variable list , transpiler_error) result = fun fun_name loop_type e ->
match e.expression_content with
E_lambda {binder;result} ->
let%bind (body,l) = map_lambda fun_name loop_type result in
@ -646,7 +556,7 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let%bind res = replace_callback fun_name loop_type false e in
ok @@ (res, [])
and replace_callback : AST.expression_variable -> type_expression -> bool -> AST.expression -> expression result = fun fun_name loop_type shadowed e ->
and replace_callback : AST.expression_variable -> type_expression -> bool -> AST.expression -> (expression , transpiler_error) result = fun fun_name loop_type shadowed e ->
match e.expression_content with
E_let_in li ->
let shadowed = shadowed || Var.equal li.let_binder fun_name in
@ -670,7 +580,7 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let%bind expr = transpile_annotated_expression e in
ok @@ Expression.make (E_constant {cons_name=C_LOOP_STOP;arguments=[expr]}) loop_type
and matching : AST.expression_variable -> type_expression -> bool -> AST.matching -> type_expression -> expression result = fun fun_name loop_type shadowed m ty ->
and matching : AST.expression_variable -> type_expression -> bool -> AST.matching -> type_expression -> (expression , transpiler_error) result = fun fun_name loop_type shadowed m ty ->
let return ret = ok @@ Expression.make ret @@ ty in
let%bind expr = transpile_annotated_expression m.matchee in
match m.cases with
@ -731,13 +641,13 @@ and transpile_recursive {fun_name; fun_type; lambda} =
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
let%bind a_ty = get_t_left tv in
let%bind a_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_left tv in
let left_var = Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok ((left_var , a_ty) , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let%bind b_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_right tv in
let right_var = Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok ((right_var , b_ty) , e)
@ -749,7 +659,7 @@ and transpile_recursive {fun_name; fun_type; lambda} =
)
in
let%bind fun_type = transpile_type fun_type in
let%bind (input_type,output_type) = get_t_function fun_type in
let%bind (input_type,output_type) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_function fun_type in
let loop_type = t_union (None, input_type) (None, output_type) in
let%bind (body,binder) = map_lambda fun_name loop_type lambda.result in
let binder = lambda.binder::binder in
@ -758,7 +668,7 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let body = Expression.make (E_iterator (C_LOOP_LEFT, ((lambda.binder, loop_type),body), expr)) output_type in
ok @@ Expression.make (E_closure {binder;body}) fun_type
let transpile_declaration env (d:AST.declaration) : toplevel_statement option result =
let transpile_declaration env (d:AST.declaration) : (toplevel_statement option , transpiler_error) result =
match d with
| Declaration_constant { binder ; expr ; inline } ->
let%bind expression = transpile_annotated_expression expr in
@ -767,8 +677,8 @@ let transpile_declaration env (d:AST.declaration) : toplevel_statement option re
ok @@ Some ((binder, inline, expression), environment_wrap env env')
| _ -> ok None
let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =
let transpile_program (lst : AST.program) : (program , transpiler_error) result =
let aux (prev:(toplevel_statement list * Environment.t , transpiler_error) result) cur =
let%bind (hds, env) = prev in
match%bind transpile_declaration env cur with
| Some ((_ , env') as cur') -> ok (hds @ [ cur' ] , env'.post_environment)
@ -777,63 +687,40 @@ let transpile_program (lst : AST.program) : program result =
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements
(* check whether the storage contains a big_map, if yes, check that
it appears on the left hand side of a pair
TODO : checking should appears in check_pass.
*)
let check_storage f ty loc : (anon_function * _) result =
let rec aux (t:type_expression) on_big_map =
match t.type_content with
| T_big_map _ -> on_big_map
| T_pair (a , b) -> (aux (snd a) true) && (aux (snd b) false)
| T_or (a,b) -> (aux (snd a) false) && (aux (snd b) false)
| T_function (a,b) -> (aux a false) && (aux b false)
| T_map (a,b) -> (aux a false) && (aux b false)
| T_list a -> (aux a false)
| T_set a -> (aux a false)
| T_contract a -> (aux a false)
| T_option a -> (aux a false)
| _ -> true
in
match f.body.type_expression.type_content with
| T_pair (_, storage) ->
if aux (snd storage) false then ok (f, ty) else fail @@ bad_big_map loc
| _ -> ok (f, ty)
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression , transpiler_error) result =
let open Append_tree in
let rec aux tv : (string * value * AST.type_expression) result=
let rec aux tv : (string * value * AST.type_expression , transpiler_error) result=
match tv with
| Leaf (k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v)
| Node {b}, D_right v -> aux (b, v)
| _ -> fail @@ internal_assertion_failure "bad constructor path"
| _ -> fail (corner_case ~loc:__LOC__ "extract constructor")
in
let%bind (s, v, t) = aux (tree, v) in
ok (s, v, t)
let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list , transpiler_error) result =
let open Append_tree in
let rec aux tv : ((value * AST.type_expression) list) result =
let rec aux tv : ((value * AST.type_expression) list , transpiler_error) result =
match tv with
| Leaf t, v -> ok @@ [v, t]
| Node {a;b}, D_pair (va, vb) ->
let%bind a' = aux (a, va) in
let%bind b' = aux (b, vb) in
ok (a' @ b')
| _ -> fail @@ internal_assertion_failure "bad tuple path"
| _ -> fail (corner_case ~loc:__LOC__ "extract tuple")
in
aux (tree, v)
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list , transpiler_error) result =
let open Append_tree in
let rec aux tv : ((string * (value * AST.type_expression)) list) result =
let rec aux tv : ((string * (value * AST.type_expression)) list , transpiler_error) result =
match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) ->
let%bind a' = aux (a, va) in
let%bind b' = aux (b, vb) in
ok (a' @ b')
| _ -> fail @@ internal_assertion_failure "bad record path"
| _ -> fail (corner_case ~loc:__LOC__ "bad record path")
in
aux (tree, v)

52
src/passes/10-transpiler/transpiler.mli
View File

@ -1,55 +1,19 @@
open Trace
open Errors
module AST = Ast_typed
module Append_tree = Tree.Append
module Errors = Errors
open Mini_c
val temp_unwrap_loc : 'a Location.wrap -> 'a
(*
val temp_unwrap_loc_list : AST.declaration Location.wrap list -> AST.declaration list
val list_of_map : 'a AST.type_name_map -> 'a list
val kv_list_of_map : 'a AST.type_name_map -> ( string * 'a ) list
val map_of_kv_list : ( string * 'a ) list -> 'a AST.type_name_map
*)
module Errors : sig
(*
val corner_case : loc:string -> string -> unit -> error
val unrecognized_type_constant : string -> unit -> error
val row_loc : Location.t -> string * ( unit -> string )
val unsupported_pattern_matching : string -> Location.t -> unit -> error
val unsupported_iterator : Location.t -> unit -> error
*)
val not_functional_main : Location.t -> unit -> error
val missing_entry_point : string -> unit -> error
val wrong_mini_c_value : string -> value -> unit -> error
val bad_untranspile : string -> value -> unit -> error
val unknown_untranspile : string -> value -> unit -> error
end
val transpile_annotated_expression : AST.expression -> (expression, transpiler_error) result
(*
val translate_type : AST.type_value -> type_value result
val tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [`Left | `Right]) list result
val record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * [`Left | `Right]) list result
val translate_literal : AST.literal -> value
val transpile_environment_element_type : AST.environment_element -> type_value result
val tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result
*)
val transpile_annotated_expression : AST.expression -> expression result
(*
val transpile_lambda : AST.lambda -> expression result
val transpile_declaration : environment -> AST.declaration -> toplevel_statement result
*)
val transpile_program : AST.program -> (program, transpiler_error) result
val transpile_program : AST.program -> program result
val check_storage : anon_function -> 'a -> Location.t -> (anon_function * 'a) result
(*
val translate_main : AST.lambda -> Location.t ->( anon_function * ( type_value * type_value )) result
val extract_constructor : value -> ( string * AST.type_expression ) Append_tree.t' -> ((string * value * AST.type_expression) , transpiler_error) result
val extract_tuple : value -> AST.type_expression Append_tree.t' -> ((value * AST.type_expression) list , transpiler_error) result
val extract_record : value -> ( string * AST.type_expression ) Append_tree.t' -> (( string * ( value * AST.type_expression)) list , transpiler_error) result
(* From an expression [expr], build the expression [fun () -> expr] *)
val translate_entry : AST.program -> string -> ( anon_function * ( type_value * type_value )) result
*)
val extract_constructor : value -> ( string * AST.type_expression ) Append_tree.t' -> (string * value * AST.type_expression) result
val extract_tuple : value -> AST.type_expression Append_tree.t' -> (value * AST.type_expression) list result
val extract_record : value -> ( string * AST.type_expression ) Append_tree.t' -> ( string * ( value * AST.type_expression)) list result
val untranspile : value -> AST.type_expression -> AST.expression result
val untranspile : value -> AST.type_expression -> (AST.expression , transpiler_error) result

87
src/passes/10-transpiler/untranspiler.ml
View File

@ -2,57 +2,24 @@ open Helpers
module AST = Ast_typed
module Append_tree = Tree.Append
module Errors = Errors
open Errors
open Mini_c
open Trace
module Errors = struct
let corner_case ~loc message =
let title () = "corner case" in
let content () = "we don't have a good error message for this case. we are
striving find ways to better report them and find the use-cases that generate
them. please report this to the developers." in
let data = [
("location" , fun () -> loc) ;
("message" , fun () -> message) ;
] in
error ~data title content
let wrong_mini_c_value expected_type actual =
let title () = "untranspiler: illed typed intermediary value" in
let content () = "type of intermediary value doesn't match what was expected" in
let data = [
("expected_type" , fun () -> expected_type) ;
("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
] in
error ~data title content
let bad_untranspile bad_type value =
let title () = "untranspiling bad value" in
let content () = Format.asprintf "can not untranspile %s" bad_type in
let data = [
("bad_type" , fun () -> bad_type) ;
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
] in
error ~data title content
end
open Errors
let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result =
let rec untranspile (v : value) (t : AST.type_expression) : (AST.expression , transpiler_error) result =
let open! AST in
let return e = ok (make_e e t) in
match t.type_content with
| T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
trace_option (wrong_mini_c_value t v) @@
get_bool v in
return (e_bool b)
)
| t when (compare t (t_bool ()).type_content) = 0-> (
| tc when (compare tc (t_bool ()).type_content) = 0-> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
trace_option (wrong_mini_c_value t v) @@
get_bool v in
return (e_bool b)
)
@ -60,87 +27,87 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
match type_constant with
| TC_unit -> (
let%bind () =
trace_strong (wrong_mini_c_value "unit" v) @@
trace_option (wrong_mini_c_value t v) @@
get_unit v in
return (E_literal Literal_unit)
)
| TC_int -> (
let%bind n =
trace_strong (wrong_mini_c_value "int" v) @@
trace_option (wrong_mini_c_value t v) @@
get_int v in
return (E_literal (Literal_int n))
)
| TC_nat -> (
let%bind n =
trace_strong (wrong_mini_c_value "nat" v) @@
trace_option (wrong_mini_c_value t v) @@
get_nat v in
return (E_literal (Literal_nat n))
)
| TC_timestamp -> (
let%bind n =
trace_strong (wrong_mini_c_value "timestamp" v) @@
trace_option (wrong_mini_c_value t v) @@
get_timestamp v in
return (E_literal (Literal_timestamp n))
)
| TC_mutez -> (
let%bind n =
trace_strong (wrong_mini_c_value "tez" v) @@
trace_option (wrong_mini_c_value t v) @@
get_mutez v in
return (E_literal (Literal_mutez n))
)
| TC_string -> (
let%bind n =
trace_strong (wrong_mini_c_value "string" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
let n = Ligo_string.Standard n in
return (E_literal (Literal_string n))
)
| TC_bytes -> (
let%bind n =
trace_strong (wrong_mini_c_value "bytes" v) @@
trace_option (wrong_mini_c_value t v) @@
get_bytes v in
return (E_literal (Literal_bytes n))
)
| TC_address -> (
let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
return (E_literal (Literal_address n))
)
| TC_operation -> (
let%bind op =
trace_strong (wrong_mini_c_value "operation" v) @@
trace_option (wrong_mini_c_value t v) @@
get_operation v in
return (E_literal (Literal_operation op))
)
| TC_key -> (
let%bind n =
trace_strong (wrong_mini_c_value "key" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
return (E_literal (Literal_key n))
)
| TC_key_hash -> (
let%bind n =
trace_strong (wrong_mini_c_value "key_hash" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
return (E_literal (Literal_key_hash n))
)
| TC_chain_id -> (
let%bind n =
trace_strong (wrong_mini_c_value "chain_id" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
return (E_literal (Literal_chain_id n))
)
| TC_void -> (
let%bind () =
trace_strong (wrong_mini_c_value "void" v) @@
trace_option (wrong_mini_c_value t v) @@
get_unit v in
return (E_literal (Literal_void))
)
| TC_signature -> (
let%bind n =
trace_strong (wrong_mini_c_value "signature" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
return (E_literal (Literal_signature n))
)
@ -149,7 +116,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
match type_operator with
| TC_option o -> (
let%bind opt =
trace_strong (wrong_mini_c_value "option" v) @@
trace_option (wrong_mini_c_value t v) @@
get_option v in
match opt with
| None -> ok (e_a_none o)
@ -159,7 +126,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
)
| TC_map {k=k_ty;v=v_ty}-> (
let%bind map =
trace_strong (wrong_mini_c_value "map" v) @@
trace_option (wrong_mini_c_value t v) @@
get_map v in
let%bind map' =
let aux = fun (k, v) ->
@ -176,7 +143,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
)
| TC_big_map {k=k_ty; v=v_ty} -> (
let%bind big_map =
trace_strong (wrong_mini_c_value "big_map" v) @@
trace_option (wrong_mini_c_value t v) @@
get_big_map v in
let%bind big_map' =
let aux = fun (k, v) ->
@ -194,7 +161,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
| TC_map_or_big_map _ -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c"
| TC_list ty -> (
let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@
trace_option (wrong_mini_c_value t v) @@
get_list v in
let%bind lst' =
let aux = fun e -> untranspile e ty in
@ -206,7 +173,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
)
| TC_set ty -> (
let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@
trace_option (wrong_mini_c_value t v) @@
get_set v in
let%bind lst' =
let aux = fun e -> untranspile e ty in
@ -218,7 +185,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
bind_fold_list aux init lst'
)
| TC_contract _ ->
fail @@ bad_untranspile "contract" v
fail @@ bad_untranspile v
)
| T_sum m ->
let lst = List.map (fun (k,{ctor_type;_}) -> (k,ctor_type)) @@ kv_list_of_cmap m in
@ -245,7 +212,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
return (E_record m')
| T_arrow _ ->
let%bind n =
trace_strong (wrong_mini_c_value "lambda as string" v) @@
trace_option (wrong_mini_c_value t v) @@
get_string v in
let n = Ligo_string.Standard n in
return (E_literal (Literal_string n))

53
src/passes/11-self_mini_c/errors.ml Normal file
View File

@ -0,0 +1,53 @@
open Simple_utils.Display
open Trace
let stage = "self_mini_c"
type self_mini_c_error = [
| `Self_mini_c_bad_self_address of Mini_c.constant'
| `Self_mini_c_not_a_function
| `Self_mini_c_aggregation
]
let bad_self_address cst =
`Self_mini_c_bad_self_address cst
let not_a_function = `Self_mini_c_not_a_function
let could_not_aggregate_entry = `Self_mini_c_aggregation
let error_ppformat : display_format:string display_format ->
Format.formatter -> self_mini_c_error -> unit =
fun ~display_format f a ->
match display_format with
| Human_readable | Dev -> (
match a with
| `Self_mini_c_bad_self_address cst ->
let s = Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in
Format.pp_print_string f s ;
| `Self_mini_c_not_a_function -> Format.fprintf f "getting function has failed"
| `Self_mini_c_aggregation -> Format.fprintf f "could not aggregate"
)
let error_jsonformat : self_mini_c_error -> J.t = fun a ->
let json_error ~stage ~content =
`Assoc [
("status", `String "error") ;
("stage", `String stage) ;
("content", content )]
in
match a with
| `Self_mini_c_bad_self_address cst ->
let msg = Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in
let content = `Assoc [
("message", `String msg); ]
in
json_error ~stage ~content
| `Self_mini_c_not_a_function ->
let content = `Assoc [
("message", `String "getting function has failed"); ]
in
json_error ~stage ~content
| `Self_mini_c_aggregation ->
let content = `Assoc [
("message", `String "could not aggregate"); ]
in
json_error ~stage ~content

12
src/passes/11-self_mini_c/helpers.ml
View File

@ -1,7 +1,7 @@
open Mini_c
open Trace
let rec fold_type_value : ('a -> type_expression -> 'a result) -> 'a -> type_expression -> 'a result = fun f init t ->
let rec fold_type_value : ('a -> type_expression -> ('a,_) result) -> 'a -> type_expression -> ('a,_) result = fun f init t ->
let self = fold_type_value f in
let%bind init' = f init t in
match t.type_content with
@ -19,8 +19,8 @@ let rec fold_type_value : ('a -> type_expression -> 'a result) -> 'a -> type_exp
| T_base _ ->
ok init'
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
type ('a,'err) folder = 'a -> expression -> ('a,'err) result
let rec fold_expression : ('a,'err) folder -> 'a -> expression -> ('a, 'err) result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.content with
@ -81,9 +81,9 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
type mapper = expression -> expression result
type 'err mapper = expression -> (expression,'err) result
let rec map_expression : mapper -> expression -> expression result = fun f e ->
let rec map_expression : 'err mapper -> expression -> (expression, 'err) result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return content = ok { e' with content } in
@ -144,7 +144,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
return @@ E_record_update(r, l, e)
)
let map_sub_level_expression : mapper -> expression -> expression result = fun f e ->
let map_sub_level_expression : 'err mapper -> expression -> (expression , 'err) result = fun f e ->
match e.content with
| E_closure {binder ; body} ->
let%bind body = map_expression f body in

15
src/passes/11-self_mini_c/michelson_restrictions.ml
View File

@ -1,19 +1,8 @@
open Errors
open Mini_c
open Trace
module Errors = struct
let bad_self_address cst () =
let title = thunk @@
Format.asprintf "Wrong %a location" Stage_common.PP.constant cst in
let message = thunk @@
Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in
error title message ()
end
open Errors
let self_in_lambdas : expression -> expression result =
let self_in_lambdas : expression -> (expression,_) result =
fun e ->
match e.content with
| E_closure {binder=_ ; body} ->

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

@ -1,6 +1,13 @@
module Errors = Errors
open Errors
open Mini_c
open Trace
let get_t_function e = trace_option not_a_function @@ Mini_c.get_t_function e
let get_function e = trace_option not_a_function @@ Mini_c.get_function e
let aggregate_entry p f = trace_option could_not_aggregate_entry @@ Mini_c.aggregate_entry p f
let get_entry l n = trace_option could_not_aggregate_entry @@ Mini_c.get_entry l n
(* TODO hack to specialize map_expression to identity monad *)
let map_expression :
(expression -> expression) -> (expression -> expression) =

1
src/passes/12-compiler/compiler.ml
View File

@ -2,5 +2,6 @@ module Uncompiler = Uncompiler
module Program = Compiler_program
module Type = Compiler_type
module Environment = Compiler_environment
module Errors = Errors
include Program

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