diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 8c3720042..4dabdbb1e 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -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) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index 73e612b7e..59cf5c57e 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -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) \ No newline at end of file diff --git a/src/bin/cli_helpers.mli b/src/bin/cli_helpers.mli index f19e281a9..166394f65 100644 --- a/src/bin/cli_helpers.mli +++ b/src/bin/cli_helpers.mli @@ -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 \ No newline at end of file diff --git a/src/bin/dune b/src/bin/dune index 5d52779fc..6a1b82971 100644 --- a/src/bin/dune +++ b/src/bin/dune @@ -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) ) diff --git a/src/bin/formatter.ml b/src/bin/formatter.ml new file mode 100644 index 000000000..61b3719be --- /dev/null +++ b/src/bin/formatter.ml @@ -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; +} \ No newline at end of file diff --git a/src/main/compile/dune b/src/main/compile/dune index 6a900909f..f850f7fe1 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -2,6 +2,7 @@ (name compile) (public_name ligo.compile) (libraries + main_errors simple-utils tezos-utils parser diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 8d89c369f..e4de4887c 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -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 \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 diff --git a/src/main/compile/of_core.ml b/src/main/compile/of_core.ml index 27c6f6b55..931aee07d 100644 --- a/src/main/compile/of_core.ml +++ b/src/main/compile/of_core.ml @@ -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 -> diff --git a/src/main/compile/of_imperative.ml b/src/main/compile/of_imperative.ml index ed12a128e..50f5bf40a 100644 --- a/src/main/compile/of_imperative.ml +++ b/src/main/compile/of_imperative.ml @@ -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 diff --git a/src/main/compile/of_michelson.ml b/src/main/compile/of_michelson.ml index 93213152a..1c517a804 100644 --- a/src/main/compile/of_michelson.ml +++ b/src/main/compile/of_michelson.ml @@ -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 () diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index e782d253d..024493c2f 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -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) diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index f0611d4ba..c04cdb970 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -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 \ No newline at end of file diff --git a/src/main/compile/of_sugar.ml b/src/main/compile/of_sugar.ml index b52607af7..85988b558 100644 --- a/src/main/compile/of_sugar.ml +++ b/src/main/compile/of_sugar.ml @@ -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 diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 8bcbfd882..761badb3f 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -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 diff --git a/src/main/compile/utils.ml b/src/main/compile/utils.ml index ab8ac6503..4af43dafb 100644 --- a/src/main/compile/utils.ml +++ b/src/main/compile/utils.ml @@ -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 diff --git a/src/main/display.ml b/src/main/display.ml deleted file mode 100644 index ee9356b79..000000000 --- a/src/main/display.ml +++ /dev/null @@ -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 diff --git a/src/main/display.mli b/src/main/display.mli deleted file mode 100644 index 9dea6d65c..000000000 --- a/src/main/display.mli +++ /dev/null @@ -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 diff --git a/src/main/dune b/src/main/dune index 802ab2af3..b68862611 100644 --- a/src/main/dune +++ b/src/main/dune @@ -5,6 +5,7 @@ run compile uncompile + main_errors ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/main/main.ml b/src/main/main.ml index 77b8b4149..b2b366512 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -2,3 +2,4 @@ module Run = Run module Compile = Compile module Uncompile = Uncompile module Display = Display +module Formatter = Main_errors.Formatter diff --git a/src/main/main_errors/dune b/src/main/main_errors/dune new file mode 100644 index 000000000..c5dad72af --- /dev/null +++ b/src/main/main_errors/dune @@ -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 )) +) diff --git a/src/main/main_errors/formatter.ml b/src/main/main_errors/formatter.ml new file mode 100644 index 000000000..f74db24e1 --- /dev/null +++ b/src/main/main_errors/formatter.ml @@ -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 "@[Test '%s'@ %a@]" + name (error_ppformat' ~display_format) err + | `Test_run_tracer (ep, err) -> + Format.fprintf f "@[Running entrypoint '%s'@ %a@]" + ep (error_ppformat' ~display_format) err + | `Test_expect_tracer (expected, actual) -> + Format.fprintf f "@[Expected:@ %a@ got:@ %a@]" + Ast_core.PP.expression expected + Ast_core.PP.expression actual + | `Test_expect_n_tracer (i,err) -> + Format.fprintf f "@[Expect n=%d@ %a@]" + i (error_ppformat' ~display_format) err + | `Test_expect_exp_tracer (e,err) -> + Format.fprintf f "@[Expect %a@ %a@]" + Ast_core.PP.expression e + (error_ppformat' ~display_format) err + | `Test_expect_eq_n_tracer (i,err) -> + Format.fprintf f "@[Expected eq_n=%d@ %a@]" + i (error_ppformat' ~display_format) err + | `Test_internal t -> + Format.fprintf f "@[Internal error:@ %s@]" t + | `Test_md_file_tracer (md_file,s,grp,prg,err) -> + Format.fprintf f "@[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 "@[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 + "@[Invalid syntax name '%s'@ Hint: Use 'pascaligo', 'cameligo' or 'reasonligo'@]" + syntax + + | `Main_invalid_extension extension -> + Format.fprintf f + "@[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 "@[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 "@[Provided storage type does not match contract storage type@ %a@]" + (error_ppformat' ~display_format) err + + | `Main_unknown_failwith_type -> + Format.fprintf f "@[Execution failed with an unknown failwith type@]" + | `Main_unknown -> + Format.fprintf f "@[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 + "[Execution failed with %s@]" + value + | `Main_entrypoint_not_a_function -> Format.fprintf f "@[Given entrypoint is not a function@]" + | `Main_entrypoint_not_found -> Format.fprintf f "@[Missing entrypoint@]" + | `Main_invalid_amount a -> Format.fprintf f "@[Invalid amount %s@]" a + | `Main_invalid_address a -> Format.fprintf f "@[Invalid address %s@]" a + | `Main_invalid_timestamp t -> Format.fprintf f "@[Invalid timestamp notation %s@]" t + + | `Main_unparse_michelson_result _ -> Format.fprintf f "@[Error unparsing michelson result@]" + | `Main_parse_payload _ -> Format.fprintf f "@[Error parsing message@]" + | `Main_pack_payload _ -> Format.fprintf f "@[Error packing message@]" + | `Main_parse_michelson_input _ -> Format.fprintf f "@[Error parsing input@]" + | `Main_parse_michelson_code _ -> Format.fprintf f "@[Error parsing program code@]" + | `Main_michelson_execution_error _ -> Format.fprintf f "@[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 "@[%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; +} \ No newline at end of file diff --git a/src/main/main_errors/main_errors.ml b/src/main/main_errors/main_errors.ml new file mode 100644 index 000000000..b6b96cb14 --- /dev/null +++ b/src/main/main_errors/main_errors.ml @@ -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 \ No newline at end of file diff --git a/src/main/main_errors/types.ml b/src/main/main_errors/types.ml new file mode 100644 index 000000000..651f5fbfc --- /dev/null +++ b/src/main/main_errors/types.ml @@ -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 +] \ No newline at end of file diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 02e884840..1128c1c96 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -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 diff --git a/src/main/uncompile/dune b/src/main/uncompile/dune index 8762c6abf..d1b2d72eb 100644 --- a/src/main/uncompile/dune +++ b/src/main/uncompile/dune @@ -11,6 +11,7 @@ ast_typed mini_c transpiler + main_errors ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/main/uncompile/formatter.ml b/src/main/uncompile/formatter.ml new file mode 100644 index 000000000..dc92729fa --- /dev/null +++ b/src/main/uncompile/formatter.ml @@ -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 ; +} \ No newline at end of file diff --git a/src/main/uncompile/uncompile.ml b/src/main/uncompile/uncompile.ml index 3adf7445e..2a9546e5c 100644 --- a/src/main/uncompile/uncompile.ml +++ b/src/main/uncompile/uncompile.ml @@ -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 diff --git a/src/passes/01-parser/cameligo.ml b/src/passes/01-parser/cameligo.ml index 7ef89b360..cba4d223b 100644 --- a/src/passes/01-parser/cameligo.ml +++ b/src/passes/01-parser/cameligo.ml @@ -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 diff --git a/src/passes/01-parser/cameligo.mli b/src/passes/01-parser/cameligo.mli index 4181e6a58..d994acab6 100644 --- a/src/passes/01-parser/cameligo.mli +++ b/src/passes/01-parser/cameligo.mli @@ -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 diff --git a/src/passes/01-parser/cameligo/AST.ml b/src/passes/01-parser/cameligo/AST.ml index b1ffa4ed7..ec8797b3e 100644 --- a/src/passes/01-parser/cameligo/AST.ml +++ b/src/passes/01-parser/cameligo/AST.ml @@ -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 diff --git a/src/passes/01-parser/cameligo/ParserLog.ml b/src/passes/01-parser/cameligo/ParserLog.ml index ec5284852..36c8edec4 100644 --- a/src/passes/01-parser/cameligo/ParserLog.ml +++ b/src/passes/01-parser/cameligo/ParserLog.ml @@ -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} *) diff --git a/src/passes/01-parser/cameligo/ParserLog.mli b/src/passes/01-parser/cameligo/ParserLog.mli index 800ea4443..14fdc9bcd 100644 --- a/src/passes/01-parser/cameligo/ParserLog.mli +++ b/src/passes/01-parser/cameligo/ParserLog.mli @@ -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} *) diff --git a/src/passes/01-parser/errors.ml b/src/passes/01-parser/errors.ml new file mode 100644 index 000000000..04e315c56 --- /dev/null +++ b/src/passes/01-parser/errors.ml @@ -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 \ No newline at end of file diff --git a/src/passes/01-parser/formatter.ml b/src/passes/01-parser/formatter.ml new file mode 100644 index 000000000..14a16b7aa --- /dev/null +++ b/src/passes/01-parser/formatter.ml @@ -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; +} \ No newline at end of file diff --git a/src/passes/01-parser/parser.ml b/src/passes/01-parser/parser.ml index 068d36184..ba2c27cb6 100644 --- a/src/passes/01-parser/parser.ml +++ b/src/passes/01-parser/parser.ml @@ -1,5 +1,5 @@ module Pascaligo = Pascaligo module Cameligo = Cameligo module Reasonligo = Reasonligo - - +module Errors = Errors +module Formatter = Formatter \ No newline at end of file diff --git a/src/passes/01-parser/pascaligo.ml b/src/passes/01-parser/pascaligo.ml index b2c6ab9f4..265efe149 100644 --- a/src/passes/01-parser/pascaligo.ml +++ b/src/passes/01-parser/pascaligo.ml @@ -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 diff --git a/src/passes/01-parser/pascaligo.mli b/src/passes/01-parser/pascaligo.mli index 48ee3dadb..1e5b296a0 100644 --- a/src/passes/01-parser/pascaligo.mli +++ b/src/passes/01-parser/pascaligo.mli @@ -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 diff --git a/src/passes/01-parser/pascaligo/AST.ml b/src/passes/01-parser/pascaligo/AST.ml index ff9808302..d3266eaca 100644 --- a/src/passes/01-parser/pascaligo/AST.ml +++ b/src/passes/01-parser/pascaligo/AST.ml @@ -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 diff --git a/src/passes/01-parser/pascaligo/ParserLog.ml b/src/passes/01-parser/pascaligo/ParserLog.ml index 6cca06237..113f41446 100644 --- a/src/passes/01-parser/pascaligo/ParserLog.ml +++ b/src/passes/01-parser/pascaligo/ParserLog.ml @@ -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 *) diff --git a/src/passes/01-parser/pascaligo/ParserLog.mli b/src/passes/01-parser/pascaligo/ParserLog.mli index 7ae739571..558c51bff 100644 --- a/src/passes/01-parser/pascaligo/ParserLog.mli +++ b/src/passes/01-parser/pascaligo/ParserLog.mli @@ -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} *) diff --git a/src/passes/01-parser/reasonligo.ml b/src/passes/01-parser/reasonligo.ml index dea9eb5a8..f5ccdeb98 100644 --- a/src/passes/01-parser/reasonligo.ml +++ b/src/passes/01-parser/reasonligo.ml @@ -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 diff --git a/src/passes/01-parser/reasonligo.mli b/src/passes/01-parser/reasonligo.mli index e51ebdb12..5f96fd4f0 100644 --- a/src/passes/01-parser/reasonligo.mli +++ b/src/passes/01-parser/reasonligo.mli @@ -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 diff --git a/src/passes/02-concrete_to_imperative/cameligo.ml b/src/passes/02-concrete_to_imperative/cameligo.ml index ed32b2c27..5ccfaf365 100644 --- a/src/passes/02-concrete_to_imperative/cameligo.ml +++ b/src/passes/02-concrete_to_imperative/cameligo.ml @@ -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 diff --git a/src/passes/02-concrete_to_imperative/cameligo.mli b/src/passes/02-concrete_to_imperative/cameligo.mli index f9e4b852a..2a16d6f6a 100644 --- a/src/passes/02-concrete_to_imperative/cameligo.mli +++ b/src/passes/02-concrete_to_imperative/cameligo.mli @@ -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 \ No newline at end of file diff --git a/src/passes/02-concrete_to_imperative/concrete_to_imperative.ml b/src/passes/02-concrete_to_imperative/concrete_to_imperative.ml index 846da5ab3..09f459ef4 100644 --- a/src/passes/02-concrete_to_imperative/concrete_to_imperative.ml +++ b/src/passes/02-concrete_to_imperative/concrete_to_imperative.ml @@ -1,2 +1,4 @@ +module Errors_cameligo = Errors_cameligo +module Errors_pascaligo = Errors_pascaligo module Pascaligo = Pascaligo module Cameligo = Cameligo diff --git a/src/passes/02-concrete_to_imperative/dune b/src/passes/02-concrete_to_imperative/dune index 1aa60f304..9c9247162 100644 --- a/src/passes/02-concrete_to_imperative/dune +++ b/src/passes/02-concrete_to_imperative/dune @@ -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 diff --git a/src/passes/02-concrete_to_imperative/errors_cameligo.ml b/src/passes/02-concrete_to_imperative/errors_cameligo.ml new file mode 100644 index 000000000..f34090187 --- /dev/null +++ b/src/passes/02-concrete_to_imperative/errors_cameligo.ml @@ -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 + "@[%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 + "@[%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 + "@[%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 + "@[%a@Untyped function parameters are not supported yet@]" + Location.pp_lift variable.Region.region + | `Concrete_cameligo_recursive_fun reg -> + Format.fprintf f + "@[%a@Untyped recursive functions are not supported yet@]" + Location.pp_lift reg + | `Concrete_cameligo_unsupported_tuple_pattern p -> + Format.fprintf f + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%a@Unsupported singleton string type@]" + Location.pp_lift (Raw.type_expr_to_region te) + | `Concrete_cameligo_abstraction_tracer (expr,err) -> + Format.fprintf f + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%a@%s does not have the right number of argument@]" + Location.pp loc + name + | `Concrete_cameligo_program_tracer (decl,err) -> + Format.fprintf f + "@[%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 \ No newline at end of file diff --git a/src/passes/02-concrete_to_imperative/errors_pascaligo.ml b/src/passes/02-concrete_to_imperative/errors_pascaligo.ml new file mode 100644 index 000000000..dfb59afef --- /dev/null +++ b/src/passes/02-concrete_to_imperative/errors_pascaligo.ml @@ -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 + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%a@Unsupported singleton string type@]" + Location.pp_lift (Raw.type_expr_to_region te) + | `Concrete_pascaligo_unsupported_deep_some_pattern p -> + Format.fprintf f + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%a@%s does not have the right number of argument@]" + Location.pp loc + name + | `Concrete_pascaligo_instruction_tracer (inst,err) -> + Format.fprintf f + "@[%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 + "@[%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 \ No newline at end of file diff --git a/src/passes/02-concrete_to_imperative/pascaligo.ml b/src/passes/02-concrete_to_imperative/pascaligo.ml index 0f999db18..51365df69 100644 --- a/src/passes/02-concrete_to_imperative/pascaligo.ml +++ b/src/passes/02-concrete_to_imperative/pascaligo.ml @@ -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 diff --git a/src/passes/02-concrete_to_imperative/pascaligo.mli b/src/passes/02-concrete_to_imperative/pascaligo.mli index cfa945fb9..0c7730c0f 100644 --- a/src/passes/02-concrete_to_imperative/pascaligo.mli +++ b/src/passes/02-concrete_to_imperative/pascaligo.mli @@ -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 diff --git a/src/passes/03-self_ast_imperative/entrypoints_length_limit.ml b/src/passes/03-self_ast_imperative/entrypoints_length_limit.ml index 804cc7f92..d1a562ed1 100644 --- a/src/passes/03-self_ast_imperative/entrypoints_length_limit.ml +++ b/src/passes/03-self_ast_imperative/entrypoints_length_limit.ml @@ -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 diff --git a/src/passes/03-self_ast_imperative/errors.ml b/src/passes/03-self_ast_imperative/errors.ml new file mode 100644 index 000000000..19553aaf2 --- /dev/null +++ b/src/passes/03-self_ast_imperative/errors.ml @@ -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 + "@[%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 + "@[%a@ Badly formatted timestamp '%s'@]" + Location.pp e.location + t + | `Self_ast_imperative_bad_format_literal (e,_errs) -> + Format.fprintf f + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%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 + "@[%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 \ No newline at end of file diff --git a/src/passes/03-self_ast_imperative/helpers.ml b/src/passes/03-self_ast_imperative/helpers.ml index c6d15ae50..8831b8588 100644 --- a/src/passes/03-self_ast_imperative/helpers.ml +++ b/src/passes/03-self_ast_imperative/helpers.ml @@ -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) = diff --git a/src/passes/03-self_ast_imperative/literals.ml b/src/passes/03-self_ast_imperative/literals.ml index 96914359a..256fa8f5a 100644 --- a/src/passes/03-self_ast_imperative/literals.ml +++ b/src/passes/03-self_ast_imperative/literals.ml @@ -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 [] ) diff --git a/src/passes/03-self_ast_imperative/none_variant.ml b/src/passes/03-self_ast_imperative/none_variant.ml index 894d55830..77f44b691 100644 --- a/src/passes/03-self_ast_imperative/none_variant.ml +++ b/src/passes/03-self_ast_imperative/none_variant.ml @@ -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 ]} diff --git a/src/passes/03-self_ast_imperative/self_ast_imperative.ml b/src/passes/03-self_ast_imperative/self_ast_imperative.ml index b0270ebd0..b664c1a40 100644 --- a/src/passes/03-self_ast_imperative/self_ast_imperative.ml +++ b/src/passes/03-self_ast_imperative/self_ast_imperative.ml @@ -1,4 +1,5 @@ open Trace +module Errors = Errors let all_expression_mapper = [ Tezos_type_annotation.peephole_expression ; diff --git a/src/passes/03-self_ast_imperative/tezos_type_annotation.ml b/src/passes/03-self_ast_imperative/tezos_type_annotation.ml index 163e061d2..240764f77 100644 --- a/src/passes/03-self_ast_imperative/tezos_type_annotation.ml +++ b/src/passes/03-self_ast_imperative/tezos_type_annotation.ml @@ -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 diff --git a/src/passes/04-imperative_to_sugar/errors.ml b/src/passes/04-imperative_to_sugar/errors.ml new file mode 100644 index 000000000..983fea9ef --- /dev/null +++ b/src/passes/04-imperative_to_sugar/errors.ml @@ -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 + "@[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 \ No newline at end of file diff --git a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml index 5b826ef38..47ce0cd9e 100644 --- a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml @@ -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} -> diff --git a/src/passes/05-self_ast_sugar/helpers.ml b/src/passes/05-self_ast_sugar/helpers.ml index 7157646c6..f8dbd6bf6 100644 --- a/src/passes/05-self_ast_sugar/helpers.ml +++ b/src/passes/05-self_ast_sugar/helpers.ml @@ -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) = diff --git a/src/passes/06-sugar_to_core/sugar_to_core.ml b/src/passes/06-sugar_to_core/sugar_to_core.ml index 67f1f3072..e5b91b124 100644 --- a/src/passes/06-sugar_to_core/sugar_to_core.ml +++ b/src/passes/06-sugar_to_core/sugar_to_core.ml @@ -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} -> diff --git a/src/passes/07-self_ast_core/helpers.ml b/src/passes/07-self_ast_core/helpers.ml index cfbb6a3ca..ad15266be 100644 --- a/src/passes/07-self_ast_core/helpers.ml +++ b/src/passes/07-self_ast_core/helpers.ml @@ -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 diff --git a/src/passes/08-typer-common/constant_typers.ml b/src/passes/08-typer-common/constant_typers.ml new file mode 100644 index 000000000..7abc2b521 --- /dev/null +++ b/src/passes/08-typer-common/constant_typers.ml @@ -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") diff --git a/src/passes/08-typer-common/constant_typers_new.ml b/src/passes/08-typer-common/constant_typers_new.ml new file mode 100644 index 000000000..58e856f21 --- /dev/null +++ b/src/passes/08-typer-common/constant_typers_new.ml @@ -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 + diff --git a/src/passes/08-typer-common/dune b/src/passes/08-typer-common/dune new file mode 100644 index 000000000..c5d55b05f --- /dev/null +++ b/src/passes/08-typer-common/dune @@ -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 )) +) \ No newline at end of file diff --git a/src/passes/08-typer-common/errors.ml b/src/passes/08-typer-common/errors.ml new file mode 100644 index 000000000..915b896b7 --- /dev/null +++ b/src/passes/08-typer-common/errors.ml @@ -0,0 +1,1155 @@ +open Trace +open Simple_utils.Display + +let stage = "typer" + +type typer_error = [ + | `Typer_michelson_comb_no_record of Location.t + | `Typer_michelson_comb_no_variant of Location.t + | `Typer_unbound_type_variable of Ast_typed.Environment.t * Ast_core.type_variable * Location.t + | `Typer_unbound_variable of Ast_typed.Environment.t * Ast_core.expression_variable * Location.t + | `Typer_match_empty_variant of Ast_core.matching_expr * Location.t + | `Typer_match_missing_case of Ast_core.matching_expr * Location.t + | `Typer_match_redundant_case of Ast_core.matching_expr * Location.t + | `Typer_unbound_constructor of Ast_typed.Environment.t * Ast_core.constructor' * Location.t + | `Typer_redundant_constructor of Ast_typed.Environment.t * Ast_core.constructor' * Location.t + | `Typer_michelson_or_no_annotation of Ast_core.constructor' * Location.t + | `Typer_match_tuple_wrong_arity of Ast_typed.type_expression_list * Ast_core.expression_variable list * Location.t + | `Typer_program_tracer of Ast_core.program * typer_error + | `Typer_constant_declaration_tracer of Ast_core.expression_variable * Ast_core.expr * (Ast_typed.type_expression option) * typer_error + | `Typer_match_error of Ast_core.matching_expr * Ast_typed.type_expression * Location.t + | `Typer_needs_annotation of Ast_core.expression * string + | `Typer_fvs_in_create_contract_lambda of Ast_core.expression * Ast_typed.expression_variable + | `Typer_create_contract_lambda of Ast_core.constant' * Ast_core.expression + | `Typer_should_be_a_function_type of Ast_typed.type_expression * Ast_core.expression + | `Typer_bad_record_access of Ast_core.label * Ast_core.expression * Ast_typed.type_expression * Location.t + | `Typer_expression_tracer of Ast_core.expression * typer_error + | `Typer_record_access_tracer of Ast_typed.expression * typer_error + | `Typer_assert_equal of Ast_typed.type_expression * Ast_typed.type_expression + | `Typer_corner_case of string + | `Typer_bad_collect_loop of Ast_typed.type_expression * Location.t + | `Typer_declaration_order_record of Location.t + | `Typer_declaration_order_variant of Location.t + | `Typer_too_small_record of Location.t + | `Typer_too_small_variant of Location.t + | `Typer_expected_record of Ast_typed.type_expression + | `Typer_expected_variant of Ast_typed.type_expression + | `Typer_wrong_param_number of string * int * Ast_typed.type_expression list + | `Typer_bad_list_fold_tracer of typer_error + | `Typer_bad_set_fold_tracer of typer_error + | `Typer_bad_map_fold_tracer of typer_error + | `Typer_expected_function of Ast_typed.type_expression + | `Typer_expected_pair of Ast_typed.type_expression + | `Typer_expected_list of Ast_typed.type_expression + | `Typer_expected_set of Ast_typed.type_expression + | `Typer_expected_map of Ast_typed.type_expression + | `Typer_expected_big_map of Ast_typed.type_expression + | `Typer_expected_option of Ast_typed.type_expression + | `Typer_expected_nat of Ast_typed.type_expression + | `Typer_expected_bytes of Ast_typed.type_expression + | `Typer_expected_key of Ast_typed.type_expression + | `Typer_expected_signature of Ast_typed.type_expression + | `Typer_expected_contract of Ast_typed.type_expression + | `Typer_expected_string of Ast_typed.type_expression + | `Typer_expected_key_hash of Ast_typed.type_expression + | `Typer_expected_mutez of Ast_typed.type_expression + | `Typer_expected_op_list of Ast_typed.type_expression + | `Typer_expected_int of Ast_typed.type_expression + | `Typer_expected_bool of Ast_typed.type_expression + | `Typer_not_matching of Ast_typed.type_expression * Ast_typed.type_expression + | `Typer_not_annotated + | `Typer_bad_substraction + | `Typer_wrong_size of Ast_typed.type_expression + | `Typer_wrong_neg of Ast_typed.type_expression + | `Typer_wrong_not of Ast_typed.type_expression + | `Typer_typeclass_error of Ast_typed.type_expression list list * Ast_typed.type_expression list + | `Typer_converter of Ast_typed.type_expression + | `Typer_uncomparable_types of Ast_typed.type_expression * Ast_typed.type_expression + | `Typer_comparator_composed of Ast_typed.type_expression + | `Typer_constant_decl_tracer of Ast_core.expression_variable * Ast_core.expr * Ast_typed.type_expression option * typer_error + | `Typer_match_variant_tracer of Ast_core.matching_expr * typer_error + | `Typer_unrecognized_type_operator of Ast_core.type_expression + |`Typer_expected_ascription of Ast_core.expression +] + +let michelson_comb_no_record (loc:Location.t) = `Typer_michelson_comb_no_record loc +let michelson_comb_no_variant (loc:Location.t) = `Typer_michelson_comb_no_variant loc +let unbound_type_variable (e:Ast_typed.Environment.t) (tv:Ast_core.type_variable) (loc:Location.t) = `Typer_unbound_type_variable (e,tv,loc) +let unbound_variable (e:Ast_typed.Environment.t) (v:Ast_core.expression_variable) (loc:Location.t) = `Typer_unbound_variable (e,v,loc) +let match_empty_variant (m:Ast_core.matching_expr) (loc:Location.t) = `Typer_match_empty_variant (m,loc) +let match_missing_case (m:Ast_core.matching_expr) (loc:Location.t) = `Typer_match_missing_case (m,loc) +let match_redundant_case (m:Ast_core.matching_expr) (loc:Location.t) = `Typer_match_redundant_case (m,loc) +let unbound_constructor (e:Ast_typed.Environment.t) (c:Ast_core.constructor') (loc:Location.t) = `Typer_unbound_constructor (e,c,loc) +let redundant_constructor (e:Ast_typed.Environment.t) (c:Ast_core.constructor') (loc:Location.t) = `Typer_redundant_constructor (e,c,loc) +let michelson_or (c:Ast_core.constructor') (loc:Location.t) = `Typer_michelson_or_no_annotation (c,loc) +let match_tuple_wrong_arity (expected: Ast_typed.type_expression_list) (actual:Ast_core.expression_variable list) (loc:Location.t) = + `Typer_match_tuple_wrong_arity (expected,actual,loc) +let program_error_tracer (p:Ast_core.program) (err:typer_error) = `Typer_program_tracer (p,err) +let constant_declaration_error_tracer (name:Ast_core.expression_variable) (ae:Ast_core.expr) (expected: Ast_typed.type_expression option) (err:typer_error) = + `Typer_constant_declaration_tracer (name,ae,expected,err) +let match_error ~(expected: Ast_core.matching_expr) ~(actual: Ast_typed.type_expression) (loc:Location.t) = + `Typer_match_error (expected,actual,loc) +let needs_annotation (e:Ast_core.expression) (case:string) = `Typer_needs_annotation (e,case) +let fvs_in_create_contract_lambda (e:Ast_core.expression) (fvar:Ast_typed.expression_variable) = `Typer_fvs_in_create_contract_lambda (e,fvar) +let create_contract_lambda (cst : Ast_core.constant') (e : Ast_core.expression) = `Typer_create_contract_lambda (cst,e) +let type_error_approximate ~(actual: Ast_typed.type_expression) ~(expression:Ast_core.expression) = + `Typer_should_be_a_function_type (actual,expression) +let bad_record_access (field:Ast_core.label) (ae:Ast_core.expression) (t:Ast_typed.type_expression) (loc:Location.t) = + `Typer_bad_record_access (field,ae,t,loc) +let expression_tracer ae err = `Typer_expression_tracer (ae,err) +let record_access_tracer (e:Ast_typed.expression) (err:typer_error) = `Typer_record_access_tracer (e,err) +let assert_equal (expected:Ast_typed.type_expression) (actual:Ast_typed.type_expression) = `Typer_assert_equal (expected,actual) +let corner_case desc = `Typer_corner_case desc +let bad_collect_loop (t:Ast_typed.type_expression) (loc:Location.t) = `Typer_bad_collect_loop (t,loc) +let declaration_order_record (loc:Location.t) = `Typer_declaration_order_record loc +let declaration_order_variant (loc:Location.t) = `Typer_declaration_order_variant loc +let too_small_record (loc:Location.t) = `Typer_too_small_record loc +let too_small_variant (loc:Location.t) = `Typer_too_small_variant loc +let expected_record (t:Ast_typed.type_expression) = `Typer_expected_record t +let expected_variant (t:Ast_typed.type_expression) = `Typer_expected_variant t +let wrong_param_number (name:string) (expected:int) (actual:Ast_typed.type_expression list) = + `Typer_wrong_param_number (name,expected,actual) +let bad_list_fold_tracer err = `Typer_bad_list_fold_tracer err +let bad_set_fold_tracer err = `Typer_bad_set_fold_tracer err +let bad_map_fold_tracer err = `Typer_bad_map_fold_tracer err +let expected_function (t:Ast_typed.type_expression) = `Typer_expected_function t +let expected_pair (t:Ast_typed.type_expression) = `Typer_expected_pair t +let expected_list (t:Ast_typed.type_expression) = `Typer_expected_list t +let expected_set (t:Ast_typed.type_expression) = `Typer_expected_set t +let expected_map (t:Ast_typed.type_expression) = `Typer_expected_map t +let expected_big_map (t:Ast_typed.type_expression) = `Typer_expected_big_map t +let expected_option (t:Ast_typed.type_expression) = `Typer_expected_option t +let expected_nat (t:Ast_typed.type_expression) = `Typer_expected_nat t +let expected_bytes (t:Ast_typed.type_expression) = `Typer_expected_bytes t +let expected_key (t:Ast_typed.type_expression) = `Typer_expected_key t +let expected_signature (t:Ast_typed.type_expression) = `Typer_expected_signature t +let expected_contract (t:Ast_typed.type_expression) = `Typer_expected_contract t +let expected_string (t:Ast_typed.type_expression) = `Typer_expected_string t +let expected_key_hash (t:Ast_typed.type_expression) = `Typer_expected_key_hash t +let expected_mutez (t:Ast_typed.type_expression) = `Typer_expected_mutez t +let expected_op_list (t:Ast_typed.type_expression) = `Typer_expected_op_list t +let expected_int (t:Ast_typed.type_expression) = `Typer_expected_int t +let expected_bool (t:Ast_typed.type_expression) = `Typer_expected_bool t +let expected_ascription (t:Ast_core.expression) = `Typer_expected_ascription t +let not_matching (t1:Ast_typed.type_expression) (t2:Ast_typed.type_expression) = `Typer_not_matching (t1,t2) +let not_annotated = `Typer_not_annotated +let bad_substraction = `Typer_bad_substraction +let wrong_size (t:Ast_typed.type_expression) = `Typer_wrong_size t +let wrong_neg (t:Ast_typed.type_expression) = `Typer_wrong_neg t +let wrong_not (t:Ast_typed.type_expression) = `Typer_wrong_not t +let typeclass_error (exps:Ast_typed.type_expression list list) (acts:Ast_typed.type_expression list) = + `Typer_typeclass_error (exps,acts) +let wrong_converter (t:Ast_typed.type_expression) = `Typer_converter t +let uncomparable_types (a:Ast_typed.type_expression) (b:Ast_typed.type_expression) = + `Typer_uncomparable_types (a,b) +let comparator_composed (a:Ast_typed.type_expression) = `Typer_comparator_composed a +let unrecognized_type_op (e:Ast_core.type_expression) = `Typer_unrecognized_type_operator e + +(* new typer errors *) +let constant_declaration_tracer (name: Ast_core.expression_variable) (ae:Ast_core.expr) (expected: Ast_typed.type_expression option) (err:typer_error) = + `Typer_constant_decl_tracer (name,ae,expected,err) +let in_match_variant_tracer (ae:Ast_core.matching_expr) (err:typer_error) = + `Typer_match_variant_tracer (ae,err) + +let rec error_ppformat : display_format:string display_format -> + Format.formatter -> typer_error -> unit = + fun ~display_format f a -> + match display_format with + | Human_readable | Dev -> ( + match a with + | `Typer_michelson_comb_no_record loc -> + Format.fprintf f + "@[%a@ Bad michelson pair comb type parameter@ can only be used on a record type@]" + Location.pp loc + | `Typer_michelson_comb_no_variant loc -> + Format.fprintf f + "@[%a@ Bad michelson or comb type parameter@ can only be used on a variant type@]" + Location.pp loc + | `Typer_unbound_type_variable (env,tv,loc) -> + Format.fprintf f + "@[%a@ Unbound type variable '%a'@ %a@]" + Location.pp loc + Ast_core.PP.type_variable tv + Ast_typed.Environment.PP.environment env + | `Typer_unbound_variable (env,v,loc) -> + Format.fprintf f + "@[%a@ Unbound variable '%a'@ %a@]" + Location.pp loc + Ast_core.PP.expression_variable v + Ast_typed.Environment.PP.environment env + | `Typer_match_empty_variant (m,loc) -> + Format.fprintf f + "@[%a@ Match with no case: @ %a@]" + Location.pp loc + Ast_core.PP.matching_type m + | `Typer_match_missing_case (m,loc) -> + Format.fprintf f + "@[%a@ Missing match case in: @ %a@]" + Location.pp loc + Ast_core.PP.matching_type m + | `Typer_match_redundant_case (m,loc) -> + Format.fprintf f + "@[%a@ Redundant match case in: @ %a@]" + Location.pp loc + Ast_core.PP.matching_type m + | `Typer_unbound_constructor (env,c,loc) -> + Format.fprintf f + "@[%a@ Unbound constructor %a@ %a@]" + Location.pp loc + Ast_core.PP.constructor c + Ast_typed.Environment.PP.environment env + | `Typer_redundant_constructor (env,c,loc) -> + Format.fprintf f + "@[%a@ Redundant constructor:@ %a@ %a@]" + Location.pp loc + Ast_core.PP.constructor c + Ast_typed.Environment.PP.environment env + | `Typer_michelson_or_no_annotation (c,loc) -> + Format.fprintf f + "@[%a@ michelson_or contructor %a must be annotated with a sum type@]" + Location.pp loc + Ast_core.PP.constructor c + | `Typer_match_tuple_wrong_arity (expected,actual,loc) -> + Format.fprintf f + "@[%a@ Matching tuple of different size. Expected size of %i but got %i@]" + Location.pp loc + (List.length expected) + (List.length actual) + | `Typer_program_tracer (_program,err) -> + Format.fprintf f + "%a" + (error_ppformat ~display_format) err + | `Typer_constant_declaration_tracer (name,ae,_,err) -> + Format.fprintf f + "@[%a@ Constant declaration '%a'@ %a@]" + Location.pp ae.location + Ast_core.PP.expression_variable name + (error_ppformat ~display_format) err + | `Typer_match_error (expected,actual,loc) -> + Format.fprintf f + "@[%a@ Typing match:@ expected %a got %a@]" + Location.pp loc + Ast_core.PP.matching_type expected + Ast_typed.PP.type_expression actual + | `Typer_needs_annotation (exp,case) -> + Format.fprintf f + "@[%a@ '%s' needs to be annotated with its type@]" + Location.pp exp.location + case + | `Typer_fvs_in_create_contract_lambda (e,fvar) -> + Format.fprintf f + "@[%a@ Free variable '%a' is not allowed in CREATE_CONTRACT lambda@]" + Location.pp e.location + Ast_typed.PP.expression_variable fvar + | `Typer_create_contract_lambda (cst,e) -> + Format.fprintf f + "@[%a@ %a first argument must be inlined using a lambda@]" + Location.pp e.location + Ast_core.PP.constant cst + | `Typer_should_be_a_function_type (actual,e) -> + Format.fprintf f + "@[%a@ Expected a function type but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression actual + | `Typer_bad_record_access (field,ae,_t,loc) -> + Format.fprintf f + "@[%a@ Invalid record field '%a' in %a@]" + Location.pp loc + Ast_core.PP.label field + Ast_core.PP.expression ae + | `Typer_expression_tracer (_,err) + | `Typer_record_access_tracer (_,err) -> + error_ppformat ~display_format f err + | `Typer_assert_equal (expected,actual) -> + Format.fprintf f + "@[Bad types:@ expected %a@ got %a@]" + Ast_typed.PP.type_expression expected + Ast_typed.PP.type_expression actual + | `Typer_corner_case desc -> + Format.fprintf f + "@[%s@]" + desc + | `Typer_bad_collect_loop (t,loc) -> + Format.fprintf f + "@[%a@ Loops over collections expect lists, sets or maps but got type %a@]" + Location.pp loc + Ast_typed.PP.type_expression t + | `Typer_declaration_order_record _loc -> + Format.fprintf f + "@[Can't retrieve type declaration order in the converted record, you need to annotate it@]" + | `Typer_declaration_order_variant loc -> + Format.fprintf f + "@[%a@ Can't retrieve type declaration order in the converted variant, you need to annotate it@]" + Location.pp loc + | `Typer_too_small_record loc -> + Format.fprintf f + "@[%a@ Converted record must have at least two elements@]" + Location.pp loc + | `Typer_too_small_variant loc -> + Format.fprintf f + "@[%a@ Converted variant must have at least two elements@]" + Location.pp loc + | `Typer_expected_record t -> + Format.fprintf f + "@[%a@ Expected a record but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_variant t -> + Format.fprintf f + "@[%a@ Expected a variant but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_wrong_param_number (name,expected,actual) -> + Format.fprintf f + "@[%a@ Constant %s has the wrong number of parameters@ expected %d, got %d @]" + Location.pp_lift (List.fold_left (fun a (t:Ast_typed.type_expression) -> match t.location with File reg -> Region.cover a reg | Virtual _ -> a) Region.ghost actual) + name + expected (List.length actual) + | `Typer_bad_list_fold_tracer err -> + Format.fprintf f + "@[Badly typed list fold@]%a" + (error_ppformat ~display_format) err + | `Typer_bad_set_fold_tracer err -> + Format.fprintf f + "@[Badly typed set fold@]%a" + (error_ppformat ~display_format) err + | `Typer_bad_map_fold_tracer err -> + Format.fprintf f + "@[Badly typed map fold@]%a" + (error_ppformat ~display_format) err + | `Typer_expected_function e -> + Format.fprintf f + "@[%a@ Expected a function but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_pair e -> + Format.fprintf f + "@[%a@ Expected a pair but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_list e -> + Format.fprintf f + "@[%a@ Expected a list but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_set e -> + Format.fprintf f + "@[%a@ Expected a set but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_map e -> + Format.fprintf f + "@[%a@ Expected a map but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_big_map e -> + Format.fprintf f + "@[%a@ Expected a big map but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_option e -> + Format.fprintf f + "@[%a@ Expected an option but got %a@]" + Location.pp e.location + Ast_typed.PP.type_expression e + | `Typer_expected_nat t -> + Format.fprintf f + "@[%a@ Expected a nat but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_bytes t -> + Format.fprintf f + "@[%a@ Expected bytes but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_key t -> + Format.fprintf f + "@[%a@ Expected a key but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_signature t -> + Format.fprintf f + "@[%a@ Expected a signature but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_contract t -> + Format.fprintf f + "@[%a@ Expected a contract but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_string t -> + Format.fprintf f + "@[%a@ Expected a string but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_key_hash t -> + Format.fprintf f + "@[%a@ Expected a key hash but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_mutez t -> + Format.fprintf f + "@[%a@ Expected a mutez but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_op_list t -> + Format.fprintf f + "@[%a@ Expected a list of operations but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_int t -> + Format.fprintf f + "@[%a@ Expected an int of operations but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_expected_bool t -> + Format.fprintf f + "@[%a@ Expected a bool of operations but got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_not_matching (t1,t2) -> + Format.fprintf f + "@[Types not matching:@ %a - %a@ %a - %a@]" + Location.pp t1.location Ast_typed.PP.type_expression t1 + Location.pp t2.location Ast_typed.PP.type_expression t2 + | `Typer_not_annotated -> + Format.fprintf f "@[Not annotated@]" + | `Typer_bad_substraction -> + Format.fprintf f "@[Bad substraction, bad parameters@]" + | `Typer_wrong_size t -> + Format.fprintf f + "@[%a@ should be of type map, list\ + string, byte or set,@ got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_wrong_neg t -> + Format.fprintf f + "@[%a@ should be of type nat or int,@ got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_wrong_not t -> + Format.fprintf f + "@[%a@ should be of type bool, nat or int,@ got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_typeclass_error (exps,acts) -> + let open Simple_utils.PP_helpers in + let printl printer ppf args = + Format.fprintf ppf "(%a)" (list_sep printer (const " , ")) args in + Format.fprintf f + "@[Expected arguments with one of the following combinations of type:@ %a@,but got %a@]" + (list_sep (printl Ast_typed.PP.type_expression) (const " or ")) exps + (list_sep Ast_typed.PP.type_expression (const " , ")) acts + | `Typer_converter t -> + Format.fprintf f + "@[%a@ Converters can only be used on records or variants,@ got %a@]" + Location.pp t.location + Ast_typed.PP.type_expression t + | `Typer_uncomparable_types (a,b) -> + Format.fprintf f + "@[Those two types are not comparable:@ %a - %a@ %a - %a@]" + Location.pp a.location + Ast_typed.PP.type_expression a + Location.pp b.location + Ast_typed.PP.type_expression b + | `Typer_comparator_composed a -> + Format.fprintf f + "@[%a@ Only composed types of not more than two element are allowed to be compared@]" + Location.pp a.location + | `Typer_constant_decl_tracer (_name,_ae,_expected,err) -> + Format.fprintf f + "%a" (error_ppformat ~display_format) err + | `Typer_match_variant_tracer (_ae,err) -> + Format.fprintf f + "%a" (error_ppformat ~display_format) err + | `Typer_unrecognized_type_operator e -> + Format.fprintf f + "@[%a@ unrecognized type operator %a@]" + Location.pp e.location + Ast_core.PP.type_expression e + | `Typer_expected_ascription t -> + Format.fprintf f + "@[%a@ expected ascription but got %a@]" + Location.pp t.location + Ast_core.PP.expression t + ) + +let rec error_jsonformat : typer_error -> J.t = fun a -> + let json_error ~stage ~content = + `Assoc [ + ("status", `String "error") ; + ("stage", `String stage) ; + ("content", content )] + in + match a with + | `Typer_michelson_comb_no_record loc -> + let message = `String "michelson pair comb can only be used on a record type" in + let loc = Format.asprintf "%a" Location.pp loc in + let content = `Assoc [ + ("message", message); + ("location", `String loc) + ] in + json_error ~stage ~content + | `Typer_michelson_comb_no_variant loc -> + let message = `String "michelson or comb can only be used on a variant type" in + let loc = Format.asprintf "%a" Location.pp loc in + let content = `Assoc [ + ("message", message); + ("location", `String loc) + ] in + json_error ~stage ~content + | `Typer_unbound_type_variable (env,tv,loc) -> + let message = `String "unbound type variable" in + let loc = Format.asprintf "%a" Location.pp loc in + let value = Format.asprintf "%a" Ast_core.PP.type_variable tv in + let env = Format.asprintf "%a" Ast_typed.Environment.PP.environment env in + let content = `Assoc [ + ("message", message); + ("location", `String loc); + ("value", `String value); + ("env", `String env); + ] in + json_error ~stage ~content + | `Typer_unbound_variable (env,v,loc) -> + let message = `String "unbound type variable" in + let loc = Format.asprintf "%a" Location.pp loc in + let value = Format.asprintf "%a" Ast_core.PP.expression_variable v in + let env = Format.asprintf "%a" Ast_typed.Environment.PP.environment env in + let content = `Assoc [ + ("message", message); + ("location", `String loc); + ("value", `String value); + ("env", `String env); + ] in + json_error ~stage ~content + | `Typer_match_empty_variant (m,loc) -> + let message = `String "Match with no case" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let value = `String (Format.asprintf "%a" Ast_core.PP.matching_type m) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_match_missing_case (m,loc) -> + let message = `String "Missing match case" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let value = `String (Format.asprintf "%a" Ast_core.PP.matching_type m) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_match_redundant_case (m,loc) -> + let message = `String "Redundant case in match cases" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let value = `String (Format.asprintf "%a" Ast_core.PP.matching_type m) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_unbound_constructor (env,c,loc) -> + let message = `String "unbound type variable" in + let loc = Format.asprintf "%a" Location.pp loc in + let value = Format.asprintf "%a" Ast_core.PP.constructor c in + let env = Format.asprintf "%a" Ast_typed.Environment.PP.environment env in + let content = `Assoc [ + ("message", message); + ("location", `String loc); + ("value", `String value); + ("env", `String env); + ] in + json_error ~stage ~content + | `Typer_redundant_constructor (env,c,loc) -> + let message = `String "redundant constructor" in + let loc = Format.asprintf "%a" Location.pp loc in + let value = Format.asprintf "%a" Ast_core.PP.constructor c in + let env = Format.asprintf "%a" Ast_typed.Environment.PP.environment env in + let content = `Assoc [ + ("message", message); + ("location", `String loc); + ("value", `String value); + ("env", `String env); + ] in + json_error ~stage ~content + | `Typer_michelson_or_no_annotation (c,loc) -> + let message = `String "michelson_or must be annotated with a sum type" in + let loc = Format.asprintf "%a" Location.pp loc in + let value = Format.asprintf "%a" Ast_core.PP.constructor c in + let content = `Assoc [ + ("message", message); + ("location", `String loc); + ("value", `String value); + ] in + json_error ~stage ~content + | `Typer_match_tuple_wrong_arity (expected,actual,loc) -> + let message = `String "Matching tuple of different size" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let expected = `Int (List.length expected) in + let actual = `Int (List.length actual) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("actual", actual); + ("expected", expected); + ] in + json_error ~stage ~content + | `Typer_program_tracer (p,err) -> + let message = `String "Typing program" in + let over = List.fold_left (fun a (p:Ast_core.declaration Location.wrap) -> match p.location with File reg -> Region.cover a reg | Virtual _ -> a) Region.ghost p in + let loc = `String (Format.asprintf "%a" Location.pp_lift over) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_constant_declaration_tracer (name,ae,Some t,err) -> + let message = `String "Typing constant declaration" in + let loc = `String (Format.asprintf "%a" Location.pp ae.location) in + let name = `String (Format.asprintf "%a" Ast_core.PP.expression_variable name) in + let expected = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("name", name); + ("expected", expected); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_constant_declaration_tracer (name,ae,None,err) -> + let message = `String "Typing constant declaration" in + let loc = `String (Format.asprintf "%a" Location.pp ae.location) in + let name = `String (Format.asprintf "%a" Ast_core.PP.expression_variable name) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("name", name); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_match_error (expected,actual,loc) -> + let message = `String "Typing match" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let expected = `String (Format.asprintf "%a" Ast_core.PP.matching_type expected) in + let actual = `String (Format.asprintf "%a" Ast_typed.PP.type_expression actual) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("actual", actual); + ("expected", expected); + ] in + json_error ~stage ~content + | `Typer_needs_annotation (exp,case) -> + let message = `String "This expression needs to be annotated with its type" in + let loc = `String (Format.asprintf "%a" Location.pp exp.location) in + let exp = `String (Format.asprintf "%a" Ast_core.PP.expression exp) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("expression", exp); + ("case", `String case); + ] in + json_error ~stage ~content + | `Typer_fvs_in_create_contract_lambda (e,fvar) -> + let message = `String "Free variables are not allowed in CREATE_CONTRACT lambdas" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let expression = `String (Format.asprintf "%a" Ast_core.PP.expression e) in + let variable = `String (Format.asprintf "%a" Ast_typed.PP.expression_variable fvar) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("expression", expression); + ("variable", variable); + ] in + json_error ~stage ~content + | `Typer_create_contract_lambda (cst,e) -> + let message = `String (Format.asprintf "First argument of %a must be inlined using a lambda" Ast_core.PP.constant cst) in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let expression = `String (Format.asprintf "%a" Ast_core.PP.expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("expression", expression); + ] in + json_error ~stage ~content + | `Typer_should_be_a_function_type (actual,e) -> + let message = `String "expected a function type" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let expression = `String (Format.asprintf "%a" Ast_core.PP.expression e) in + let actual = `String (Format.asprintf "%a" Ast_typed.PP.type_expression actual) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("expression", expression); + ("actual", actual); + ] in + json_error ~stage ~content + | `Typer_bad_record_access (field,ae,t,loc) -> + let message = `String "invalid record field" in + let field = `String (Format.asprintf "%a" Ast_core.PP.label field) in + let value = `String (Format.asprintf "%a" Ast_core.PP.expression ae) in + let value_type = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let content = `Assoc [ + ("message", message); ("location", loc); + ("value", value); ("value_type", value_type); + ("field", field); + ] in + json_error ~stage ~content + | `Typer_expression_tracer (e,err) -> + let expression = `String (Format.asprintf "%a" Ast_core.PP.expression e) in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let content = `Assoc [ + ("location", loc); + ("expression", expression); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_record_access_tracer (e,err) -> + let message = `String "invalid record access" in + let expression = `String (Format.asprintf "%a" Ast_typed.PP.expression e) in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("expression", expression); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_assert_equal (expected,actual) -> + let message = `String "bad types" 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 actual) in + let content = `Assoc [ + ("message", message); + ("expected", expected); + ("actual", actual); + ] in + json_error ~stage ~content + | `Typer_corner_case desc -> + let message = `String desc in + let content = `Assoc [ + ("message", message); + ] in + json_error ~stage ~content + | `Typer_bad_collect_loop (t,loc) -> + let message = `String "Loops over collections expect lists, sets or maps" in + let actual = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("actual", actual); + ] in + json_error ~stage ~content + | `Typer_declaration_order_record loc -> + let message = `String "can't retrieve type declaration order in the converted record, you need to annotate it" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_declaration_order_variant loc -> + let message = `String "can't retrieve type declaration order in the converted variant, you need to annotate it" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_too_small_record loc -> + let message = `String "converted record must have at least two elements" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_too_small_variant loc -> + let message = `String "converted variant must have at least two elements" in + let loc = `String (Format.asprintf "%a" Location.pp loc) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_expected_record t -> + let message = `String "expected a record" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_variant t -> + let message = `String "expected a record" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_nat t -> + let message = `String "expected a nat" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_bytes t -> + let message = `String "expected bytes" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_key t -> + let message = `String "expected key" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_signature t -> + let message = `String "expected signature" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_contract t -> + let message = `String "expected contract" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_string t -> + let message = `String "expected string" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_key_hash t -> + let message = `String "expected key hash" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_mutez t -> + let message = `String "expected mutez" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_op_list t -> + let message = `String "expected operation lists" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_wrong_param_number (name,expected,actual) -> + let message = `String "constant with a wrong number of parameter" in + let loc = `String ( Format.asprintf "%a" + Location.pp_lift + (List.fold_left (fun a (t:Ast_typed.type_expression) -> + match t.location with File reg -> Region.cover a reg | Virtual _ -> a) Region.ghost actual) + ) in + let value = `String name in + let expected = `Int expected in + let actual = `Int (List.length actual) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ("actual", actual); + ("expected", expected); + ] in + json_error ~stage ~content + | `Typer_bad_list_fold_tracer err -> + let message = `String "badly typed list fold" in + let content = `Assoc [ + ("message", message); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_bad_set_fold_tracer err -> + let message = `String "badly typed set fold" in + let content = `Assoc [ + ("message", message); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_bad_map_fold_tracer err -> + let message = `String "badly typed map fold" in + let content = `Assoc [ + ("message", message); + ("children", error_jsonformat err); + ] in + json_error ~stage ~content + | `Typer_expected_function e -> + let message = `String "expected a function" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_pair e -> + let message = `String "expected a pair" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_list e -> + let message = `String "expected a list" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_set e -> + let message = `String "expected a set" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_map e -> + let message = `String "expected a map" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_big_map e -> + let message = `String "expected a big map" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_option e -> + let message = `String "expected an option" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_int e -> + let message = `String "expected an int" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_expected_bool e -> + let message = `String "expected a bool" in + let loc = `String (Format.asprintf "%a" Location.pp e.location) in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_not_matching (t1,t2) -> + let message = `String "types not matching" in + let loc1 = `String (Format.asprintf "%a" Location.pp t1.location) in + let loc2 = `String (Format.asprintf "%a" Location.pp t2.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 [ + ("message", message); + ("location_type_1", loc1); + ("location_type_2", loc2); + ("type_1", t1); + ("type_2", t2); + ] in + json_error ~stage ~content + | `Typer_not_annotated -> + let message = `String "not annotated" in + let content = `Assoc [ + ("message", message); + ] in + json_error ~stage ~content + | `Typer_bad_substraction -> + let message = `String "bad substraction, bad parameters" in + let content = `Assoc [ + ("message", message); + ] in + json_error ~stage ~content + | `Typer_wrong_size t -> + let message = `String "should be of type map, list, string, byte or set" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_wrong_neg t -> + let message = `String "should be of type nat or int" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_wrong_not t -> + let message = `String "should be of type bool, nat or int" in + let loc = `String (Format.asprintf "%a" Location.pp t.location) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_typeclass_error (exps,acts) -> + let open Simple_utils.PP_helpers in + let printl printer ppf args = + Format.fprintf ppf "%a" (list_sep printer (const " , ")) args in + let message = `String "typeclass error" in + let expected = `String (Format.asprintf "%a" (list_sep (printl Ast_typed.PP.type_expression) (const " or ")) exps) in + let actual = `String (Format.asprintf "%a" (list_sep Ast_typed.PP.type_expression (const " or ")) acts) in + let content = `Assoc [ + ("message", message); + ("expected", expected); + ("actual", actual); + ] in + json_error ~stage ~content + | `Typer_converter t -> + let message = `String "converters can only be used on records or variants" in + let value = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t) in + let content = `Assoc [ + ("message", message); + ("value", value); + ] in + json_error ~stage ~content + | `Typer_uncomparable_types (a,b) -> + let message = `String "those two types are not comparable" in + let loc1 = `String (Format.asprintf "%a" Location.pp a.location) in + let loc2 = `String (Format.asprintf "%a" Location.pp b.location) in + let t1 = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let t2 = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message); + ("location_type_1", loc1); + ("location_type_2", loc2); + ("type_1", t1); + ("type_2", t2); + ] in + json_error ~stage ~content + | `Typer_comparator_composed a -> + let message = `String "Only composed types of not more than two element are allowed to be compared" in + let loc = `String (Format.asprintf "%a" Location.pp a.location) in + let content = `Assoc [ + ("message", message); + ("location", loc); + ] in + json_error ~stage ~content + | `Typer_constant_decl_tracer (name,ae,expected,err) -> + let message = `String "typing constant declaration" in + let loc = `String (Format.asprintf "%a" Location.pp ae.location) in + let name = `String (Format.asprintf "%a" Ast_core.PP.expression_variable name) in + let expected = `String (match expected with + | None -> "(no annotation for the expected type)" + | Some expected -> Format.asprintf "%a" Ast_typed.PP.type_expression expected) in + let content = `Assoc [ + ("message", message) ; + ("name", name) ; + ("location", loc) ; + ("expected", expected) ; + ("children", error_jsonformat err) ; + ] in + json_error ~stage ~content + | `Typer_match_variant_tracer (m,err) -> + let message = `String "typing matching expression" in + let expected = `String (Format.asprintf "%a" Ast_core.PP.matching_type m) in + let content = `Assoc [ + ("message", message) ; + ("expected", expected) ; + ("children", error_jsonformat err) ; + ] in + json_error ~stage ~content + | `Typer_unrecognized_type_operator e -> + let message = `String "unrecognized type operator" in + let value = `String (Format.asprintf "%a" Ast_core.PP.type_expression e) in + let content = `Assoc [ + ("message", message) ; + ("value", value) ; + ] in + json_error ~stage ~content + | `Typer_expected_ascription t -> + let message = `String "expected ascription" in + let location = `String (Format.asprintf "%a" Location.pp t.location) in + let value = `String (Format.asprintf "%a" Ast_core.PP.expression t) in + let content = `Assoc [ + ("message", message) ; + ("location", location) ; + ("value", value) ; + ] in + json_error ~stage ~content \ No newline at end of file diff --git a/src/passes/08-typer-common/helpers.ml b/src/passes/08-typer-common/helpers.ml new file mode 100644 index 000000000..6c58f539e --- /dev/null +++ b/src/passes/08-typer-common/helpers.ml @@ -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 \ No newline at end of file diff --git a/src/passes/08-typer-common/michelson_type_converter.ml b/src/passes/08-typer-common/michelson_type_converter.ml new file mode 100644 index 000000000..ff2766585 --- /dev/null +++ b/src/passes/08-typer-common/michelson_type_converter.ml @@ -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)) \ No newline at end of file diff --git a/src/passes/08-typer-common/typer_common.ml b/src/passes/08-typer-common/typer_common.ml new file mode 100644 index 000000000..2f19a4dfe --- /dev/null +++ b/src/passes/08-typer-common/typer_common.ml @@ -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 \ No newline at end of file diff --git a/src/passes/08-typer-new/dune b/src/passes/08-typer-new/dune index bda5cb43a..af5327e8f 100644 --- a/src/passes/08-typer-new/dune +++ b/src/passes/08-typer-new/dune @@ -9,6 +9,7 @@ operators UnionFind environment + typer_common ) (preprocess (pps ppx_let) diff --git a/src/passes/08-typer-new/errors.ml b/src/passes/08-typer-new/errors.ml deleted file mode 100644 index 866211659..000000000 --- a/src/passes/08-typer-new/errors.ml +++ /dev/null @@ -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 diff --git a/src/passes/08-typer-new/solver.ml b/src/passes/08-typer-new/solver.ml index 504035733..aa2df6f24 100644 --- a/src/passes/08-typer-new/solver.ml +++ b/src/passes/08-typer-new/solver.ml @@ -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 } diff --git a/src/passes/08-typer-new/typer.ml b/src/passes/08-typer-new/typer.ml index b45087f07..8359a281f 100644 --- a/src/passes/08-typer-new/typer.ml +++ b/src/passes/08-typer-new/typer.ml @@ -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 diff --git a/src/passes/08-typer-new/typer.mli b/src/passes/08-typer-new/typer.mli index 626dc29ea..5b880d0bc 100644 --- a/src/passes/08-typer-new/typer.mli +++ b/src/passes/08-typer-new/typer.mli @@ -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 diff --git a/src/passes/08-typer-new/untyper.ml b/src/passes/08-typer-new/untyper.ml index 00bbdcb2d..979d8144b 100644 --- a/src/passes/08-typer-new/untyper.ml +++ b/src/passes/08-typer-new/untyper.ml @@ -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=_}} -> diff --git a/src/passes/08-typer-new/wrap.ml b/src/passes/08-typer-new/wrap.ml index a5773bcd0..0b88ed0c6 100644 --- a/src/passes/08-typer-new/wrap.ml +++ b/src/passes/08-typer-new/wrap.ml @@ -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 = *) diff --git a/src/passes/08-typer-old/dune b/src/passes/08-typer-old/dune index 224914e78..fc8cfbd18 100644 --- a/src/passes/08-typer-old/dune +++ b/src/passes/08-typer-old/dune @@ -2,6 +2,7 @@ (name typer_old) (public_name ligo.typer_old) (libraries + typer_common simple-utils tezos-utils ast_core diff --git a/src/passes/08-typer-old/typer.ml b/src/passes/08-typer-old/typer.ml index 732bfa601..e1d755c7c 100644 --- a/src/passes/08-typer-old/typer.ml +++ b/src/passes/08-typer-old/typer.ml @@ -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=_}} -> diff --git a/src/passes/08-typer-old/typer.mli b/src/passes/08-typer-old/typer.mli index b0dda96e3..fc8283470 100644 --- a/src/passes/08-typer-old/typer.mli +++ b/src/passes/08-typer-old/typer.mli @@ -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 *) diff --git a/src/passes/08-typer/typer.ml b/src/passes/08-typer/typer.ml index b1577a514..b33d2551c 100644 --- a/src/passes/08-typer/typer.ml +++ b/src/passes/08-typer/typer.ml @@ -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 diff --git a/src/passes/08-typer/typer.mli b/src/passes/08-typer/typer.mli index 062b4aab4..9b37e44de 100644 --- a/src/passes/08-typer/typer.mli +++ b/src/passes/08-typer/typer.mli @@ -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 \ No newline at end of file diff --git a/src/passes/09-self_ast_typed/contract_passes.ml b/src/passes/09-self_ast_typed/contract_passes.ml index 764319a2c..338ccd8de 100644 --- a/src/passes/09-self_ast_typed/contract_passes.ml +++ b/src/passes/09-self_ast_typed/contract_passes.ml @@ -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) diff --git a/src/passes/09-self_ast_typed/errors.ml b/src/passes/09-self_ast_typed/errors.ml new file mode 100644 index 000000000..aedf38d2b --- /dev/null +++ b/src/passes/09-self_ast_typed/errors.ml @@ -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 + "@[%a@ Recursion must be achieved through tail-calls only@]" + Location.pp loc + | `Self_ast_typed_bad_self_type (expected,got,loc) -> + Format.fprintf f + "@[%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 + "@[%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 + "@[%a@ Entrypoint annotation must be a string literal@]" + Location.pp loc + | `Self_ast_typed_unmatched_entrypoint loc -> + Format.fprintf f + "@[%a@ No constructor matches the entrypoint annotation@]" + Location.pp loc + | `Self_ast_typed_nested_big_map loc -> + Format.fprintf f + "@[%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 + "@[Internal error: %s @]" + desc + | `Self_ast_typed_contract_io (_entrypoint, e) -> + Format.fprintf f + "@[%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 + "@[%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 + "@[%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 + "@[%a@ Badly typed contract:@ expected a pair as parameter@]" + Location.pp loc + | `Self_ast_typed_pair_out loc -> + Format.fprintf f + "@[%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 \ No newline at end of file diff --git a/src/passes/09-self_ast_typed/helpers.ml b/src/passes/09-self_ast_typed/helpers.ml index e9edc7101..a891cdd56 100644 --- a/src/passes/09-self_ast_typed/helpers.ml +++ b/src/passes/09-self_ast_typed/helpers.ml @@ -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 diff --git a/src/passes/09-self_ast_typed/michelson_layout.ml b/src/passes/09-self_ast_typed/michelson_layout.ml index ce59c0898..1bf47bee9 100644 --- a/src/passes/09-self_ast_typed/michelson_layout.ml +++ b/src/passes/09-self_ast_typed/michelson_layout.ml @@ -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 diff --git a/src/passes/09-self_ast_typed/no_nested_big_map.ml b/src/passes/09-self_ast_typed/no_nested_big_map.ml index c92034d3d..ba80ce7b0 100644 --- a/src/passes/09-self_ast_typed/no_nested_big_map.ml +++ b/src/passes/09-self_ast_typed/no_nested_big_map.ml @@ -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) diff --git a/src/passes/09-self_ast_typed/self_ast_typed.ml b/src/passes/09-self_ast_typed/self_ast_typed.ml index 442564638..c142b5315 100644 --- a/src/passes/09-self_ast_typed/self_ast_typed.ml +++ b/src/passes/09-self_ast_typed/self_ast_typed.ml @@ -1,4 +1,5 @@ open Trace +module Errors = Errors let all_passes = [ Tail_recursion.peephole_expression ; diff --git a/src/passes/09-self_ast_typed/tail_recursion.ml b/src/passes/09-self_ast_typed/tail_recursion.ml index d31440bf9..a0a4cbe46 100644 --- a/src/passes/09-self_ast_typed/tail_recursion.ml +++ b/src/passes/09-self_ast_typed/tail_recursion.ml @@ -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-> ( diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index 385a1d247..9570a3993 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -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 diff --git a/src/passes/10-interpreter/interpreter.mli b/src/passes/10-interpreter/interpreter.mli index 9e7820e1a..7dc4e003f 100644 --- a/src/passes/10-interpreter/interpreter.mli +++ b/src/passes/10-interpreter/interpreter.mli @@ -1,3 +1,4 @@ open Trace -val dummy : Ast_typed.program -> string result \ No newline at end of file +type interpreter_error = [] +val eval : Ast_typed.program -> (string, interpreter_error) result \ No newline at end of file diff --git a/src/passes/10-transpiler/errors.ml b/src/passes/10-transpiler/errors.ml new file mode 100644 index 000000000..0dc324b58 --- /dev/null +++ b/src/passes/10-transpiler/errors.ml @@ -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 + "@[%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 \ No newline at end of file diff --git a/src/passes/10-transpiler/helpers.ml b/src/passes/10-transpiler/helpers.ml index 27a9f94dc..ffc228897 100644 --- a/src/passes/10-transpiler/helpers.ml +++ b/src/passes/10-transpiler/helpers.ml @@ -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) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index ab3de29f3..550eead4a 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -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) diff --git a/src/passes/10-transpiler/transpiler.mli b/src/passes/10-transpiler/transpiler.mli index dbdb41b58..8ec051962 100644 --- a/src/passes/10-transpiler/transpiler.mli +++ b/src/passes/10-transpiler/transpiler.mli @@ -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 \ No newline at end of file diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 5f68cddd5..9780dd929 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -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)) diff --git a/src/passes/11-self_mini_c/errors.ml b/src/passes/11-self_mini_c/errors.ml new file mode 100644 index 000000000..24a1c15a7 --- /dev/null +++ b/src/passes/11-self_mini_c/errors.ml @@ -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 \ No newline at end of file diff --git a/src/passes/11-self_mini_c/helpers.ml b/src/passes/11-self_mini_c/helpers.ml index 013de8283..5f53d8fc6 100644 --- a/src/passes/11-self_mini_c/helpers.ml +++ b/src/passes/11-self_mini_c/helpers.ml @@ -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 diff --git a/src/passes/11-self_mini_c/michelson_restrictions.ml b/src/passes/11-self_mini_c/michelson_restrictions.ml index 88bab055f..cb5c4aaff 100644 --- a/src/passes/11-self_mini_c/michelson_restrictions.ml +++ b/src/passes/11-self_mini_c/michelson_restrictions.ml @@ -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} -> diff --git a/src/passes/11-self_mini_c/self_mini_c.ml b/src/passes/11-self_mini_c/self_mini_c.ml index dfcb75c3b..6ce39bddd 100644 --- a/src/passes/11-self_mini_c/self_mini_c.ml +++ b/src/passes/11-self_mini_c/self_mini_c.ml @@ -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) = diff --git a/src/passes/12-compiler/compiler.ml b/src/passes/12-compiler/compiler.ml index fbdd8942a..4389b4f00 100644 --- a/src/passes/12-compiler/compiler.ml +++ b/src/passes/12-compiler/compiler.ml @@ -2,5 +2,6 @@ module Uncompiler = Uncompiler module Program = Compiler_program module Type = Compiler_type module Environment = Compiler_environment +module Errors = Errors include Program diff --git a/src/passes/12-compiler/compiler_environment.ml b/src/passes/12-compiler/compiler_environment.ml index 5b429208f..77ff075ba 100644 --- a/src/passes/12-compiler/compiler_environment.ml +++ b/src/passes/12-compiler/compiler_environment.ml @@ -1,3 +1,4 @@ +open Errors open Trace open Mini_c open Environment @@ -5,15 +6,9 @@ open Michelson let empty : environment = [] -let get : environment -> expression_variable -> michelson result = fun e s -> +let get : environment -> expression_variable -> (michelson, compiler_error) result = fun e s -> let%bind (_ , position) = - let error = - let title () = "Environment.get" in - let content () = Format.asprintf "%a in %a" - Var.pp s - PP.environment e in - error title content in - generic_try error @@ + generic_try (get_env s e) @@ (fun () -> Environment.get_i s e) in let aux_dig = fun n -> seq [ i_dig n ; @@ -28,8 +23,8 @@ let get : environment -> expression_variable -> michelson result = fun e s -> ok code -let pack_closure : environment -> selector -> michelson result = fun e lst -> - let%bind () = Assert.assert_true (e <> []) in +let pack_closure : environment -> selector -> (michelson, compiler_error) result = fun e lst -> + let%bind () = Assert.assert_true (corner_case ~loc:__LOC__ "pack closure") (e <> []) in (* Tag environment with selected elements. Only the first occurence of each name from the selector in the environment is kept. *) @@ -58,7 +53,7 @@ let pack_closure : environment -> selector -> michelson result = fun e lst -> ok code -let unpack_closure : environment -> michelson result = fun e -> +let unpack_closure : environment -> (michelson , compiler_error) result = fun e -> match e with | [] -> ok @@ seq [] | _ :: tl -> ( diff --git a/src/passes/12-compiler/compiler_environment.mli b/src/passes/12-compiler/compiler_environment.mli index 22801279d..fc68931a7 100644 --- a/src/passes/12-compiler/compiler_environment.mli +++ b/src/passes/12-compiler/compiler_environment.mli @@ -1,3 +1,4 @@ +open Errors open Proto_alpha_utils open Trace open Mini_c @@ -7,10 +8,11 @@ open Michelson module Stack = Meta_michelson.Stack *) val empty: environment -val get : environment -> expression_variable -> michelson result +val get : environment -> expression_variable -> + (michelson , compiler_error) result -val pack_closure : environment -> selector -> michelson result -val unpack_closure : environment -> michelson result +val pack_closure : environment -> selector -> (michelson , compiler_error) result +val unpack_closure : environment -> (michelson , compiler_error) result (* val add : environment -> (string * type_value) -> michelson result diff --git a/src/passes/12-compiler/compiler_program.ml b/src/passes/12-compiler/compiler_program.ml index 426d0656b..003458a88 100644 --- a/src/passes/12-compiler/compiler_program.ml +++ b/src/passes/12-compiler/compiler_program.ml @@ -1,46 +1,15 @@ open Trace +open Errors open Mini_c open Michelson open Memory_proto_alpha.Protocol.Script_ir_translator open Operators.Compiler -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 contract_entrypoint_must_be_literal ~loc = - let title () = "contract entrypoint must be literal" in - let content () = "For get_entrypoint, entrypoint must be given as a literal string" in - let data = - [ ("location", fun () -> loc) ; - ] in - error ~data title content - - let raw_michelson_parsing_error code = - let title () = "Error while parsing Michelson code insertion" in - let content () = "Unable to parse the michelson code" in - let data = [ - ("code", fun () -> code); - (* TODO : add location in Mini-c *) - (* ("location", fun () -> Format.asprintf "%a" Location.pp location); *) - ] in - error ~data title content -end -open Errors - (* This does not makes sense to me *) -let rec get_operator : constant' -> type_expression -> expression list -> predicate result = fun s ty lst -> +let rec get_operator : constant' -> type_expression -> expression list -> (predicate , compiler_error) result = fun s ty lst -> match Operators.Compiler.get_operators s with - | Ok (x,_) -> ok x - | Error _ -> ( + | Some x -> ok x + | None -> ( match s with | C_SELF -> ( let%bind entrypoint_as_string = match lst with @@ -57,85 +26,84 @@ let rec get_operator : constant' -> type_expression -> expression list -> predic ] ) | C_NONE -> ( - let%bind ty' = Mini_c.get_t_option ty in + let%bind ty' = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_option ty in let%bind m_ty = Compiler_type.type_ ty' in ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE ) | C_NIL -> ( - let%bind ty' = Mini_c.get_t_list ty in + let%bind ty' = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_list ty in let%bind m_ty = Compiler_type.type_ ty' in ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL ) | C_LOOP_CONTINUE -> ( - let%bind (_,ty) = get_t_or ty in + let%bind (_,ty) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_or ty in let%bind m_ty = Compiler_type.type_ ty in ok @@ simple_unary @@ prim ~children:[m_ty] I_LEFT ) | C_LOOP_STOP -> ( - let%bind (ty, _) = get_t_or ty in + let%bind (ty, _) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_or ty in let%bind m_ty = Compiler_type.type_ ty in ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT ) | C_LIST_EMPTY -> ( - let%bind ty' = Mini_c.get_t_list ty in + let%bind ty' = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_list ty in let%bind m_ty = Compiler_type.type_ ty' in ok @@ simple_constant @@ i_nil m_ty ) | C_SET_EMPTY -> ( - let%bind ty' = Mini_c.get_t_set ty in + let%bind ty' = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_set ty in let%bind m_ty = Compiler_type.type_ ty' in ok @@ simple_constant @@ i_empty_set m_ty ) | C_MAP_EMPTY -> ( - let%bind sd = Mini_c.get_t_map ty in + let%bind sd = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_map ty in let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in ok @@ simple_constant @@ i_empty_map src dst ) | C_BIG_MAP_EMPTY -> ( - let%bind sd = Mini_c.get_t_big_map ty in + let%bind sd = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_big_map ty in let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in ok @@ simple_constant @@ i_empty_big_map src dst ) | C_BYTES_UNPACK -> ( - let%bind ty' = Mini_c.get_t_option ty in + let%bind ty' = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ Mini_c.get_t_option ty in let%bind m_ty = Compiler_type.type_ ty' in ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK ) | C_MAP_REMOVE -> - let%bind v = match lst with + let%bind (_k,v) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ match lst with | [ _ ; expr ] -> - let%bind (_, v) = Mini_c.Combinators.(bind_map_or (get_t_map , get_t_big_map) (Expression.get_type expr)) in - ok v - | _ -> simple_fail "mini_c . MAP_REMOVE" in + Option.(map_pair_or (get_t_map , get_t_big_map) (Expression.get_type expr)) + | _ -> None in let%bind v_ty = Compiler_type.type_ v in ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ] | C_LEFT -> - let%bind r = match lst with + let%bind r = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ match lst with | [ _ ] -> get_t_right ty - | _ -> simple_fail "mini_c . LEFT" in + | _ -> None in let%bind r_ty = Compiler_type.type_ r in ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT | C_RIGHT -> - let%bind l = match lst with + let%bind l = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ match lst with | [ _ ] -> get_t_left ty - | _ -> simple_fail "mini_c . RIGHT" in + | _ -> None in let%bind l_ty = Compiler_type.type_ l in ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT | C_CONTRACT -> - let%bind r = get_t_contract ty in + let%bind r = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_contract ty in let%bind r_ty = Compiler_type.type_ r in ok @@ simple_unary @@ seq [ prim ~children:[r_ty] I_CONTRACT ; i_assert_some_msg (i_push_string "bad address for get_contract") ; ] | C_CONTRACT_OPT -> - let%bind tc = get_t_option ty in - let%bind r = get_t_contract tc in + let%bind tc = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_option ty in + let%bind r = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_contract tc in let%bind r_ty = Compiler_type.type_ r in ok @@ simple_unary @@ prim ~children:[r_ty] I_CONTRACT ; | C_CONTRACT_ENTRYPOINT -> - let%bind r = get_t_contract ty in + let%bind r = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_contract ty in let%bind r_ty = Compiler_type.type_ r in let%bind entry = match lst with | [ { content = E_literal (D_string entry); type_expression = _ } ; _addr ] -> ok entry @@ -149,8 +117,8 @@ let rec get_operator : constant' -> type_expression -> expression list -> predic i_assert_some_msg (i_push_string @@ Format.sprintf "bad address for get_entrypoint (%s)" entry) ; ] | C_CONTRACT_ENTRYPOINT_OPT -> - let%bind tc = get_t_option ty in - let%bind r = get_t_contract tc in + let%bind tc = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_option ty in + let%bind r = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_contract tc in let%bind r_ty = Compiler_type.type_ r in let%bind entry = match lst with | [ { content = E_literal (D_string entry); type_expression = _ } ; _addr ] -> ok entry @@ -175,10 +143,10 @@ let rec get_operator : constant' -> type_expression -> expression list -> predic prim ~children:[ch] I_CREATE_CONTRACT ; i_pair ; ] - | x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" PP.constant x) + | x -> fail @@ corner_case ~loc:__LOC__ (Format.asprintf "predicate \"%a\" doesn't exist" PP.constant x) ) -and translate_value (v:value) ty : michelson result = match v with +and translate_value (v:value) ty : (michelson , compiler_error) result = match v with | D_bool b -> ok @@ prim (if b then D_True else D_False) | D_int n -> ok @@ int n | D_nat n -> ok @@ int n @@ -188,18 +156,18 @@ and translate_value (v:value) ty : michelson result = match v with | D_bytes s -> ok @@ bytes s | D_unit -> ok @@ prim D_Unit | D_pair (a, b) -> ( - let%bind (a_ty , b_ty) = get_t_pair ty in + let%bind (a_ty , b_ty) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_pair ty in let%bind a = translate_value a a_ty in let%bind b = translate_value b b_ty in ok @@ prim ~children:[a;b] D_Pair ) | D_left a -> ( - let%bind (a_ty , _) = get_t_or ty in + let%bind (a_ty , _) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_or ty in let%bind a' = translate_value a a_ty in ok @@ prim ~children:[a'] D_Left ) | D_right b -> ( - let%bind (_ , b_ty) = get_t_or ty in + let%bind (_ , b_ty) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_or ty in let%bind b' = translate_value b b_ty in ok @@ prim ~children:[b'] D_Right ) @@ -208,7 +176,7 @@ and translate_value (v:value) ty : michelson result = match v with let%bind s' = translate_value s ty in ok @@ prim ~children:[s'] D_Some | D_map lst -> ( - let%bind (k_ty , v_ty) = get_t_map ty in + let%bind (k_ty , v_ty) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_map ty in let%bind lst' = let aux (k , v) = bind_pair (translate_value k k_ty , translate_value v v_ty) in bind_map_list aux lst in @@ -217,7 +185,7 @@ and translate_value (v:value) ty : michelson result = match v with ok @@ seq @@ List.map aux sorted ) | D_big_map lst -> ( - let%bind (k_ty , v_ty) = get_t_big_map ty in + let%bind (k_ty , v_ty) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_big_map ty in let%bind lst' = let aux (k , v) = bind_pair (translate_value k k_ty , translate_value v v_ty) in bind_map_list aux lst in @@ -226,27 +194,24 @@ and translate_value (v:value) ty : michelson result = match v with ok @@ seq @@ List.map aux sorted ) | D_list lst -> ( - let%bind e_ty = get_t_list ty in + let%bind e_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_list ty in let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in ok @@ seq lst' ) | D_set lst -> ( - let%bind e_ty = get_t_set ty in + let%bind e_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_set ty in let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in let sorted = List.sort compare lst' in ok @@ seq sorted ) | D_operation _ -> - simple_fail "can't compile an operation" + fail @@ corner_case ~loc:__LOC__ "can't compile an operation" -and translate_expression (expr:expression) (env:environment) : michelson result = +and translate_expression (expr:expression) (env:environment) : (michelson , compiler_error) result = let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in - let error_message () = - Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_variable ty - in let return code = ok code in - trace (error (thunk "compiling expression") error_message) @@ + trace (compile_expression_tracer expr ty) @@ match expr' with | E_skip -> return @@ i_push_unit | E_literal v -> @@ -257,10 +222,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result match ty.type_content with | T_function (input_ty , output_ty) -> translate_function anon env input_ty output_ty - | _ -> simple_fail "expected function type" + | _ -> fail @@ corner_case ~loc:__LOC__ "expected function type" ) | E_application (f , arg) -> ( - trace (simple_error "Compiling quote application") @@ + trace_strong (corner_case ~loc:__LOC__ "Compiling quote application") @@ let%bind f = translate_expression f (Environment.add (Var.fresh (), arg.type_expression) env) in let%bind arg = translate_expression arg env in return @@ seq [ @@ -318,13 +283,8 @@ and translate_expression (expr:expression) (env:environment) : michelson result pre_code ; f ; ] - | _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str) + | _ -> fail @@ bad_constant_arity str in - let error = - let title () = "error compiling constant" in - let content () = L.get () in - error title content in - trace error @@ return code | E_make_none o -> let%bind o' = Compiler_type.type_ o in @@ -424,7 +384,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result return code ) | C_LOOP_LEFT -> ( - let%bind (_, ty) = get_t_or (snd v) in + let%bind (_, ty) = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_or (snd v) in let%bind m_ty = Compiler_type.type_ ty in let%bind code = ok (seq [ expr' ; @@ -434,9 +394,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result return code ) | s -> ( - let iter = Format.asprintf "iter %a" PP.constant s in - let error = error (thunk "bad iterator") (thunk iter) in - fail error + fail (bad_iterator s) ) ) | E_fold ((v , body) , collection , initial) -> ( @@ -495,7 +453,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result ) | E_raw_michelson code -> let%bind code = - Proto_alpha_utils.Trace.trace_tzresult (raw_michelson_parsing_error code) @@ + Proto_alpha_utils.Trace.trace_tzresult (fun _ -> corner_case ~loc:__LOC__ "Error while parsing michelson code insertion") @@ Tezos_micheline.Micheline_parser.no_parsing_error @@ Michelson_parser.V1.parse_expression ~check:false code in @@ -503,7 +461,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result let%bind ty = Compiler_type.type_ ty in return @@ i_push ty code -and translate_function_body ({body ; binder} : anon_function) lst input : michelson result = +and translate_function_body ({body ; binder} : anon_function) lst input : (michelson , compiler_error) result = let pre_env = Environment.of_list lst in let env = Environment.(add (binder , input) pre_env) in let%bind expr_code = translate_expression body env in @@ -520,7 +478,7 @@ and translate_function_body ({body ; binder} : anon_function) lst input : michel ok code -and translate_function anon env input_ty output_ty : michelson result = +and translate_function anon env input_ty output_ty : (michelson , compiler_error) result = let fvs = Mini_c.Free_variables.lambda [] anon in let small_env = Mini_c.Environment.select fvs env in let%bind (_lambda_ty , input_ty' , output_ty') = diff --git a/src/passes/12-compiler/compiler_program.mli b/src/passes/12-compiler/compiler_program.mli index 19088ca96..0b7d2a02b 100644 --- a/src/passes/12-compiler/compiler_program.mli +++ b/src/passes/12-compiler/compiler_program.mli @@ -1,3 +1,4 @@ +open Errors open Trace open Mini_c @@ -14,28 +15,11 @@ type compiled_expression = { expr : michelson ; } -val get_operator : constant' -> type_expression -> expression list -> predicate result -val translate_expression : expression -> environment -> michelson result -val translate_function_body : anon_function -> environment_element list -> type_expression -> michelson result -val translate_value : value -> type_expression -> michelson result -(* +val get_operator : constant' -> type_expression -> expression list -> (predicate, compiler_error) result -open Operators.Compiler +val translate_expression : expression -> environment -> (michelson, compiler_error) result -val get_predicate : string -> type_value -> expression list -> predicate result +val translate_function_body : anon_function -> environment_element list -> type_expression -> (michelson, compiler_error) result -val translate_function : anon_function -> michelson result - -val translate_expression : ?push_var_name:string -> expression -> environment -> ( michelson * environment ) result - -val translate_quote_body : anon_function -> michelson result - -val get_main : program -> string -> anon_function result - - -module Errors : sig - val corner_case : loc:string -> string -> unit -> error -end - -*) +val translate_value : value -> type_expression -> (michelson, compiler_error) result diff --git a/src/passes/12-compiler/compiler_type.ml b/src/passes/12-compiler/compiler_type.ml index 9329afab0..08a2cd625 100644 --- a/src/passes/12-compiler/compiler_type.ml +++ b/src/passes/12-compiler/compiler_type.ml @@ -1,3 +1,4 @@ +open Errors open Trace open Mini_c.Types @@ -56,14 +57,11 @@ module Ty = struct let pair_ann (anna, a) (annb, b) = Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None , has_big_map a || has_big_map b) - let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) () - let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) () - - let comparable_type_base : type_base -> ex_comparable_ty result = fun tb -> + let comparable_type_base : type_base -> (ex_comparable_ty , compiler_error) result = fun tb -> let return x = ok @@ Ex_comparable_ty x in match tb with - | TB_unit -> fail (not_comparable "unit") - | TB_void -> fail (not_comparable "void") + | TB_unit -> fail (Errors.not_comparable_base tb) + | TB_void -> fail (Errors.not_comparable_base tb) | TB_bool -> return bool_k | TB_nat -> return nat_k | TB_mutez -> return tez_k @@ -72,16 +70,16 @@ module Ty = struct | TB_address -> return address_k | TB_timestamp -> return timestamp_k | TB_bytes -> return bytes_k - | TB_operation -> fail (not_comparable "operation") - | TB_signature -> fail (not_comparable "signature") - | TB_key -> fail (not_comparable "key") + | TB_operation -> fail (Errors.not_comparable_base tb) + | TB_signature -> fail (Errors.not_comparable_base tb) + | TB_key -> fail (Errors.not_comparable_base tb) | TB_key_hash -> return key_hash_k - | TB_chain_id -> fail (not_comparable "chain_id") + | TB_chain_id -> fail (Errors.not_comparable_base tb) - let comparable_leaf : type a. (a, _) comparable_struct -> (a , leaf) comparable_struct result = + let comparable_leaf : type a. (a, _) comparable_struct -> ((a , leaf) comparable_struct , compiler_error) result = fun a -> match a with - | Pair_key _ -> fail (not_comparable "pair (use (a,(b,c)) instead of (a,b,c))") + | Pair_key _ -> fail Errors.not_comparable_pair_struct | Int_key annot -> ok (Int_key annot) | Nat_key annot -> ok (Nat_key annot) | String_key annot -> ok (String_key annot) @@ -92,28 +90,28 @@ module Ty = struct | Timestamp_key annot -> ok (Timestamp_key annot) | Address_key annot -> ok (Address_key annot) - let rec comparable_type : type_expression -> ex_comparable_ty result = fun tv -> + let rec comparable_type : type_expression -> (ex_comparable_ty , compiler_error) result = fun tv -> match tv.type_content with | T_base b -> comparable_type_base b - | T_function _ -> fail (not_comparable "function") - | T_or _ -> fail (not_comparable "or") + | T_function _ -> fail (Errors.not_comparable tv) + | T_or _ -> fail (Errors.not_comparable tv) | T_pair ((_,a),(_,b)) -> let%bind (Ex_comparable_ty a') = comparable_type a in let%bind (Ex_comparable_ty b') = comparable_type b in let%bind a'' = comparable_leaf a' in ok @@ Ex_comparable_ty (pair_k a'' b') - | T_map _ -> fail (not_comparable "map") - | T_big_map _ -> fail (not_comparable "big_map") - | T_list _ -> fail (not_comparable "list") - | T_set _ -> fail (not_comparable "set") - | T_option _ -> fail (not_comparable "option") - | T_contract _ -> fail (not_comparable "contract") + | T_map _ -> fail (Errors.not_comparable tv) + | T_big_map _ -> fail (Errors.not_comparable tv) + | T_list _ -> fail (Errors.not_comparable tv) + | T_set _ -> fail (Errors.not_comparable tv) + | T_option _ -> fail (Errors.not_comparable tv) + | T_contract _ -> fail (Errors.not_comparable tv) - let base_type : type_base -> ex_ty result = fun b -> + let base_type : type_base -> (ex_ty , compiler_error) result = fun b -> let return x = ok @@ Ex_ty x in match b with | TB_unit -> return unit - | TB_void -> fail (not_compilable_type "void") + | TB_void -> fail (Errors.void_type_not_compilable) | TB_bool -> return bool | TB_int -> return int | TB_nat -> return nat @@ -128,7 +126,7 @@ module Ty = struct | TB_key_hash -> return key_hash | TB_chain_id -> return chain_id - let rec type_ : type_expression -> ex_ty result = + let rec type_ : type_expression -> (ex_ty , compiler_error) result = fun te -> match te.type_content with | T_base b -> base_type b | T_pair (t, t') -> ( @@ -167,7 +165,7 @@ module Ty = struct let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty (contract t') - and annotated : type_expression annotated -> ex_ty annotated result = + and annotated : type_expression annotated -> (ex_ty annotated , compiler_error) result = fun (ann, a) -> let%bind a = type_ a in ok @@ (ann, a) @@ -183,7 +181,7 @@ module Ty = struct bind_fold_right_list aux tl_ty hds ) - and environment : environment -> ex_stack_ty result = fun env -> + and environment : environment -> (ex_stack_ty , compiler_error) result = fun env -> let%bind lst = bind_map_list type_ @@ List.map snd env in @@ -194,11 +192,10 @@ module Ty = struct end - -let base_type : type_base -> O.michelson result = +let base_type : type_base -> (O.michelson , compiler_error) result = function | TB_unit -> ok @@ O.prim T_unit - | TB_void -> fail (Ty.not_compilable_type "void") + | TB_void -> fail (Errors.void_type_not_compilable) | TB_bool -> ok @@ O.prim T_bool | TB_int -> ok @@ O.prim T_int | TB_nat -> ok @@ O.prim T_nat @@ -213,7 +210,7 @@ let base_type : type_base -> O.michelson result = | TB_key_hash -> ok @@ O.prim T_key_hash | TB_chain_id -> ok @@ O.prim T_chain_id -let rec type_ : type_expression -> O.michelson result = +let rec type_ : type_expression -> (O.michelson , compiler_error) result = fun te -> match te.type_content with | T_base b -> base_type b | T_pair (t, t') -> ( @@ -249,7 +246,7 @@ let rec type_ : type_expression -> O.michelson result = let%bind ret = type_ ret in ok @@ O.prim ~children:[arg;ret] T_lambda -and annotated : type_expression annotated -> O.michelson result = +and annotated : type_expression annotated -> (O.michelson , compiler_error) result = function | (Some ann, o) -> let%bind o' = type_ o in @@ -281,7 +278,7 @@ and lambda_closure_with_ty = fun (c , arg , ret) -> and environment_closure = function - | [] -> simple_fail "Type of empty env" + | [] -> fail @@ corner_case ~loc:"TODO" "Type of empty env" | [a] -> type_ @@ snd a | a :: b -> let%bind a = type_ @@ snd a in diff --git a/src/passes/12-compiler/compiler_type.mli b/src/passes/12-compiler/compiler_type.mli index 1c6186c50..2771561eb 100644 --- a/src/passes/12-compiler/compiler_type.mli +++ b/src/passes/12-compiler/compiler_type.mli @@ -1,3 +1,4 @@ +open Errors open Trace open Mini_c.Types open Proto_alpha_utils.Memory_proto_alpha @@ -63,11 +64,11 @@ module Ty : sig val comparable_type : type_value -> ex_comparable_ty result val base_type : type_base -> ex_ty result *) - val type_ : type_expression -> ex_ty result + val type_ : type_expression -> (ex_ty, compiler_error) result - val environment_representation : environment -> ex_ty result + val environment_representation : environment -> (ex_ty, compiler_error) result - val environment : environment -> ex_stack_ty result + val environment : environment -> (ex_stack_ty, compiler_error) result (* val not_comparable : string -> unit -> error val not_compilable_type : string -> unit -> error @@ -81,17 +82,14 @@ module Ty : sig *) end -val type_ : type_expression -> O.t result +val type_ : type_expression -> (O.t, compiler_error) result -val environment_element : string * type_expression -> (int, O.prim) Tezos_micheline.Micheline.node result +val environment_element : string * type_expression -> ((int, O.prim) Tezos_micheline.Micheline.node, compiler_error) result -val environment : ( 'a * type_expression ) list -> O.t list result -val lambda_closure : environment * type_expression * type_expression -> (int, O.prim) Tezos_micheline.Micheline.node result +val environment : ( 'a * type_expression ) list -> (O.t list , compiler_error) result val lambda_closure_with_ty : environment * type_expression * type_expression -> - (O.michelson * O.michelson * O.michelson) result + (O.michelson * O.michelson * O.michelson, compiler_error) result -val environment_closure : environment -> (int , O.prim ) Tezos_micheline.Micheline.node result -(* -val base_type : type_base -> O.michelson result +val lambda_closure : environment * type_expression * type_expression -> ((int, O.prim) Tezos_micheline.Micheline.node, compiler_error) result -*) +val environment_closure : environment -> ((int , O.prim ) Tezos_micheline.Micheline.node, compiler_error) result diff --git a/src/passes/12-compiler/errors.ml b/src/passes/12-compiler/errors.ml new file mode 100644 index 000000000..244edf8e6 --- /dev/null +++ b/src/passes/12-compiler/errors.ml @@ -0,0 +1,185 @@ +open Trace +open Simple_utils.Display +open Stage_common.Types + +type compiler_error = [ + | `Compiler_get_environment of expression_variable * Mini_c.environment + | `Compiler_corner_case of string * string + | `Compiler_contract_entrypoint of string + | `Compiler_expression_tracer of Mini_c.expression * Mini_c.type_expression * compiler_error + | `Compiler_bad_iterator of Mini_c.constant' + | `Compiler_not_comparable_base of Mini_c.type_base + | `Compiler_not_comparable of Mini_c.type_expression + | `Compiler_not_comparable_pair_struct + | `Compiler_void_type_not_compilable + | `Compiler_unparsing_unrecognized_data of + (Proto_alpha_utils.Trace.tezos_alpha_error list) + | `Compiler_untranspilable of Michelson.michelson * Michelson.michelson + | `Compiler_bad_constant_arity of Mini_c.constant' +] + +let stage = "compiler" +let uncompiler_stage = "uncompiler_stage" +let corner_case_msg () = + "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 get_env var env = `Compiler_get_environment (var , env) +let corner_case ~loc message = `Compiler_corner_case (loc,message) +let contract_entrypoint_must_be_literal ~loc = `Compiler_contract_entrypoint loc +let compile_expression_tracer e ty err = `Compiler_expression_tracer (e,ty,err) +let bad_iterator cst = `Compiler_bad_iterator cst +let not_comparable_base tb = `Compiler_not_comparable_base tb +let not_comparable t = `Compiler_not_comparable t +let not_comparable_pair_struct = `Compiler_not_comparable_pair_struct +let void_type_not_compilable = `Compiler_void_type_not_compilable +let unrecognized_data errs = `Compiler_unparsing_unrecognized_data errs +let untranspilable m_data m_type = `Compiler_untranspilable (m_data, m_type) +let bad_constant_arity c = `Compiler_bad_constant_arity c + +let rec error_ppformat : display_format:string display_format -> + Format.formatter -> compiler_error -> unit = + fun ~display_format f a -> + match display_format with + | Human_readable | Dev -> ( + match a with + | `Compiler_get_environment (var,env) -> + let s = Format.asprintf "failed to get var %a in environment %a" + Var.pp var + Mini_c.PP.environment env in + Format.pp_print_string f s ; + | `Compiler_corner_case (loc,msg) -> + let s = Format.asprintf "compiler corner case at %s : %s\n %s" + loc msg (corner_case_msg ()) in + Format.pp_print_string f s ; + | `Compiler_contract_entrypoint loc -> + let s = Format.asprintf "contract entrypoint must be given as a literal string: %s" + loc in + Format.pp_print_string f s ; + | `Compiler_expression_tracer (e,ty,err) -> + Format.fprintf f + "@[compiling expression@%a of type %a@%a]" + Mini_c.PP.expression e + Mini_c.PP.type_variable ty + (error_ppformat ~display_format) err + | `Compiler_bad_iterator cst -> + let s = Format.asprintf "bad iterator: iter %a" Mini_c.PP.constant cst in + Format.pp_print_string f s ; + | `Compiler_not_comparable_base tb -> + let s = Format.asprintf "not a comparable type: %a" Mini_c.PP.type_constant tb in + Format.pp_print_string f s ; + | `Compiler_not_comparable t -> + let s = Format.asprintf "not a comparable type: %a" Mini_c.PP.type_variable t in + Format.pp_print_string f s ; + | `Compiler_not_comparable_pair_struct -> + let s = "pair does not have a comparable structure. (hint: use (a,(b,c)) instead of (a,b,c))" in + Format.pp_print_string f s; + | `Compiler_void_type_not_compilable -> + let s = "void is not a compilable type" in + Format.pp_print_string f s; + | `Compiler_unparsing_unrecognized_data _errlist -> + let s = "unparsing unrecognized data" in + Format.pp_print_string f s; + | `Compiler_untranspilable (mdata,mty) -> + let s = Format.asprintf "this value can't be transpiled back yet. data : %a type : %a" + Michelson.pp mdata + Michelson.pp mty in + Format.pp_print_string f s; + | `Compiler_bad_constant_arity c -> + Format.fprintf f + "Bad arity for %a" + Mini_c.PP.constant c + ) + +let rec error_jsonformat : compiler_error -> J.t = fun a -> + let json_error ~stage ~content = + `Assoc [ + ("status", `String "error") ; + ("stage", `String stage) ; + ("content", content )] + in + match a with + | `Compiler_get_environment (var,env) -> + let var' = Format.asprintf "%a" Var.pp var in + let env' = Format.asprintf "%a" Mini_c.PP.environment env in + let content = `Assoc [ + ("message", `String "failed to get var from environment"); + ("var", `String var'); + ("environment", `String env'); ] in + json_error ~stage ~content + | `Compiler_corner_case (loc,msg) -> + let content = `Assoc [ + ("location", `String loc); + ("message", `String msg); ] in + json_error ~stage ~content + | `Compiler_contract_entrypoint loc -> + let content = `Assoc [ + ("location", `String loc); + ("message", `String "contract entrypoint must be given as literal string"); ] in + json_error ~stage ~content + | `Compiler_expression_tracer (e,ty,err) -> + let e' = Format.asprintf "%a" Mini_c.PP.expression e in + let ty' = Format.asprintf "%a" Mini_c.PP.type_variable ty in + let children = error_jsonformat err in + let content = `Assoc [ + ("message", `String "compiling expression"); + ("expression", `String e'); + ("type", `String ty'); + ("children", children) ] + in + json_error ~stage ~content + | `Compiler_bad_iterator cst -> + let s = Format.asprintf "%a" Mini_c.PP.constant cst in + let content = `Assoc [ + ("message", `String "bad iterator"); + ("iterator", `String s); ] + in + json_error ~stage ~content + | `Compiler_not_comparable_base tb -> + let s = Format.asprintf "%a" Mini_c.PP.type_constant tb in + let content = `Assoc [ + ("message", `String "not a comparable type"); + ("type", `String s); ] + in + json_error ~stage ~content + | `Compiler_not_comparable t -> + let s = Format.asprintf "%a" Mini_c.PP.type_variable t in + let content = `Assoc [ + ("message", `String "not a comparable type"); + ("type", `String s); ] + in + json_error ~stage ~content + | `Compiler_not_comparable_pair_struct -> + let content = `Assoc [ + ("message", `String "pair does not have a comparable structure"); + ("hint", `String "use (a,(b,c)) instead of (a,b,c)"); ] + in + json_error ~stage ~content + | `Compiler_void_type_not_compilable -> + let content = `Assoc [ + ("message", `String "void is not a compilable type"); ] + in + json_error ~stage ~content + | `Compiler_unparsing_unrecognized_data _errlist -> + let content = `Assoc [ + ("message", `String "unparsing unrecognized data"); ] + in + json_error ~stage:uncompiler_stage ~content + | `Compiler_untranspilable (mdata,mty) -> + let mdata' = Format.asprintf "%a" Michelson.pp mdata in + let mty' = Format.asprintf "%a" Michelson.pp mty in + let content = `Assoc [ + ("message", `String "this value can't be transpiled back yet"); + ("michelson data", `String mdata'); + ("michelson type", `String mty'); + ] + in + json_error ~stage:uncompiler_stage ~content + | `Compiler_bad_constant_arity c -> + let constant = Format.asprintf "%a" Mini_c.PP.constant c in + let content = `Assoc [ + ("message", `String "Bad constant arity"); + ("constant", `String constant)] + in + json_error ~stage ~content \ No newline at end of file diff --git a/src/passes/12-compiler/uncompiler.ml b/src/passes/12-compiler/uncompiler.ml index 86e1a8cc9..a6f2ca529 100644 --- a/src/passes/12-compiler/uncompiler.ml +++ b/src/passes/12-compiler/uncompiler.ml @@ -1,3 +1,4 @@ +open Errors open Mini_c.Types open Proto_alpha_utils.Memory_proto_alpha open X @@ -6,7 +7,7 @@ open Protocol open Script_typed_ir open Script_ir_translator -let rec translate_value (Ex_typed_value (ty, value)) : value result = +let rec translate_value (Ex_typed_value (ty, value)) : (value , compiler_error) result = match (ty, value) with | Pair_t ((a_ty, _, _), (b_ty, _, _), _ , _), (a, b) -> ( let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in @@ -43,7 +44,7 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = ok @@ D_timestamp n | (Mutez_t _), n -> let%bind n = - generic_try (simple_error "too big to fit an int") @@ + generic_try (corner_case ~loc:__LOC__ "too big to fit an int") @@ (fun () -> Z.of_int64 @@ Alpha_context.Tez.to_mutez n) in ok @@ D_mutez n | (Bool_t _), b -> @@ -115,24 +116,20 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = | (Operation_t _) , (op , _) -> ok @@ D_operation op | (Lambda_t _ as ty) , _ -> - let%bind m_ty = - trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@ + let%bind m_ty = trace_strong (corner_case ~loc:"TODO" "TODO") @@ + trace_tzresult_lwt unrecognized_data @@ Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_ty ty in let pp_lambda = Format.asprintf "[lambda of type: %a ]" Michelson.pp m_ty in ok @@ D_string pp_lambda | ty, v -> - let%bind error = + let%bind error = trace_strong (corner_case ~loc:"TODO" "TODO") @@ let%bind m_data = - trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@ + trace_tzresult_lwt unrecognized_data @@ Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in let%bind m_ty = - trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@ + trace_tzresult_lwt unrecognized_data @@ Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_ty ty in - let error_content () = - Format.asprintf "%a : %a" - Michelson.pp m_data - Michelson.pp m_ty in - ok @@ (fun () -> error (thunk "this value can't be transpiled back yet") error_content ()) + fail (untranspilable m_data m_ty) in fail error diff --git a/src/passes/12-compiler/uncompiler.mli b/src/passes/12-compiler/uncompiler.mli index 4b717d01c..a2f7aedac 100644 --- a/src/passes/12-compiler/uncompiler.mli +++ b/src/passes/12-compiler/uncompiler.mli @@ -1,6 +1,7 @@ +open Errors open Mini_c.Types open Proto_alpha_utils.Memory_proto_alpha open X open Proto_alpha_utils.Trace -val translate_value : ex_typed_value -> value result +val translate_value : ex_typed_value -> (value , compiler_error) result diff --git a/src/passes/13-self_michelson/helpers.ml b/src/passes/13-self_michelson/helpers.ml index f7421546c..7b84f28a0 100644 --- a/src/passes/13-self_michelson/helpers.ml +++ b/src/passes/13-self_michelson/helpers.ml @@ -3,8 +3,9 @@ open Tezos_utils open Michelson open Tezos_micheline.Micheline -type mapper = michelson -> michelson result -let rec map_expression : mapper -> michelson -> michelson result = fun f e -> +type 'error mapper = michelson -> (michelson,'error) result + +let rec map_expression : 'error mapper -> michelson -> (michelson,_) result = fun f e -> let self = map_expression f in let%bind e' = f e in match e' with @@ -19,12 +20,11 @@ let rec map_expression : mapper -> michelson -> michelson result = fun f e -> | x -> ok x open Memory_proto_alpha.Protocol.Script_ir_translator -let fetch_contract_inputs : ex_ty -> (ex_ty * ex_ty) result = - let error () = simple_fail "Invalid contract: Failed to fetch parameter and storage" in +let fetch_contract_inputs : ex_ty -> (ex_ty * ex_ty) option = function | Ex_ty (Lambda_t (in_ty, _, _)) -> ( match in_ty with | Pair_t ((param_ty,_,_),(storage_ty,_,_),_,_) -> - ok (Ex_ty param_ty, Ex_ty storage_ty) - |_ -> error () ) - | _ -> error () + Some (Ex_ty param_ty, Ex_ty storage_ty) + |_ -> None ) + | _ -> None diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index f99024539..4fc4eba63 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -1,358 +1,3 @@ -module Typer = struct - - open Trace - open Ast_typed - - module Errors = struct - let wrong_param_number = fun name expected got -> - let title () = "wrong number of params" in - let full () = Format.asprintf "constant name: %s\nexpected: %d\ngot: %d\n" - name expected (List.length got) in - error title full - - let error_uncomparable_types a b () = - let title () = "these types are not comparable" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) - ] in - error ~data title message () - - let error_comparator_composed a () = - let title () = "We only allow composed types of not more than two element to be compared" in - let message () = "" in - let data = [ - ("received" , fun () -> Format.asprintf "%a" PP.type_expression a); - ] in - error ~data title message () - - let error_first_field_comp_pair a () = - let title () = "this field is not allowed at the left of a comparable pair" in - let message () = "" in - let data = [ - ("received" , fun () -> Format.asprintf "%a" PP.type_expression a); - ] in - error ~data title message () - - end - - open Errors - - type type_result = type_expression - type typer = type_expression list -> type_expression option -> type_result result - - let typer_0 : string -> (type_expression option -> type_expression 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 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 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 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 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 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 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 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 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) - - open Combinators - - 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 ?msg a b = Assert.assert_true ?msg (eq_1 a b) - - let simple_comparator : string -> typer = fun s -> typer_2 s @@ fun a b -> - let%bind () = - trace_strong (error_uncomparable_types a b) @@ - Assert.assert_true @@ - 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 () = - trace_strong (error_uncomparable_types a b) @@ - Assert.assert_true @@ eq_1 a b - in - let%bind (a_k, a_v) = - trace_strong (error_comparator_composed a) @@ - get_t_pair a in - let%bind (b_k, b_v) = get_t_pair b in - let%bind _ = - trace_strong (error_first_field_comp_pair a) @@ - 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 boolean_operator_2 : string -> typer = fun s -> typer_2 s @@ fun a b -> - let%bind () = - trace_strong (simple_error "A isn't of type bool") @@ - Assert.assert_true @@ - type_expression_eq (t_bool () , a) in - let%bind () = - trace_strong (simple_error "B isn't of type bool") @@ - Assert.assert_true @@ - type_expression_eq (t_bool () , b) in - ok @@ t_bool () - - module Converter = struct - open Ast_typed - open Trace - - let record_checks kvl = - let%bind () = Assert.assert_true_err - (simple_error "converted record must have at least two elements") - (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_err - (simple_error "can't retrieve type declaration order in the converted record, you need to annotate it") - (not all_undefined) in - ok () - - let variant_checks kvl = - let%bind () = Assert.assert_true_err - (simple_error "converted variant must have at least two elements") - (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_err - (simple_error "can't retrieve type declaration order in the converted variant, you need to annotate it") - (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) 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 = get_t_record tr in - let%bind next = from_right_comb_pair comb_lmap (size-1) in - ok (l :: next) - | _ -> simple_fail "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) 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 = get_t_record tl in - let%bind next = from_left_comb_pair comb_lmap (size-1) in - ok (List.append next [r]) - | _ -> simple_fail "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) 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 = get_t_sum tr in - let%bind next = from_right_comb_variant comb_cmap (size-1) in - ok (l :: next) - | _ -> simple_fail "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) 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 = get_t_sum tl in - let%bind next = from_left_comb_variant comb_cmap (size-1) in - ok (List.append next [r]) - | _ -> simple_fail "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 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 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 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 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)) - - end - -end - module Compiler = struct open Tezos_utils.Michelson diff --git a/src/passes/operators/helpers.mli b/src/passes/operators/helpers.mli index 2138a218d..6182ad1fe 100644 --- a/src/passes/operators/helpers.mli +++ b/src/passes/operators/helpers.mli @@ -1,78 +1,3 @@ -module Typer : sig - open Trace - open Ast_typed - - module Errors : sig - val wrong_param_number : string -> int -> 'a list -> unit -> error - val error_uncomparable_types : type_expression -> type_expression -> unit -> error - end - - type type_result = type_expression - type typer = type_expression list -> type_expression option -> type_result result - - (* - val typer'_0 : name -> (type_expression option -> type_expression result) -> typer' - *) - val typer_0 : string -> ( type_expression option -> type_expression result ) -> typer - (* - val typer'_1 : name -> (type_expression -> type_expression result) -> typer' - *) - val typer_1 : string -> (type_expression -> type_expression result) -> typer - (* - val typer'_1_opt : name -> (type_expression -> type_expression option -> type_expression result) -> typer' - *) - val typer_1_opt : string -> (type_expression -> type_expression option -> type_expression result) -> typer - (* - val typer'_2 : name -> (type_expression -> type_expression -> type_expression result) -> typer' - *) - val typer_2 : string -> (type_expression -> type_expression -> type_expression result) -> typer - val typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> type_expression result) -> typer - (* - val typer'_3 : name -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer' - *) - val typer_3 : string -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer - (* - val typer'_4 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer' - *) - val typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer - (* - val typer'_5 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer' - *) - val typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer - (* - val typer'_6 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer' - *) - val typer_6 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer - - val constant' : string -> type_expression -> typer - - val eq_1 : type_expression -> type_expression -> bool - val eq_2 : ( type_expression * type_expression ) -> type_expression -> bool - val assert_eq_1 : ?msg:string -> type_expression -> type_expression -> unit result - - val comparator : string -> typer - val boolean_operator_2 : string -> typer - - module Converter : sig - - open Ast_typed - - val record_checks : (label * field_content) list -> unit result - val variant_checks : (constructor' * ctor_content) list -> unit result - - val convert_pair_to_right_comb : (label * field_content) list -> type_content - val convert_pair_to_left_comb : (label * field_content) list -> type_content - val convert_pair_from_right_comb : field_content label_map -> field_content label_map -> type_content result - val convert_pair_from_left_comb : field_content label_map -> field_content label_map -> type_content result - - val convert_variant_to_right_comb : (constructor' * ctor_content) list -> type_content - val convert_variant_to_left_comb : (constructor' * ctor_content) list -> type_content - val convert_variant_from_right_comb : ctor_content constructor_map -> ctor_content constructor_map -> type_content result - val convert_variant_from_left_comb : ctor_content constructor_map -> ctor_content constructor_map -> type_content result - - end -end - module Compiler : sig open Tezos_utils.Michelson diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index ebafebcba..30b29f6de 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -1,5 +1,3 @@ -open Trace - (* This file is used throughout the pipeline. Its idea is to add a unique place that you have to modify when you add a new operator/constant to the language. @@ -375,955 +373,6 @@ module Concrete_to_imperative = struct let type_constants = type_constants let type_operators = type_operators end - -end - -module Typer = struct - module Operator_errors = struct - let type_error msg expected_type actual_type () = - let message () = - Format.asprintf "Expected an expression of type %a but got an expression of type %a" - Ast_typed.PP.type_expression expected_type - Ast_typed.PP.type_expression actual_type in - error (thunk msg) message - - open PP_helpers - - let print_f_args f printer ppf args = - Format.fprintf ppf "%s(%a)" f (list_sep printer (const " , ")) args - - (* These are handled by typeclasses in the new typer *) - let typeclass_error msg f expected_types actual_types () = - let message () = - Format.asprintf "Expected arguments with one of the following combinations of types: %a but got this combination instead: %a" - (list_sep (print_f_args f Ast_typed.PP.type_expression) (const " or ")) expected_types - (print_f_args f Ast_typed.PP.type_expression) actual_types in - error (thunk msg) message - end - (* - 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 and explaines in `Helpers.Typer`. - *) - - open Helpers.Typer - open Ast_typed - - module Converter = Converter - - 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 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 -> simple_fail @@ Format.asprintf "Typer not implemented for constant %a" Ast_typed.PP.constant c - end - - let none = typer_0 "NONE" @@ fun tv_opt -> - match tv_opt with - | None -> simple_fail "untyped NONE" - | Some t -> ok t - - let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt -> - match tv_opt with - | None -> simple_fail "untyped SET_EMPTY" - | 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 (simple_error "Typing substraction, bad parameters.") - - 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 (get_t_map , get_t_big_map) m in - let%bind () = assert_type_expression_eq (src , k) in - ok m - - let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt -> - match tv_opt with - | None -> simple_fail "untyped MAP_EMPTY" - | Some t -> - let%bind (src, dst) = 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 -> simple_fail "untyped BIG_MAP_EMPTY" - | Some t -> - let%bind (src, dst) = 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 (get_t_map , get_t_big_map) m in - let%bind () = assert_type_expression_eq (src, k) in - let%bind () = assert_type_expression_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 (get_t_map , get_t_big_map) m in - let%bind () = assert_type_expression_eq (src, k) in - let%bind v' = get_t_option v in - let%bind () = assert_type_expression_eq (dst, v') in - ok m - - let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m -> - let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in - let%bind () = assert_type_expression_eq (src, k) in - ok @@ t_bool () - - let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> - let%bind (src, dst) = - trace_strong (simple_error "MAP_FIND: not map or bigmap") @@ - bind_map_or (get_t_map , get_t_big_map) m in - let%bind () = assert_type_expression_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 (get_t_map , get_t_big_map) m in - let%bind () = assert_type_expression_eq (src, k) in - ok @@ t_option dst () - - let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m -> - let%bind (k, v) = get_t_map m in - let%bind (arg , res) = get_t_function f in - let%bind () = assert_eq_1 arg (t_pair k v ()) in - let%bind () = assert_eq_1 res (t_unit ()) in - ok @@ t_unit () - - let map_map : typer = typer_2 "MAP_MAP" @@ fun f m -> - let%bind (k, v) = get_t_map m in - let%bind (arg , res) = get_t_function f in - let%bind () = assert_eq_1 arg (t_pair k v ()) in - ok @@ t_map k res () - - let size = typer_1 "SIZE" @@ fun t -> - let%bind () = - Assert.assert_true @@ - (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in - ok @@ t_nat () - - let slice = typer_3 "SLICE" @@ fun i j s -> - let%bind () = assert_eq_1 i (t_nat ()) in - let%bind () = assert_eq_1 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 @@ Operator_errors.typeclass_error "Computing slice with wrong types" "slice" - [ - [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 @@ Operator_errors.typeclass_error "Failwith with disallowed type" "failwith" - [ - [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 () = 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 () = assert_t_bytes input in - trace_option (simple_error "untyped UNPACK") @@ - output_opt - - let hash256 = typer_1 "SHA256" @@ fun t -> - let%bind () = assert_t_bytes t in - ok @@ t_bytes () - - let hash512 = typer_1 "SHA512" @@ fun t -> - let%bind () = assert_t_bytes t in - ok @@ t_bytes () - - let blake2b = typer_1 "BLAKE2b" @@ fun t -> - let%bind () = assert_t_bytes t in - ok @@ t_bytes () - - let hash_key = typer_1 "HASH_KEY" @@ fun t -> - let%bind () = assert_t_key t in - ok @@ t_key_hash () - - let check_signature = typer_3 "CHECK_SIGNATURE" @@ fun k s b -> - let%bind () = assert_t_key k in - let%bind () = assert_t_signature s in - let%bind () = 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 contract -> - let%bind () = assert_t_contract contract 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 () = assert_t_string entrypoint_as_string in - match tv_opt with - | None -> simple_fail "untyped SELF" - | Some t -> ok @@ t - - let implicit_account = typer_1 "IMPLICIT_ACCOUNT" @@ fun key_hash -> - let%bind () = 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 () = assert_t_mutez amount in - let%bind contract_param = get_t_contract contract in - let%bind () = assert_type_expression_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) = get_t_function f in - let%bind (_,s) = get_t_pair args in - let%bind (oplist,s') = get_t_pair ret in - let%bind () = assert_t_mutez amount in - let%bind (delegate) = get_t_option kh_opt in - let%bind () = assert_type_expression_eq (s,s') in - let%bind () = assert_type_expression_eq (s,init_storage) in - let%bind () = assert_t_list_operation oplist in - let%bind () = 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 -> - if not (type_expression_eq (addr_tv, t_address ())) - then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_expression addr_tv) - else - let%bind tv = - trace_option (simple_error "get_contract needs a type annotation") tv_opt in - let%bind tv' = - trace_strong (simple_error "get_contract has a not-contract annotation") @@ - get_t_contract tv in - ok @@ t_contract tv' () - - let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt -> - if not (type_expression_eq (addr_tv, t_address ())) - then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_expression addr_tv) - else - let%bind tv = - trace_option (simple_error "get_contract_opt needs a type annotation") tv_opt in - let%bind tv = - trace_strong (simple_error "get_entrypoint_opt has a not-option annotation") @@ - get_t_option tv in - let%bind tv' = - trace_strong (simple_error "get_entrypoint_opt has a not-option(contract) annotation") @@ - 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 -> - if not (type_expression_eq (entry_tv, t_string ())) - then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv) - else - if not (type_expression_eq (addr_tv, t_address ())) - then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_expression addr_tv) - else - let%bind tv = - trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in - let%bind tv' = - trace_strong (simple_error "get_entrypoint has a not-contract annotation") @@ - 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 -> - if not (type_expression_eq (entry_tv, t_string ())) - then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv) - else - if not (type_expression_eq (addr_tv, t_address ())) - then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_expression addr_tv) - else - let%bind tv = - trace_option (simple_error "get_entrypoint_opt needs a type annotation") tv_opt in - let%bind tv = - trace_strong (simple_error "get_entrypoint_opt has a not-option annotation") @@ - get_t_option tv in - let%bind tv' = - trace_strong (simple_error "get_entrypoint_opt has a not-option(contract) annotation") @@ - get_t_contract tv in - ok @@ t_option (t_contract tv' ())() - - let set_delegate = typer_1 "SET_DELEGATE" @@ fun delegate_opt -> - let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in - ok @@ t_operation () - - let abs = typer_1 "ABS" @@ fun t -> - let%bind () = assert_t_int t in - ok @@ t_nat () - - let is_nat = typer_1 "ISNAT" @@ fun t -> - let%bind () = assert_t_int t in - ok @@ t_option (t_nat ()) () - - let neg = typer_1 "NEG" @@ fun t -> - let%bind () = Assert.assert_true (eq_1 t (t_nat ()) || eq_1 t (t_int ())) in - ok @@ t_int () - - let assertion = typer_1 "ASSERT" @@ fun a -> - if eq_1 a (t_bool ()) - then ok @@ t_unit () - else fail @@ Operator_errors.type_error "Asserting a non-bool" a (t_bool ()) () - - 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 @@ Operator_errors.typeclass_error "Multiplying with wrong types" "multiply" - [ - [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 @@ Operator_errors.typeclass_error "Dividing with wrong types" "divide" - [ - [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 @@ Operator_errors.typeclass_error "Dividing with wrong types" "divide" - [ - [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 @@ Operator_errors.typeclass_error "Computing modulo with wrong types" "modulo" - [ - [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 @@ Operator_errors.typeclass_error "Adding modulo with wrong types" "add" - [ - [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 = get_t_set set in - if eq_1 elt key - then ok @@ t_bool () - else fail @@ Operator_errors.type_error "Set.mem: elt and set don't match" elt key () - - let set_add = typer_2 "SET_ADD" @@ fun elt set -> - let%bind key = get_t_set set in - if eq_1 elt key - then ok set - else fail @@ Operator_errors.type_error "Set.add: elt and set don't match" elt key () - - let set_remove = typer_2 "SET_REMOVE" @@ fun elt set -> - let%bind key = get_t_set set in - if eq_1 elt key - then ok set - else fail @@ Operator_errors.type_error "Set.remove: elt and set don't match" key elt () - - let set_iter = typer_2 "SET_ITER" @@ fun body set -> - let%bind (arg , res) = get_t_function body in - let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in - let%bind key = get_t_set set in - if eq_1 key arg - then ok (t_unit ()) - else fail @@ Operator_errors.type_error "bad set iter" key arg () - - let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt -> - match tv_opt with - | None -> simple_fail "untyped LIST_EMPTY" - | Some t -> ok t - - let list_iter = typer_2 "LIST_ITER" @@ fun body lst -> - let%bind (arg , res) = get_t_function body in - let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in - let%bind key = get_t_list lst in - if eq_1 key arg - then ok (t_unit ()) - else fail @@ Operator_errors.type_error "bad list iter" key arg () - - let list_map = typer_2 "LIST_MAP" @@ fun body lst -> - let%bind (arg , res) = get_t_function body in - let%bind key = get_t_list lst in - if eq_1 key arg - then ok (t_list res ()) - else fail @@ Operator_errors.type_error "bad list map" key arg () - - let list_fold = typer_3 "LIST_FOLD" @@ fun body lst init -> - let%bind (arg , res) = get_t_function body in - let%bind (prec , cur) = get_t_pair arg in - let%bind key = get_t_list lst in - let msg = Format.asprintf "%a vs %a" - PP.type_expression key - PP.type_expression arg - in - trace (simple_error ("bad list fold:" ^ msg)) @@ - let%bind () = assert_eq_1 ~msg:"key cur" key cur in - let%bind () = assert_eq_1 ~msg:"prec res" prec res in - let%bind () = assert_eq_1 ~msg:"res init" res init in - ok res - - let set_fold = typer_3 "SET_FOLD" @@ fun body lst init -> - let%bind (arg , res) = get_t_function body in - let%bind (prec , cur) = get_t_pair arg in - let%bind key = get_t_set lst in - let msg = Format.asprintf "%a vs %a" - PP.type_expression key - PP.type_expression arg - in - trace (simple_error ("bad set fold:" ^ msg)) @@ - let%bind () = assert_eq_1 ~msg:"key cur" key cur in - let%bind () = assert_eq_1 ~msg:"prec res" prec res in - let%bind () = assert_eq_1 ~msg:"res init" res init in - ok res - - let map_fold = typer_3 "MAP_FOLD" @@ fun body map init -> - let%bind (arg , res) = get_t_function body in - let%bind (prec , cur) = get_t_pair arg in - let%bind (key , value) = get_t_map map in - let msg = Format.asprintf "%a vs %a" - PP.type_expression key - PP.type_expression arg - in - trace (simple_error ("bad map fold:" ^ msg)) @@ - let%bind () = assert_eq_1 ~msg:"key cur" (t_pair key value ()) cur in - let%bind () = assert_eq_1 ~msg:"prec res" prec res in - let%bind () = assert_eq_1 ~msg:"res init" res init in - ok res - - (** 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) = get_t_function body in - let%bind () = assert_eq_1 arg init in - let%bind () = assert_eq_1 (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 @@ Operator_errors.type_error "bad parameter to not" elt (t_bool ()) () - - 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 @@ Operator_errors.typeclass_error "OR with wrong types" "or" - [ - [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 @@ Operator_errors.typeclass_error "XOR with wrong types" "xor" - [ - [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 @@ Operator_errors.typeclass_error "AND with wrong types" "and" - [ - [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 @@ Operator_errors.typeclass_error "LSL with wrong types" "lsl" - [ - [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 @@ Operator_errors.typeclass_error "LSR with wrong types" "lsr" - [ - [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 @@ Operator_errors.typeclass_error "Concatenation with wrong types" "concat" - [ - [t_string();t_string()] ; - [t_bytes();t_bytes()] ; - ] - [a; b] () - - let cons = typer_2 "CONS" @@ fun hd tl -> - let%bind elt = get_t_list tl in - let%bind () = assert_eq_1 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 () = Converter.record_checks kvl in - let pair = 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 () = Converter.variant_checks kvl in - let michelson_or = Converter.convert_variant_to_right_comb kvl in - ok {t with type_content = michelson_or} - | _ -> simple_fail "converter can only be used on record or variants" - - 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 () = Converter.record_checks kvl in - let pair = 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 () = Converter.variant_checks kvl in - let michelson_or = Converter.convert_variant_to_left_comb kvl in - ok {t with type_content = michelson_or} - | _ -> simple_fail "converter can only be used on record or variants" - - let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun t opt -> - match t.type_content with - | T_record src_lmap -> - let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in - let%bind dst_lmap = get_t_record dst_t in - let%bind record = Converter.convert_pair_from_right_comb src_lmap dst_lmap in - ok {t with type_content = record} - | T_sum src_cmap -> - let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in - let%bind dst_cmap = get_t_sum dst_t in - let%bind variant = Converter.convert_variant_from_right_comb src_cmap dst_cmap in - ok {t with type_content = variant} - | _ -> simple_fail "converter can only be used on record or variants" - - let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun t opt -> - match t.type_content with - | T_record src_lmap -> - let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in - let%bind dst_lmap = get_t_record dst_t in - let%bind record = Converter.convert_pair_from_left_comb src_lmap dst_lmap in - ok {t with type_content = record} - | T_sum src_cmap -> - let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in - let%bind dst_cmap = get_t_sum dst_t in - let%bind variant = Converter.convert_variant_from_left_comb src_cmap dst_cmap in - ok {t with type_content = variant} - | _ -> simple_fail "converter can only be used on record or variants" - - let constant_typers c : typer 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 ; - | _ -> simple_fail @@ Format.asprintf "Typer not implemented for constant %a" PP.constant c - - - end module Compiler = struct @@ -1345,77 +394,71 @@ module Compiler = struct open Tezos_utils.Michelson open Mini_c - let get_operators c : predicate result = + let get_operators c : predicate option = match c with - | C_ADD -> ok @@ simple_binary @@ prim I_ADD - | C_SUB -> ok @@ simple_binary @@ prim I_SUB - | C_MUL -> ok @@ simple_binary @@ prim I_MUL - | C_EDIV -> ok @@ simple_binary @@ prim I_EDIV - | C_DIV -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car] - | C_MOD -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr] - | C_NEG -> ok @@ simple_unary @@ prim I_NEG - | C_OR -> ok @@ simple_binary @@ prim I_OR - | C_AND -> ok @@ simple_binary @@ prim I_AND - | C_XOR -> ok @@ simple_binary @@ prim I_XOR - | C_LSL -> ok @@ simple_binary @@ prim I_LSL - | C_LSR -> ok @@ simple_binary @@ prim I_LSR - | C_NOT -> ok @@ simple_unary @@ prim I_NOT - | C_PAIR -> ok @@ simple_binary @@ prim I_PAIR - | C_CAR -> ok @@ simple_unary @@ prim I_CAR - | C_CDR -> ok @@ simple_unary @@ prim I_CDR - | C_EQ -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_EQ] - | C_NEQ -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ] - | C_LT -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LT] - | C_LE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LE] - | C_GT -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GT] - | C_GE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GE] - | C_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE - | C_SOME -> ok @@ simple_unary @@ prim I_SOME - | C_MAP_FIND -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")] - | C_MAP_MEM -> ok @@ simple_binary @@ prim I_MEM - | C_MAP_FIND_OPT -> ok @@ simple_binary @@ prim I_GET - | C_MAP_ADD -> ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE] - | C_MAP_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE - | C_FOLD_WHILE -> ok @@ simple_binary @@ seq [i_swap ; (i_push (prim T_bool) (prim D_True));prim ~children:[seq [dip i_dup; i_exec; i_unpair]] I_LOOP ;i_swap ; i_drop] - | C_FOLD_CONTINUE -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)); i_pair] - | C_FOLD_STOP -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)); i_pair] - | C_SIZE -> ok @@ simple_unary @@ prim I_SIZE - | C_FAILWITH -> ok @@ simple_unary @@ prim I_FAILWITH - | C_ASSERT_INFERRED -> ok @@ simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit]) - | C_ASSERTION -> ok @@ simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_string "failed assertion" ; i_failwith]) - | C_INT -> ok @@ simple_unary @@ prim I_INT - | C_ABS -> ok @@ simple_unary @@ prim I_ABS - | C_IS_NAT -> ok @@ simple_unary @@ prim I_ISNAT - | C_CONS -> ok @@ simple_binary @@ prim I_CONS - | C_UNIT -> ok @@ simple_constant @@ prim I_UNIT - | C_BALANCE -> ok @@ simple_constant @@ prim I_BALANCE - | C_AMOUNT -> ok @@ simple_constant @@ prim I_AMOUNT - | C_ADDRESS -> ok @@ simple_unary @@ prim I_ADDRESS - | C_SELF_ADDRESS -> ok @@ simple_constant @@ seq [prim I_SELF; prim I_ADDRESS] - | C_IMPLICIT_ACCOUNT -> ok @@ simple_unary @@ prim I_IMPLICIT_ACCOUNT - | C_SET_DELEGATE -> ok @@ simple_unary @@ prim I_SET_DELEGATE - | C_NOW -> ok @@ simple_constant @@ prim I_NOW - | C_CALL -> ok @@ simple_ternary @@ prim I_TRANSFER_TOKENS - | C_SOURCE -> ok @@ simple_constant @@ prim I_SOURCE - | C_SENDER -> ok @@ simple_constant @@ prim I_SENDER - | C_SET_MEM -> ok @@ simple_binary @@ prim I_MEM - | C_SET_ADD -> ok @@ simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE] - | C_SET_REMOVE -> ok @@ simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE] - | C_SLICE -> ok @@ simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")] - | C_SHA256 -> ok @@ simple_unary @@ prim I_SHA256 - | C_SHA512 -> ok @@ simple_unary @@ prim I_SHA512 - | C_BLAKE2b -> ok @@ simple_unary @@ prim I_BLAKE2B - | C_CHECK_SIGNATURE -> ok @@ simple_ternary @@ prim I_CHECK_SIGNATURE - | C_HASH_KEY -> ok @@ simple_unary @@ prim I_HASH_KEY - | C_BYTES_PACK -> ok @@ simple_unary @@ prim I_PACK - | C_CONCAT -> ok @@ simple_binary @@ prim I_CONCAT - | C_CHAIN_ID -> ok @@ simple_constant @@ prim I_CHAIN_ID - | _ -> simple_fail @@ Format.asprintf "operator not implemented for %a" Stage_common.PP.constant c + | C_ADD -> Some ( simple_binary @@ prim I_ADD) + | C_SUB -> Some ( simple_binary @@ prim I_SUB) + | C_MUL -> Some ( simple_binary @@ prim I_MUL) + | C_EDIV -> Some ( simple_binary @@ prim I_EDIV) + | C_DIV -> Some ( simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]) + | C_MOD -> Some ( simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr]) + | C_NEG -> Some ( simple_unary @@ prim I_NEG) + | C_OR -> Some ( simple_binary @@ prim I_OR) + | C_AND -> Some ( simple_binary @@ prim I_AND) + | C_XOR -> Some ( simple_binary @@ prim I_XOR) + | C_LSL -> Some ( simple_binary @@ prim I_LSL) + | C_LSR -> Some ( simple_binary @@ prim I_LSR) + | C_NOT -> Some ( simple_unary @@ prim I_NOT) + | C_PAIR -> Some ( simple_binary @@ prim I_PAIR) + | C_CAR -> Some ( simple_unary @@ prim I_CAR) + | C_CDR -> Some ( simple_unary @@ prim I_CDR) + | C_EQ -> Some ( simple_binary @@ seq [prim I_COMPARE ; prim I_EQ]) + | C_NEQ -> Some ( simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ]) + | C_LT -> Some ( simple_binary @@ seq [prim I_COMPARE ; prim I_LT]) + | C_LE -> Some ( simple_binary @@ seq [prim I_COMPARE ; prim I_LE]) + | C_GT -> Some ( simple_binary @@ seq [prim I_COMPARE ; prim I_GT]) + | C_GE -> Some ( simple_binary @@ seq [prim I_COMPARE ; prim I_GE]) + | C_UPDATE -> Some ( simple_ternary @@ prim I_UPDATE) + | C_SOME -> Some ( simple_unary @@ prim I_SOME) + | C_MAP_FIND -> Some ( simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) + | C_MAP_MEM -> Some ( simple_binary @@ prim I_MEM) + | C_MAP_FIND_OPT -> Some ( simple_binary @@ prim I_GET) + | C_MAP_ADD -> Some ( simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) + | C_MAP_UPDATE -> Some ( simple_ternary @@ prim I_UPDATE) + | C_FOLD_WHILE -> Some ( simple_binary @@ seq [i_swap ; (i_push (prim T_bool) (prim D_True));prim ~children:[seq [dip i_dup; i_exec; i_unpair]] I_LOOP ;i_swap ; i_drop]) + | C_FOLD_CONTINUE -> Some ( simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)); i_pair]) + | C_FOLD_STOP -> Some ( simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)); i_pair]) + | C_SIZE -> Some ( simple_unary @@ prim I_SIZE) + | C_FAILWITH -> Some ( simple_unary @@ prim I_FAILWITH) + | C_ASSERT_INFERRED -> Some ( simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) + | C_ASSERTION -> Some ( simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_string "failed assertion" ; i_failwith])) + | C_INT -> Some ( simple_unary @@ prim I_INT) + | C_ABS -> Some ( simple_unary @@ prim I_ABS) + | C_IS_NAT -> Some ( simple_unary @@ prim I_ISNAT) + | C_CONS -> Some ( simple_binary @@ prim I_CONS) + | C_UNIT -> Some ( simple_constant @@ prim I_UNIT) + | C_BALANCE -> Some ( simple_constant @@ prim I_BALANCE) + | C_AMOUNT -> Some ( simple_constant @@ prim I_AMOUNT) + | C_ADDRESS -> Some ( simple_unary @@ prim I_ADDRESS) + | C_SELF_ADDRESS -> Some ( simple_constant @@ seq [prim I_SELF; prim I_ADDRESS]) + | C_IMPLICIT_ACCOUNT -> Some ( simple_unary @@ prim I_IMPLICIT_ACCOUNT) + | C_SET_DELEGATE -> Some ( simple_unary @@ prim I_SET_DELEGATE) + | C_NOW -> Some ( simple_constant @@ prim I_NOW) + | C_CALL -> Some ( simple_ternary @@ prim I_TRANSFER_TOKENS) + | C_SOURCE -> Some ( simple_constant @@ prim I_SOURCE) + | C_SENDER -> Some ( simple_constant @@ prim I_SENDER) + | C_SET_MEM -> Some ( simple_binary @@ prim I_MEM) + | C_SET_ADD -> Some ( simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) + | C_SET_REMOVE -> Some ( simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) + | C_SLICE -> Some ( simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")]) + | C_SHA256 -> Some ( simple_unary @@ prim I_SHA256) + | C_SHA512 -> Some ( simple_unary @@ prim I_SHA512) + | C_BLAKE2b -> Some ( simple_unary @@ prim I_BLAKE2B) + | C_CHECK_SIGNATURE -> Some ( simple_ternary @@ prim I_CHECK_SIGNATURE) + | C_HASH_KEY -> Some ( simple_unary @@ prim I_HASH_KEY) + | C_BYTES_PACK -> Some ( simple_unary @@ prim I_PACK) + | C_CONCAT -> Some ( simple_binary @@ prim I_CONCAT) + | C_CHAIN_ID -> Some ( simple_constant @@ prim I_CHAIN_ID) + | _ -> None - - (* - Some complex operators will need to be added in compiler/compiler_program. - All operators whose compilations involve a type are found there. - *) - -end +end \ No newline at end of file diff --git a/src/passes/operators/operators.mli b/src/passes/operators/operators.mli index 502d7af39..3ccced4df 100644 --- a/src/passes/operators/operators.mli +++ b/src/passes/operators/operators.mli @@ -16,181 +16,12 @@ module Concrete_to_imperative : sig end -module Typer : sig - open Helpers.Typer - open Ast_typed - open Trace - - module Operators_types : sig - (* TODO: we need a map from type names to type values. Then, all - these bindings don't need to be exported anymore. *) - val tc_subarg : - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val tc_sizearg : - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val tc_packable : - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val tc_timargs : - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val tc_divargs : - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val tc_modargs : - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val tc_addargs : - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> - Typesystem.Core.type_value -> Typesystem.Core.type_constraint - val t_none : Typesystem.Core.type_value - val t_sub : Typesystem.Core.type_value - val t_some : Typesystem.Core.type_value - val t_map_remove : Typesystem.Core.type_value - val t_map_add : Typesystem.Core.type_value - val t_map_update : Typesystem.Core.type_value - val t_map_mem : Typesystem.Core.type_value - val t_map_find : Typesystem.Core.type_value - val t_map_find_opt : Typesystem.Core.type_value - val t_map_fold : Typesystem.Core.type_value - val t_map_map : Typesystem.Core.type_value - val t_map_map_fold : Typesystem.Core.type_value - val t_map_iter : Typesystem.Core.type_value - val t_size : Typesystem.Core.type_value - val t_slice : Typesystem.Core.type_value - val t_failwith : Typesystem.Core.type_value - val t_get_force : Typesystem.Core.type_value - val t_int : Typesystem.Core.type_value - val t_bytes_pack : Typesystem.Core.type_value - val t_bytes_unpack : Typesystem.Core.type_value - val t_hash256 : Typesystem.Core.type_value - val t_hash512 : Typesystem.Core.type_value - val t_blake2b : Typesystem.Core.type_value - val t_hash_key : Typesystem.Core.type_value - val t_check_signature : Typesystem.Core.type_value - val t_sender : Typesystem.Core.type_value - val t_source : Typesystem.Core.type_value - val t_unit : Typesystem.Core.type_value - val t_amount : Typesystem.Core.type_value - val t_address : Typesystem.Core.type_value - val t_now : Typesystem.Core.type_value - val t_transaction : Typesystem.Core.type_value - val t_get_contract : Typesystem.Core.type_value - val t_abs : Typesystem.Core.type_value - val t_cons : Typesystem.Core.type_value - val t_assertion : Typesystem.Core.type_value - val t_times : Typesystem.Core.type_value - val t_div : Typesystem.Core.type_value - val t_mod : Typesystem.Core.type_value - val t_add : Typesystem.Core.type_value - val t_set_mem : Typesystem.Core.type_value - val t_set_add : Typesystem.Core.type_value - val t_set_remove : Typesystem.Core.type_value - val t_not : Typesystem.Core.type_value - val constant_type : constant' -> Typesystem.Core.type_value Trace.result - end - - (* - val none : typer - val set_empty : typer - val sub : typer - val some : typer - val map_remove : typer - val map_add : typer - val map_update : typer - val map_mem : typer - val map_find : typer - *) - val map_find_opt : typer - (* - val map_iter : typer - val map_map : typer - val map_fold : typer - val big_map_remove : typer - val big_map_add : typer - val big_map_update : typer - val big_map_mem : typer - val big_map_find : typer - val size : typer - val slice : typer - val failwith_ : typer - val get_force : typer - val int : typer - val bytes_pack : typer - val bytes_unpack : typer - val hash256 : typer - val hash512 : typer - val blake2b : typer - val hash_key : typer - val check_signature : typer - val sender : typer - val source : typer - val unit : typer - val amount : typer - *) - val balance : typer - (* - val address : typer - val now : typer - val transaction : typer - *) - val create_contract : typer - (* - val get_contract : typer - *) - val set_delegate : typer - (* - val abs : typer - val neg : typer - val assertion : typer - val times : typer - val div : typer - val mod_ : typer - val add : typer - val set_mem : typer - val set_add : typer - val set_remove : typer - val set_iter : typer - val list_iter : typer - val list_map : typer - val not_ : typer - val or_ : typer - val xor : typer - val and_ : typer - *) - val lsl_ : typer - val lsr_ : typer - (* - val concat : typer - *) - val cons : typer - val constant_typers : constant' -> typer result - - module Converter : sig - - open Ast_typed - - val record_checks : (label * field_content) list -> unit result - val convert_pair_to_right_comb : (label * field_content) list -> type_content - val convert_pair_to_left_comb : (label * field_content) list -> type_content - val convert_variant_to_right_comb : (constructor' * ctor_content) list -> type_content - val convert_variant_to_left_comb : (constructor' * ctor_content) list -> type_content - - end -end - module Compiler : sig (* include Helpers.Compiler *) open Tezos_utils.Michelson open Mini_c - open Trace type predicate = | Constant of michelson @@ -200,7 +31,7 @@ module Compiler : sig | Tetrary of michelson | Pentary of michelson | Hexary of michelson - val get_operators : constant' -> predicate result + val get_operators : constant' -> predicate option val simple_constant : t -> predicate val simple_unary : t -> predicate val simple_binary : t -> predicate diff --git a/src/stages/1-ast_imperative/ast_imperative.ml b/src/stages/1-ast_imperative/ast_imperative.ml index 7fa34e677..a6dddcf8b 100644 --- a/src/stages/1-ast_imperative/ast_imperative.ml +++ b/src/stages/1-ast_imperative/ast_imperative.ml @@ -5,3 +5,4 @@ include Combinators module Types = Types module PP=PP module Combinators = Combinators +module Formatter = Formatter diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 22687dd67..94432921b 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -1,20 +1,8 @@ open Types -open Simple_utils.Trace module Option = Simple_utils.Option module SMap = Map.String -module Errors = struct - let bad_kind expected location = - let title () = Format.asprintf "a %s was expected" expected in - let message () = "" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title message -end -open Errors - let make_t ?(loc = Location.generated) type_content = {type_content; location=loc} let t_bool ?loc () : type_expression = make_t ?loc @@ T_variable (Stage_common.Constant.t_bool) @@ -69,8 +57,8 @@ let t_michelson_or_left_comb ?loc c : type_expression = make_t ?loc @@ T_o let get_t_annoted = fun te -> match te.type_content with - T_annoted (te, lst) -> ok (te,lst) - | _ -> simple_fail "not a T_annoted" + T_annoted (te, lst) -> Some (te,lst) + | _ -> None let make_e ?(loc = Location.generated) expression_content = let location = loc in @@ -93,12 +81,15 @@ let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signatur let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s) let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s) let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s) -let e'_bytes b : expression_content result = - let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in - ok @@ E_literal (Literal_bytes bytes) -let e_bytes_hex ?loc b : expression result = - let%bind e' = e'_bytes b in - ok @@ make_e ?loc e' +let e'_bytes b : expression_content option = + try + let bytes = Hex.to_bytes (`Hex b) in + Some (E_literal (Literal_bytes bytes)) + with _ -> None +let e_bytes_hex ?loc b : expression option = + match e'_bytes b with + | Some e' -> Some (make_e ?loc e') + | None -> None let e_bytes_raw ?loc (b: bytes) : expression = make_e ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = @@ -189,45 +180,46 @@ let e_assign ?loc variable access_path expression = let get_e_accessor = fun t -> match t with - | E_accessor {record; path} -> ok (record , path) - | _ -> simple_fail "not an accessor" + | E_accessor {record; path} -> Some (record , path) + | _ -> None let assert_e_accessor = fun t -> - let%bind _ = get_e_accessor t in - ok () + match get_e_accessor t with + | None -> None + | Some _ -> Some () let get_e_pair = fun t -> match t with - | E_tuple [a ; b] -> ok (a , b) - | _ -> simple_fail "not a pair" + | E_tuple [a ; b] -> Some (a , b) + | _ -> None let get_e_list = fun t -> match t with - | E_list lst -> ok lst - | _ -> simple_fail "not a list" + | E_list lst -> Some lst + | _ -> None let get_e_tuple = fun t -> match t with - | E_tuple t -> ok @@ t - | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" + | E_tuple t -> Some t + | _ -> None (* Same as get_e_pair *) -let extract_pair : expression -> (expression * expression) result = fun e -> +let extract_pair : expression -> (expression * expression) option = fun e -> match e.expression_content with - | E_tuple [a;b] -> ok @@ (a,b) - | _ -> fail @@ bad_kind "pair" e.location + | E_tuple [a;b] -> Some (a,b) + | _ -> None -let extract_list : expression -> (expression list) result = fun e -> +let extract_list : expression -> expression list option = fun e -> match e.expression_content with - | E_list lst -> ok lst - | _ -> fail @@ bad_kind "list" e.location + | E_list lst -> Some lst + | _ -> None -let extract_record : expression -> (label * expression) list result = fun e -> +let extract_record : expression -> (label * expression) list option = fun e -> match e.expression_content with - | E_record lst -> ok @@ LMap.to_kv_list lst - | _ -> fail @@ bad_kind "record" e.location + | E_record lst -> Some (LMap.to_kv_list lst) + | _ -> None -let extract_map : expression -> (expression * expression) list result = fun e -> +let extract_map : expression -> (expression * expression) list option = fun e -> match e.expression_content with - | E_map lst -> ok lst - | _ -> fail @@ bad_kind "map" e.location + | E_map lst -> Some lst + | _ -> None diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index c9ce85c03..170f0a2c0 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -1,14 +1,7 @@ open Types -open Simple_utils.Trace -(* -module Option = Simple_utils.Option module SMap = Map.String -module Errors : sig - val bad_kind : name -> Location.t -> unit -> error -end -*) val make_t : ?loc:Location.t -> type_content -> type_expression val t_bool : ?loc:Location.t -> unit -> type_expression val t_string : ?loc:Location.t -> unit -> type_expression @@ -23,14 +16,8 @@ val t_key : ?loc:Location.t -> unit -> type_expression val t_key_hash : ?loc:Location.t -> unit -> type_expression val t_timestamp : ?loc:Location.t -> unit -> type_expression val t_signature : ?loc:Location.t -> unit -> type_expression -(* -val t_option : type_expression -> type_expression -*) val t_list : ?loc:Location.t -> type_expression -> type_expression val t_variable : ?loc:Location.t -> string -> type_expression -(* -val t_record : te_map -> type_expression -*) val t_pair : ?loc:Location.t -> ( type_expression * type_expression ) -> type_expression val t_tuple : ?loc:Location.t -> type_expression list -> type_expression @@ -56,7 +43,7 @@ val t_set : ?loc:Location.t -> type_expression -> type_expression val t_contract : ?loc:Location.t -> type_expression -> type_expression val t_annoted : ?loc:Location.t -> type_expression -> string -> type_expression -val get_t_annoted : type_expression -> (type_expression* string) result +val get_t_annoted : type_expression -> (type_expression* string) option val make_e : ?loc:Location.t -> expression_content -> expression @@ -78,8 +65,8 @@ val e_key_hash : ?loc:Location.t -> string -> expression val e_chain_id : ?loc:Location.t -> string -> expression val e_mutez_z : ?loc:Location.t -> Z.t -> expression val e_mutez : ?loc:Location.t -> int -> expression -val e'_bytes : string -> expression_content result -val e_bytes_hex : ?loc:Location.t -> string -> expression result +val e'_bytes : string -> expression_content option +val e_bytes_hex : ?loc:Location.t -> string -> expression option val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_string : ?loc:Location.t -> string -> expression @@ -143,21 +130,11 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression - -val assert_e_accessor : expression_content -> unit result - -val get_e_pair : expression_content -> ( expression * expression ) result - -val get_e_list : expression_content -> ( expression list ) result -val get_e_tuple : expression_content -> ( expression list ) result -(* -val get_e_failwith : expression -> expression result -val is_e_failwith : expression -> bool -*) -val extract_pair : expression -> ( expression * expression ) result - -val extract_list : expression -> (expression list) result - -val extract_record : expression -> (label * expression) list result - -val extract_map : expression -> (expression * expression) list result +val assert_e_accessor : expression_content -> unit option +val get_e_pair : expression_content -> (expression * expression) option +val get_e_list : expression_content -> expression list option +val get_e_tuple : expression_content -> expression list option +val extract_pair : expression -> (expression * expression) option +val extract_list : expression -> expression list option +val extract_record : expression -> (label * expression) list option +val extract_map : expression -> (expression * expression) list option diff --git a/src/stages/1-ast_imperative/formatter.ml b/src/stages/1-ast_imperative/formatter.ml new file mode 100644 index 000000000..9d3489fef --- /dev/null +++ b/src/stages/1-ast_imperative/formatter.ml @@ -0,0 +1,14 @@ +open Display + +let program_ppformat ~display_format f (p,_) = + match display_format with + | Human_readable | Dev -> PP.program f p + +let program_jsonformat (p,_) : json = + let p' = Format.asprintf "%a" PP.program p in + `Assoc [("AST" , `String p')] + +let program_format : 'a format = { + pp = program_ppformat; + to_json = program_jsonformat; +} \ No newline at end of file diff --git a/src/stages/2-ast_sugar/ast_sugar.ml b/src/stages/2-ast_sugar/ast_sugar.ml index 7fa34e677..a6dddcf8b 100644 --- a/src/stages/2-ast_sugar/ast_sugar.ml +++ b/src/stages/2-ast_sugar/ast_sugar.ml @@ -5,3 +5,4 @@ include Combinators module Types = Types module PP=PP module Combinators = Combinators +module Formatter = Formatter diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 8c254df2b..6dded916e 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -1,20 +1,8 @@ open Types -open Simple_utils.Trace module Option = Simple_utils.Option module SMap = Map.String -module Errors = struct - let bad_kind expected location = - let title () = Format.asprintf "a %s was expected" expected in - let message () = "" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title message -end -open Errors - let make_t ?(loc = Location.generated) type_content = {type_content; location=loc} @@ -84,12 +72,12 @@ let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signatur let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s) let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s) let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s) -let e'_bytes b : expression_content result = - let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in - ok @@ E_literal (Literal_bytes bytes) -let e_bytes_hex ?loc b : expression result = - let%bind e' = e'_bytes b in - ok @@ make_e ?loc e' +let e'_bytes b : expression_content = + let bytes = Hex.to_bytes (`Hex b) in + E_literal (Literal_bytes bytes) +let e_bytes_hex ?loc b : expression = + let e' = e'_bytes b in + make_e ?loc e' let e_bytes_raw ?loc (b: bytes) : expression = make_e ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = @@ -150,45 +138,46 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) let get_e_accessor = fun t -> match t with - | E_accessor {record; path} -> ok (record, path) - | _ -> simple_fail "not a record accessor" + | E_accessor {record; path} -> Some (record, path) + | _ -> None let assert_e_accessor = fun t -> - let%bind _ = get_e_accessor t in - ok () + match get_e_accessor t with + | Some _ -> Some () + | None -> None let get_e_pair = fun t -> match t with - | E_tuple [a ; b] -> ok (a , b) - | _ -> simple_fail "not a pair" + | E_tuple [a ; b] -> Some (a , b) + | _ -> None let get_e_list = fun t -> match t with - | E_list lst -> ok lst - | _ -> simple_fail "not a list" + | E_list lst -> Some lst + | _ -> None let get_e_tuple = fun t -> match t with - | E_tuple t -> ok @@ t - | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" + | E_tuple t -> Some t + | _ -> None (* Same as get_e_pair *) -let extract_pair : expression -> (expression * expression) result = fun e -> +let extract_pair : expression -> (expression * expression) option = fun e -> match e.expression_content with - | E_tuple [a;b] -> ok @@ (a,b) - | _ -> fail @@ bad_kind "pair" e.location + | E_tuple [a;b] -> Some (a,b) + | _ -> None -let extract_list : expression -> (expression list) result = fun e -> +let extract_list : expression -> (expression list) option = fun e -> match e.expression_content with - | E_list lst -> ok lst - | _ -> fail @@ bad_kind "list" e.location + | E_list lst -> Some lst + | _ -> None -let extract_record : expression -> (label * expression) list result = fun e -> +let extract_record : expression -> ((label * expression) list) option = fun e -> match e.expression_content with - | E_record lst -> ok @@ LMap.to_kv_list lst - | _ -> fail @@ bad_kind "record" e.location + | E_record lst -> Some (LMap.to_kv_list lst) + | _ -> None -let extract_map : expression -> (expression * expression) list result = fun e -> +let extract_map : expression -> ((expression * expression) list) option = fun e -> match e.expression_content with - | E_map lst -> ok lst - | _ -> fail @@ bad_kind "map" e.location + | E_map lst -> Some lst + | _ -> None diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index 7d4fcbcdf..765799b5c 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -1,5 +1,4 @@ open Types -open Simple_utils.Trace (* module Option = Simple_utils.Option @@ -62,8 +61,8 @@ val e_key : ?loc:Location.t -> string -> expression val e_key_hash : ?loc:Location.t -> string -> expression val e_chain_id : ?loc:Location.t -> string -> expression val e_mutez : ?loc:Location.t -> Z.t -> expression -val e'_bytes : string -> expression_content result -val e_bytes_hex : ?loc:Location.t -> string -> expression result +val e'_bytes : string -> expression_content +val e_bytes_hex : ?loc:Location.t -> string -> expression val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_string : ?loc:Location.t -> string -> expression val e_some : ?loc:Location.t -> expression -> expression @@ -110,20 +109,16 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression -val assert_e_accessor : expression_content -> unit result +val assert_e_accessor : expression_content -> unit option -val get_e_pair : expression_content -> ( expression * expression ) result +val get_e_pair : expression_content -> (expression * expression) option -val get_e_list : expression_content -> ( expression list ) result -val get_e_tuple : expression_content -> ( expression list ) result -(* -val get_e_failwith : expression -> expression result -val is_e_failwith : expression -> bool -*) -val extract_pair : expression -> ( expression * expression ) result +val get_e_list : expression_content -> (expression list) option +val get_e_tuple : expression_content -> (expression list) option +val extract_pair : expression -> (expression * expression) option -val extract_list : expression -> (expression list) result +val extract_list : expression -> (expression list) option -val extract_record : expression -> (label * expression) list result +val extract_record : expression -> ((label * expression) list) option -val extract_map : expression -> (expression * expression) list result +val extract_map : expression -> ((expression * expression) list) option diff --git a/src/stages/2-ast_sugar/formatter.ml b/src/stages/2-ast_sugar/formatter.ml new file mode 100644 index 000000000..d48ae19c1 --- /dev/null +++ b/src/stages/2-ast_sugar/formatter.ml @@ -0,0 +1,14 @@ +open Display + +let program_ppformat ~display_format f (p,_) = + match display_format with + | Human_readable | Dev -> PP.program f p + +let program_jsonformat (p,_) : json = + let core' = Format.asprintf "%a" PP.program p in + `Assoc [("Sugar" , `String core')] + +let program_format : 'a format = { + pp = program_ppformat; + to_json = program_jsonformat; +} \ No newline at end of file diff --git a/src/stages/3-ast_core/ast_core.ml b/src/stages/3-ast_core/ast_core.ml index e9614490a..7c136fd4f 100644 --- a/src/stages/3-ast_core/ast_core.ml +++ b/src/stages/3-ast_core/ast_core.ml @@ -6,3 +6,4 @@ module Types = Types module Misc = Misc module PP=PP module Combinators = Combinators +module Formatter = Formatter diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index 139a9ece8..2e578d27e 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -1,23 +1,10 @@ open Types -open Simple_utils.Trace module Option = Simple_utils.Option module SMap = Map.String -module Errors = struct - let bad_kind expected location = - let title () = Format.asprintf "a %s was expected" expected in - let message () = "" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title message -end -open Errors - let make_t ?(loc = Location.generated) type_content = {type_content; location=loc; type_meta = ()} - let tuple_to_record lst = let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in let (_, lst ) = List.fold_left aux (0,[]) lst in @@ -81,12 +68,12 @@ let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signatur let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s) let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s) let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s) -let e'_bytes b : expression_content result = - let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in - ok @@ E_literal (Literal_bytes bytes) -let e_bytes_hex ?loc b : expression result = - let%bind e' = e'_bytes b in - ok @@ make_e ?loc e' +let e'_bytes b : expression_content = + let bytes = Hex.to_bytes (`Hex b) in + E_literal (Literal_bytes bytes) +let e_bytes_hex ?loc b : expression = + let e' = e'_bytes b in + make_e ?loc e' let e_bytes_raw ?loc (b: bytes) : expression = make_e ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = @@ -128,12 +115,13 @@ let e_typed_none ?loc t_opt = let get_e_record_accessor = fun t -> match t with - | E_record_accessor {record; path} -> ok (record, path) - | _ -> simple_fail "not an accessor" + | E_record_accessor {record; path} -> Some (record, path) + | _ -> None let assert_e_record_accessor = fun t -> - let%bind _ = get_e_record_accessor t in - ok () + match get_e_record_accessor t with + | Some _ -> Some () + | None -> None let get_e_pair = fun t -> match t with @@ -142,58 +130,62 @@ let get_e_pair = fun t -> match lst with | [(Label "O",a);(Label "1",b)] | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> simple_fail "not a pair" + Some (a , b) + | _ -> None ) - | _ -> simple_fail "not a pair" + | _ -> None let get_e_list = fun t -> let rec aux t = match t with E_constant {cons_name=C_CONS;arguments=[key;lst]} -> - let%bind lst = aux lst.expression_content in - ok @@ key::(lst) + let lst = aux lst.expression_content in + (Some key)::(lst) | E_constant {cons_name=C_LIST_EMPTY;arguments=[]} -> - ok @@ [] - | _ -> simple_fail "not a list" + [] + | _ -> [None] in - aux t + let opts = aux t in + if List.exists (Option.is_none) opts then None + else Some (List.map Option.unopt_exn opts) let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r - | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" + | E_record r -> Some (List.map snd @@ Stage_common.Helpers.tuple_of_record r) + | _ -> None let get_e_ascription = fun a -> match a with - | E_ascription {anno_expr; type_annotation} -> ok @@ (anno_expr,type_annotation) - | _ -> simple_fail "ast_core: get_e_ascription: not an ascription" + | E_ascription {anno_expr; type_annotation} -> Some (anno_expr,type_annotation) + | _ -> None (* Same as get_e_pair *) -let extract_pair : expression -> (expression * expression) result = fun e -> +let extract_pair : expression -> (expression * expression) option = fun e -> match e.expression_content with | E_record r -> ( let lst = LMap.to_kv_list r in match lst with | [(Label "O",a);(Label "1",b)] | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> fail @@ bad_kind "pair" e.location + Some (a , b) + | _ -> None ) - | _ -> fail @@ bad_kind "pair" e.location + | _ -> None -let extract_record : expression -> (label * expression) list result = fun e -> +let extract_record : expression -> (label * expression) list option = fun e -> match e.expression_content with - | E_record lst -> ok @@ LMap.to_kv_list lst - | _ -> fail @@ bad_kind "record" e.location + | E_record lst -> Some (LMap.to_kv_list lst) + | _ -> None -let extract_map : expression -> (expression * expression) list result = fun e -> +let extract_map : expression -> (expression * expression) list option = fun e -> let rec aux e = match e.expression_content with E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} -> - let%bind map = aux map in - ok @@ (k,v)::map - | E_constant {cons_name=C_MAP_EMPTY|C_BIG_MAP_EMPTY; arguments=[]} -> ok @@ [] - | _ -> fail @@ bad_kind "map" e.location + let map = aux map in + (Some (k,v))::map + | E_constant {cons_name=C_MAP_EMPTY|C_BIG_MAP_EMPTY; arguments=[]} -> [] + | _ -> [None] in - aux e + let opts = aux e in + if List.exists (Option.is_none) opts then None + else Some (List.map Option.unopt_exn opts) diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index 2eae3795b..63a5da2a8 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -1,14 +1,5 @@ open Types -open Simple_utils.Trace -(* -module Option = Simple_utils.Option -module SMap = Map.String - -module Errors : sig - val bad_kind : name -> Location.t -> unit -> error -end -*) val make_t : ?loc:Location.t -> type_content -> type_expression val t_bool : ?loc:Location.t -> unit -> type_expression val t_string : ?loc:Location.t -> unit -> type_expression @@ -63,8 +54,8 @@ val e_key : ?loc:Location.t -> string -> expression val e_key_hash : ?loc:Location.t -> string -> expression val e_chain_id : ?loc:Location.t -> string -> expression val e_mutez : ?loc:Location.t -> Z.t -> expression -val e'_bytes : string -> expression_content result -val e_bytes_hex : ?loc:Location.t -> string -> expression result +val e'_bytes : string -> expression_content +val e_bytes_hex : ?loc:Location.t -> string -> expression val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_string : ?loc:Location.t -> string -> expression @@ -91,23 +82,13 @@ val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> l val e_record : ?loc:Location.t -> expr label_map-> expression val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression -(* -val get_e_accessor : expression' -> ( expression * access_path ) result -*) +val assert_e_record_accessor : expression_content -> unit option -val assert_e_record_accessor : expression_content -> unit result +val get_e_pair : expression_content -> (expression * expression) option +val get_e_list : expression_content -> expression list option +val get_e_tuple : expression_content -> expression list option +val get_e_ascription : expression_content -> (expression * type_expression) option -val get_e_pair : expression_content -> ( expression * expression ) result - -val get_e_list : expression_content -> ( expression list ) result -val get_e_tuple : expression_content -> ( expression list ) result -val get_e_ascription : expression_content -> ( expression * type_expression ) result -(* -val get_e_failwith : expression -> expression result -val is_e_failwith : expression -> bool -*) -val extract_pair : expression -> ( expression * expression ) result - -val extract_record : expression -> (label * expression) list result - -val extract_map : expression -> (expression * expression) list result +val extract_pair : expression -> (expression * expression) option +val extract_record : expression -> (label * expression) list option +val extract_map : expression -> (expression * expression) list option diff --git a/src/stages/3-ast_core/formatter.ml b/src/stages/3-ast_core/formatter.ml new file mode 100644 index 000000000..d1d9ec665 --- /dev/null +++ b/src/stages/3-ast_core/formatter.ml @@ -0,0 +1,27 @@ +open Display + +let program_ppformat ~display_format f (p,_) = + match display_format with + | Human_readable | Dev -> PP.program f p + +let program_jsonformat (p,_) : json = + let s = Format.asprintf "%a" PP.program p in + `Assoc [("Core(temp)" , `String s)] + +let program_format : 'a format = { + pp = program_ppformat; + to_json = program_jsonformat; +} + +let expression_ppformat ~display_format f (p,_) = + match display_format with + | Human_readable | Dev -> PP.expression f p + +let expression_jsonformat (p,_) : json = + let core' = Format.asprintf "%a" PP.expression p in + `Assoc [("Core(temp)" , `String core')] + +let expression_format : 'a format = { + pp = expression_ppformat; + to_json = expression_jsonformat; +} \ No newline at end of file diff --git a/src/stages/3-ast_core/misc.ml b/src/stages/3-ast_core/misc.ml index 96705f5d2..ca6519052 100644 --- a/src/stages/3-ast_core/misc.ml +++ b/src/stages/3-ast_core/misc.ml @@ -1,290 +1,101 @@ -open Trace open Types -open Stage_common.Helpers -module Errors = struct - let different_literals_because_different_types name a b () = - let title () = "literals have different types: " ^ name in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let different_literals name a b () = - let title () = name ^ " are different" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let error_uncomparable_literals name a b () = - let title () = name ^ " are not comparable" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () -end -open Errors - -let assert_literal_eq (a, b : literal * literal) : unit result = +let assert_literal_eq (a, b : literal * literal) : unit option = match (a, b) with - | Literal_int a, Literal_int b when a = b -> ok () - | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b - | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b - | Literal_nat a, Literal_nat b when a = b -> ok () - | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b - | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b - | Literal_timestamp a, Literal_timestamp b when a = b -> ok () - | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b - | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_mutez a, Literal_mutez b when a = b -> ok () - | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b - | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b - | Literal_string a, Literal_string b when a = b -> ok () - | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b - | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b - | Literal_bytes a, Literal_bytes b when a = b -> ok () - | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b - | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b - | Literal_void, Literal_void -> ok () - | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b - | Literal_unit, Literal_unit -> ok () - | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b - | Literal_address a, Literal_address b when a = b -> ok () - | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b - | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b - | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b - | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b - | Literal_signature a, Literal_signature b when a = b -> ok () - | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b - | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b - | Literal_key a, Literal_key b when a = b -> ok () - | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b - | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b - | Literal_key_hash a, Literal_key_hash b when a = b -> ok () - | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b - | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b - | Literal_chain_id a, Literal_chain_id b when a = b -> ok () - | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b - | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b + | Literal_int a, Literal_int b when a = b -> Some () + | Literal_int _, Literal_int _ -> None + | Literal_int _, _ -> None + | Literal_nat a, Literal_nat b when a = b -> Some () + | Literal_nat _, Literal_nat _ -> None + | Literal_nat _, _ -> None + | Literal_timestamp a, Literal_timestamp b when a = b -> Some () + | Literal_timestamp _, Literal_timestamp _ -> None + | Literal_timestamp _, _ -> None + | Literal_mutez a, Literal_mutez b when a = b -> Some () + | Literal_mutez _, Literal_mutez _ -> None + | Literal_mutez _, _ -> None + | Literal_string a, Literal_string b when a = b -> Some () + | Literal_string _, Literal_string _ -> None + | Literal_string _, _ -> None + | Literal_bytes a, Literal_bytes b when a = b -> Some () + | Literal_bytes _, Literal_bytes _ -> None + | Literal_bytes _, _ -> None + | Literal_void, Literal_void -> Some () + | Literal_void, _ -> None + | Literal_unit, Literal_unit -> Some () + | Literal_unit, _ -> None + | Literal_address a, Literal_address b when a = b -> Some () + | Literal_address _, Literal_address _ -> None + | Literal_address _, _ -> None + | Literal_operation _, Literal_operation _ -> None + | Literal_operation _, _ -> None + | Literal_signature a, Literal_signature b when a = b -> Some () + | Literal_signature _, Literal_signature _ -> None + | Literal_signature _, _ -> None + | Literal_key a, Literal_key b when a = b -> Some () + | Literal_key _, Literal_key _ -> None + | Literal_key _, _ -> None + | Literal_key_hash a, Literal_key_hash b when a = b -> Some () + | Literal_key_hash _, Literal_key_hash _ -> None + | Literal_key_hash _, _ -> None + | Literal_chain_id a, Literal_chain_id b when a = b -> Some () + | Literal_chain_id _, Literal_chain_id _ -> None + | Literal_chain_id _, _ -> None -let rec assert_value_eq (a, b: (expression * expression )) : unit result = - Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b; - let error_content () = - Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b - in - trace (fun () -> error (thunk "not equal") error_content ()) @@ +let rec assert_value_eq (a, b: (expression * expression )) : unit option = match (a.expression_content , b.expression_content) with | E_literal a , E_literal b -> - assert_literal_eq (a, b) - | E_literal _ , _ -> - simple_fail "comparing a literal with not a literal" + assert_literal_eq (a, b) | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> ( - let%bind lst = - generic_try (simple_error "constants with different number of elements") - (fun () -> List.combine ca.arguments cb.arguments) in - let%bind _all = bind_list @@ List.map assert_value_eq lst in - ok () + let lst = List.combine ca.arguments cb.arguments in + let all = List.map assert_value_eq lst in + if List.exists (Option.is_none) all then None else Some () ) - | E_constant _ , E_constant _ -> - simple_fail "different constants" - | E_constant _ , _ -> - let error_content () = - Format.asprintf "%a vs %a" - PP.expression a - PP.expression b - in - fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ()) - | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> ( - let%bind _eq = assert_value_eq (ca.element, cb.element) in - ok () + assert_value_eq (ca.element, cb.element) ) - | E_constructor _, E_constructor _ -> - simple_fail "different constructors" - | E_constructor _, _ -> - simple_fail "comparing constructor with other expression" - - | E_record sma, E_record smb -> ( let aux _ a b = match a, b with - | Some a, Some b -> Some (assert_value_eq (a, b)) - | _ -> Some (simple_fail "different record keys") + | Some a, Some b -> assert_value_eq (a, b) + | _ -> None in - let%bind _all = bind_lmap @@ LMap.merge aux sma smb in - ok () + let all = LMap.merge aux sma smb in + if ((LMap.cardinal all) = (LMap.cardinal sma)) + || ((LMap.cardinal all) = (LMap.cardinal smb)) then + Some () + else None ) - | E_record _, _ -> - simple_fail "comparing record with other expression" - - | E_record_update ura, E_record_update urb -> - let _ = - generic_try (simple_error "Updating different record") @@ - fun () -> assert_value_eq (ura.record, urb.record) in - let aux (Label a,Label b) = - assert (String.equal a b) - in - let () = aux (ura.path, urb.path) in - let%bind () = assert_value_eq (ura.update,urb.update) in - ok () - | E_record_update _, _ -> - simple_fail "comparing record update with other expression" + | E_record_update ura, E_record_update urb -> ( + match assert_value_eq (ura.record, urb.record) with + | None -> None + | Some () -> + let aux (Label a,Label b) = + assert (String.equal a b) + in + let () = aux (ura.path, urb.path) in + assert_value_eq (ura.update,urb.update) + ) + | E_record_update _, _ -> None | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b) | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) + | (E_variable _, _) | (E_lambda _, _) | (E_application _, _) | (E_let_in _, _) | (E_raw_code _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_matching _, _) - -> simple_fail "comparing not a value" + -> None -let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) + | E_literal _ , _ + | E_constant _ , E_constant _ + | E_constant _ , _ + | E_constructor _, E_constructor _ + | E_record _, _ + | E_constructor _, _ -> + None -(* module Rename = struct - * open Trace - * - * module Type = struct - * (\* Type renaming, not needed. Yet. *\) - * end - * - * module Value = struct - * type renaming = string * (string * access_path) (\* src -> dst *\) - * type renamings = renaming list - * let filter (r:renamings) (s:string) : renamings = - * List.filter (fun (x, _) -> not (x = s)) r - * let filters (r:renamings) (ss:string list) : renamings = - * List.filter (fun (x, _) -> not (List.mem x ss)) r - * - * let rec rename_instruction (r:renamings) (i:instruction) : instruction result = - * match i with - * | I_assignment ({name;annotated_expression = e} as a) -> ( - * match List.assoc_opt name r with - * | None -> - * let%bind annotated_expression = rename_annotated_expression (filter r name) e in - * ok (I_assignment {a with annotated_expression}) - * | Some (name', lst) -> ( - * let%bind annotated_expression = rename_annotated_expression r e in - * match lst with - * | [] -> ok (I_assignment {name = name' ; annotated_expression}) - * | lst -> - * let (hds, tl) = - * let open List in - * let r = rev lst in - * rev @@ tl r, hd r - * in - * let%bind tl' = match tl with - * | Access_record n -> ok n - * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in - * ok (I_record_patch (name', hds, [tl', annotated_expression])) - * ) - * ) - * | I_skip -> ok I_skip - * | I_fail e -> - * let%bind e' = rename_annotated_expression r e in - * ok (I_fail e') - * | I_loop (cond, body) -> - * let%bind cond' = rename_annotated_expression r cond in - * let%bind body' = rename_block r body in - * ok (I_loop (cond', body')) - * | I_matching (ae, m) -> - * let%bind ae' = rename_annotated_expression r ae in - * let%bind m' = rename_matching rename_block r m in - * ok (I_matching (ae', m')) - * | I_record_patch (v, path, lst) -> - * let aux (x, y) = - * let%bind y' = rename_annotated_expression (filter r v) y in - * ok (x, y') in - * let%bind lst' = bind_map_list aux lst in - * match List.assoc_opt v r with - * | None -> ( - * ok (I_record_patch (v, path, lst')) - * ) - * | Some (v', path') -> ( - * ok (I_record_patch (v', path' @ path, lst')) - * ) - * and rename_block (r:renamings) (bl:block) : block result = - * bind_map_list (rename_instruction r) bl - * - * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = - * fun f r m -> - * match m with - * | Match_bool { match_true = mt ; match_false = mf } -> - * let%bind match_true = f r mt in - * let%bind match_false = f r mf in - * ok (Match_bool {match_true ; match_false}) - * | Match_option { match_none = mn ; match_some = (some, ms) } -> - * let%bind match_none = f r mn in - * let%bind ms' = f (filter r some) ms in - * ok (Match_option {match_none ; match_some = (some, ms')}) - * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> - * let%bind match_nil = f r mn in - * let%bind mc' = f (filters r [hd;tl]) mc in - * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) - * | Match_tuple (lst, body) -> - * let%bind body' = f (filters r lst) body in - * ok (Match_tuple (lst, body')) - * - * and rename_matching_instruction = fun x -> rename_matching rename_block x - * - * and rename_matching_expr = fun x -> rename_matching rename_expression x - * - * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = - * let%bind expression = rename_expression r ae.expression in - * ok {ae with expression} - * - * and rename_expression : renamings -> expression -> expression result = fun r e -> - * match e with - * | E_literal _ as l -> ok l - * | E_constant (name, lst) -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_constant (name, lst')) - * | E_constructor (name, ae) -> - * let%bind ae' = rename_annotated_expression r ae in - * ok (E_constructor (name, ae')) - * | E_variable v -> ( - * match List.assoc_opt v r with - * | None -> ok (E_variable v) - * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) - * ) - * | E_lambda ({binder;body;result} as l) -> - * let r' = filter r binder in - * let%bind body = rename_block r' body in - * let%bind result = rename_annotated_expression r' result in - * ok (E_lambda {l with body ; result}) - * | E_application (f, arg) -> - * let%bind f' = rename_annotated_expression r f in - * let%bind arg' = rename_annotated_expression r arg in - * ok (E_application (f', arg')) - * | E_tuple lst -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_tuple lst') - * | E_accessor (ae, p) -> - * let%bind ae' = rename_annotated_expression r ae in - * ok (E_accessor (ae', p)) - * | E_record sm -> - * let%bind sm' = bind_smap - * @@ SMap.map (rename_annotated_expression r) sm in - * ok (E_record sm') - * | E_map m -> - * let%bind m' = bind_map_list - * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in - * ok (E_map m') - * | E_list lst -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_list lst') - * | E_look_up m -> - * let%bind m' = bind_map_pair (rename_annotated_expression r) m in - * ok (E_look_up m') - * | E_matching (ae, m) -> - * let%bind ae' = rename_annotated_expression r ae in - * let%bind m' = rename_matching rename_annotated_expression r m in - * ok (E_matching (ae', m')) - * end - * end *) +let is_value_eq (a , b) = + match assert_value_eq (a , b) with + | Some () -> true + | None -> false diff --git a/src/stages/3-ast_core/misc.mli b/src/stages/3-ast_core/misc.mli index 0784d109c..37fb780c7 100644 --- a/src/stages/3-ast_core/misc.mli +++ b/src/stages/3-ast_core/misc.mli @@ -1,20 +1,4 @@ -open Trace open Types - -(* - -module Errors : sig - val different_literals_because_different_types : name -> literal -> literal -> unit -> error - - val different_literals : name -> literal -> literal -> unit -> error - - val error_uncomparable_literals : name -> literal -> literal -> unit -> error -end - -val assert_literal_eq : ( literal * literal ) -> unit result -*) - -val assert_value_eq : ( expression * expression ) -> unit result - +val assert_value_eq : ( expression * expression ) -> unit option val is_value_eq : ( expression * expression ) -> bool diff --git a/src/stages/4-ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml index b97117f9c..09134e0fd 100644 --- a/src/stages/4-ast_typed/ast_typed.ml +++ b/src/stages/4-ast_typed/ast_typed.ml @@ -3,6 +3,7 @@ module Environment = Environment module PP = PP module PP_generic = PP_generic module Compare_generic = Compare_generic +module Formatter = Formatter module Combinators = struct include Combinators end diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 6b33a9f3e..bb8a6069b 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -1,28 +1,5 @@ -open Trace open Types -module Errors = struct - let not_a_x_expression expected_expression actual_expression () = - let message () = - Format.asprintf "Expected a %s expression but got a %a expression" - expected_expression - PP.expression actual_expression in - error (thunk "Expected a different expression") message - - let not_a_x_type expected_type actual_type () = - let message () = - Format.asprintf "Expected the type %s but got the type %a" - expected_type - PP.type_expression actual_type in - error (thunk "Expected a different type") message - - let declaration_not_found expected_declaration () = - let message () = - Format.asprintf "Could not find a declaration with the name %s" - expected_declaration in - error (thunk "No declaration with the given name") message -end - let make_t ?(loc = Location.generated) type_content core = {type_content; location=loc; type_meta = core} let make_e ?(location = Location.generated) expression_content type_expression = { expression_content ; @@ -84,71 +61,71 @@ let get_type_expression (x:expression) = x.type_expression let get_type' (x:type_expression) = x.type_content let get_expression (x:expression) = x.expression_content -let get_lambda e : _ result = match e.expression_content with - | E_lambda l -> ok l - | _ -> fail @@ Errors.not_a_x_expression "lambda" e () +let get_lambda e : lambda option = match e.expression_content with + | E_lambda l -> Some l + | _ -> None let get_lambda_with_type e = match (e.expression_content , e.type_expression.type_content) with - | E_lambda l , T_arrow {type1;type2} -> ok (l , (type1,type2)) - | _ -> simple_fail "not a lambda with functional type" + | E_lambda l , T_arrow {type1;type2} -> Some (l , (type1,type2)) + | _ -> None -let get_t_bool (t:type_expression) : unit result = match t.type_content with - | T_variable v when Var.equal v Stage_common.Constant.t_bool -> ok () - | t when (compare t (t_bool ()).type_content) = 0-> ok () - | _ -> fail @@ Errors.not_a_x_type "bool" t () +let get_t_bool (t:type_expression) : unit option = match t.type_content with + | T_variable v when Var.equal v Stage_common.Constant.t_bool -> Some () + | t when (compare t (t_bool ()).type_content) = 0-> Some () + | _ -> None -let get_t_int (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_int) -> ok () - | _ -> fail @@ Errors.not_a_x_type "int" t () +let get_t_int (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_int) -> Some () + | _ -> None -let get_t_nat (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_nat) -> ok () - | _ -> fail @@ Errors.not_a_x_type "nat" t () +let get_t_nat (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_nat) -> Some () + | _ -> None -let get_t_unit (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_unit) -> ok () - | _ -> fail @@ Errors.not_a_x_type "unit" t () +let get_t_unit (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_unit) -> Some () + | _ -> None -let get_t_mutez (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_mutez) -> ok () - | _ -> fail @@ Errors.not_a_x_type "tez" t () +let get_t_mutez (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_mutez) -> Some () + | _ -> None -let get_t_bytes (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_bytes) -> ok () - | _ -> fail @@ Errors.not_a_x_type "bytes" t () +let get_t_bytes (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_bytes) -> Some () + | _ -> None -let get_t_string (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_string) -> ok () - | _ -> fail @@ Errors.not_a_x_type "string" t () +let get_t_string (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_string) -> Some () + | _ -> None -let get_t_contract (t:type_expression) : type_expression result = match t.type_content with - | T_operator (TC_contract x) -> ok x - | _ -> fail @@ Errors.not_a_x_type "contract" t () +let get_t_contract (t:type_expression) : type_expression option = match t.type_content with + | T_operator (TC_contract x) -> Some x + | _ -> None -let get_t_option (t:type_expression) : type_expression result = match t.type_content with - | T_operator (TC_option o) -> ok o - | _ -> fail @@ Errors.not_a_x_type "option" t () +let get_t_option (t:type_expression) : type_expression option = match t.type_content with + | T_operator (TC_option o) -> Some o + | _ -> None -let get_t_list (t:type_expression) : type_expression result = match t.type_content with - | T_operator (TC_list l) -> ok l - | _ -> fail @@ Errors.not_a_x_type "list" t () +let get_t_list (t:type_expression) : type_expression option = match t.type_content with + | T_operator (TC_list l) -> Some l + | _ -> None -let get_t_set (t:type_expression) : type_expression result = match t.type_content with - | T_operator (TC_set s) -> ok s - | _ -> fail @@ Errors.not_a_x_type "set" t () +let get_t_set (t:type_expression) : type_expression option = match t.type_content with + | T_operator (TC_set s) -> Some s + | _ -> None -let get_t_key (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_key) -> ok () - | _ -> fail @@ Errors.not_a_x_type "key" t () +let get_t_key (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_key) -> Some () + | _ -> None -let get_t_signature (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_signature) -> ok () - | _ -> fail @@ Errors.not_a_x_type "signature" t () +let get_t_signature (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_signature) -> Some () + | _ -> None -let get_t_key_hash (t:type_expression) : unit result = match t.type_content with - | T_constant (TC_key_hash) -> ok () - | _ -> fail @@ Errors.not_a_x_type "key_hash" t () +let get_t_key_hash (t:type_expression) : unit option = match t.type_content with + | T_constant (TC_key_hash) -> Some () + | _ -> None let tuple_of_record (m: _ LMap.t) = let aux i = @@ -159,145 +136,111 @@ let tuple_of_record (m: _ LMap.t) = List.map (fun {field_type;_} -> field_type) l -let get_t_tuple (t:type_expression) : type_expression list result = match t.type_content with - | T_record lst -> ok @@ tuple_of_record lst - | _ -> fail @@ Errors.not_a_x_type "tuple" t () +let get_t_tuple (t:type_expression) : type_expression list option = match t.type_content with + | T_record lst -> Some (tuple_of_record lst) + | _ -> None -let get_t_pair (t:type_expression) : (type_expression * type_expression) result = match t.type_content with +let get_t_pair (t:type_expression) : (type_expression * type_expression) option = match t.type_content with | T_record m -> let lst = tuple_of_record m in - let%bind () = - trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@ - Assert.assert_list_size lst 2 in - ok List.(nth lst 0 , nth lst 1) - | _ -> fail @@ Errors.not_a_x_type "pair (tuple with two elements)" t () + ( match List.(length lst = 2) with + | true -> Some (List.(nth lst 0 , nth lst 1)) + | false -> None + ) + | _ -> None -let get_t_function_opt (t:type_expression) : (type_expression * type_expression) option = match t.type_content with +let get_t_function (t:type_expression) : (type_expression * type_expression) option = match t.type_content with | T_arrow {type1;type2} -> Some (type1,type2) | _ -> None -let get_t_function t = - trace_option (Errors.not_a_x_type "function" t ()) @@ - get_t_function_opt t - -let get_t_function_exn t = match get_t_function_opt t with +let get_t_function_exn t = match get_t_function t with | Some x -> x | None -> raise (Failure ("Internal error: broken invariant at " ^ __LOC__)) -let get_t_function_full (t:type_expression) : (type_expression * type_expression) result = - let%bind _ = get_t_function t in - let rec aux n t = match t.type_content with - | T_arrow {type1;type2} -> - let (l, o) = aux (n+1) type2 in - ((Label (string_of_int n),type1)::l,o) - | _ -> ([],t) - in - let (input,output) = aux 0 t in - let input = List.map (fun (l,t) -> (l,{field_type = t ; michelson_annotation = None ; field_decl_pos = 0})) input in - ok @@ (t_record (LMap.of_list input) (),output) - -let get_t_sum_opt (t:type_expression) : ctor_content constructor_map option = match t.type_content with +let get_t_sum (t:type_expression) : ctor_content constructor_map option = match t.type_content with | T_sum m -> Some m | _ -> None -let get_t_sum t = match get_t_sum_opt t with - | Some m -> ok m - | None -> fail @@ Errors.not_a_x_type "sum" t () +let get_t_sum_exn (t:type_expression) : ctor_content constructor_map = match t.type_content with + | T_sum m -> m + | _ -> raise (Failure ("Internal error: broken invariant at " ^ __LOC__)) -let get_t_sum_exn t = match get_t_sum_opt t with - | Some m -> m - | None -> raise (Failure ("Internal error: broken invariant at " ^ __LOC__)) +let get_t_record (t:type_expression) : field_content label_map option = match t.type_content with + | T_record m -> Some m + | _ -> None -let get_t_record (t:type_expression) : field_content label_map result = match t.type_content with - | T_record m -> ok m - | _ -> fail @@ Errors.not_a_x_type "record" t () - -let get_t_map (t:type_expression) : (type_expression * type_expression) result = +let get_t_map (t:type_expression) : (type_expression * type_expression) option = match t.type_content with - | T_operator (TC_map { k ; v }) -> ok (k, v) - | T_operator (TC_map_or_big_map { k ; v }) -> ok (k, v) - | _ -> fail @@ Errors.not_a_x_type "map" t () + | T_operator (TC_map { k ; v }) -> Some (k, v) + | T_operator (TC_map_or_big_map { k ; v }) -> Some (k, v) + | _ -> None -let get_t_big_map (t:type_expression) : (type_expression * type_expression) result = +let get_t_big_map (t:type_expression) : (type_expression * type_expression) option = match t.type_content with - | T_operator (TC_big_map { k ; v }) -> ok (k, v) - | T_operator (TC_map_or_big_map { k ; v }) -> ok (k, v) - | _ -> fail @@ Errors.not_a_x_type "big_map" t () + | T_operator (TC_big_map { k ; v }) -> Some (k, v) + | T_operator (TC_map_or_big_map { k ; v }) -> Some (k, v) + | _ -> None -let get_t_map_key : type_expression -> type_expression result = fun t -> - let%bind (key , _) = get_t_map t in - ok key +let get_t_map_key : type_expression -> type_expression option = fun t -> + match get_t_map t with + | Some (key,_) -> Some key + | None -> None -let get_t_map_value : type_expression -> type_expression result = fun t -> - let%bind (_ , value) = get_t_map t in - ok value +let get_t_map_value : type_expression -> type_expression option = fun t -> + match get_t_map t with + | Some (_,value) -> Some value + | None -> None -let get_t_big_map_key : type_expression -> type_expression result = fun t -> - let%bind (key , _) = get_t_big_map t in - ok key +let get_t_big_map_key : type_expression -> type_expression option = fun t -> + match get_t_big_map t with + | Some (key,_) -> Some key + | None -> None -let get_t_big_map_value : type_expression -> type_expression result = fun t -> - let%bind (_ , value) = get_t_big_map t in - ok value +let get_t_big_map_value : type_expression -> type_expression option = fun t -> + match get_t_big_map t with + | Some (_,value) -> Some value + | None -> None -let assert_t_map = fun t -> - let%bind _ = get_t_map t in - ok () +let is_t_map t = Option.is_some (get_t_map t) +let is_t_big_map t = Option.is_some (get_t_big_map t) -let is_t_map = Function.compose to_bool get_t_map -let is_t_big_map = Function.compose to_bool get_t_big_map - -let assert_t_mutez : type_expression -> unit result = get_t_mutez +let assert_t_mutez : type_expression -> unit option = get_t_mutez let assert_t_key = get_t_key let assert_t_signature = get_t_signature let assert_t_key_hash = get_t_key_hash +let assert_t_bytes = get_t_bytes +let assert_t_string = get_t_string -let assert_t_contract (t:type_expression) : unit result = match t.type_content with - | T_operator (TC_contract _) -> ok () - | _ -> simple_fail "not a contract" +let assert_t_contract (t:type_expression) : unit option = match t.type_content with + | T_operator (TC_contract _) -> Some () + | _ -> None -let assert_t_list t = - let%bind _ = get_t_list t in - ok () +let is_t_list t = Option.is_some (get_t_list t) +let is_t_set t = Option.is_some (get_t_set t) +let is_t_nat t = Option.is_some (get_t_nat t) +let is_t_string t = Option.is_some (get_t_string t) +let is_t_bytes t = Option.is_some (get_t_bytes t) +let is_t_int t = Option.is_some (get_t_int t) -let assert_t_record t = - let%bind _ = get_t_record t in - ok () +let assert_t_list_operation (t : type_expression) : unit option = + match get_t_list t with + | Some t' -> ( + match t'.type_content with + | T_constant (TC_operation) -> Some () + | _ -> None + ) + | None -> None -let is_t_list = Function.compose to_bool get_t_list -let is_t_set = Function.compose to_bool get_t_set -let is_t_nat = Function.compose to_bool get_t_nat -let is_t_string = Function.compose to_bool get_t_string -let is_t_bytes = Function.compose to_bool get_t_bytes -let is_t_int = Function.compose to_bool get_t_int +let assert_t_int : type_expression -> unit option = fun t -> match t.type_content with + | T_constant (TC_int) -> Some () + | _ -> None -let assert_t_bytes = fun t -> - let%bind _ = get_t_bytes t in - ok () +let assert_t_nat : type_expression -> unit option = fun t -> match t.type_content with + | T_constant (TC_nat) -> Some () + | _ -> None -let assert_t_string = fun t -> - let%bind _ = get_t_string t in - ok () - -let assert_t_operation (t:type_expression) : unit result = - match t.type_content with - | T_constant (TC_operation) -> ok () - | _ -> simple_fail "assert: not an operation" - -let assert_t_list_operation (t : type_expression) : unit result = - let%bind t' = get_t_list t in - assert_t_operation t' - -let assert_t_int : type_expression -> unit result = fun t -> match t.type_content with - | T_constant (TC_int) -> ok () - | _ -> simple_fail "not an int" - -let assert_t_nat : type_expression -> unit result = fun t -> match t.type_content with - | T_constant (TC_nat) -> ok () - | _ -> simple_fail "not an nat" - -let assert_t_bool : type_expression -> unit result = fun v -> get_t_bool v -let assert_t_unit : type_expression -> unit result = fun v -> get_t_unit v +let assert_t_bool : type_expression -> unit option = fun v -> get_t_bool v +let assert_t_unit : type_expression -> unit option = fun v -> get_t_unit v let e_record map : expression_content = E_record map let ez_e_record (lst : (label * expression) list) : expression_content = @@ -357,40 +300,42 @@ let e_a_let_in binder expr body attributes = make_e (e_let_in binder expr body a let get_a_int (t:expression) = match t.expression_content with - | E_literal (Literal_int n) -> ok n - | _ -> simple_fail "not an int" + | E_literal (Literal_int n) -> Some n + | _ -> None let get_a_string (t:expression) = match t.expression_content with - | E_literal (Literal_string s) -> ok @@ Ligo_string.extract s - | _ -> simple_fail "not a string" + | E_literal (Literal_string s) -> Some (Ligo_string.extract s) + | _ -> None let get_a_verbatim (t:expression) = match t.expression_content with - E_literal (Literal_string (Verbatim v)) -> ok @@ v - | _ -> simple_fail "not a verbatim string" + E_literal (Literal_string (Verbatim v)) -> Some v + | _ -> None let get_a_unit (t:expression) = match t.expression_content with - | E_literal (Literal_unit) -> ok () - | _ -> simple_fail "not a unit" + | E_literal (Literal_unit) -> Some () + | _ -> None let get_a_bool (t:expression) = match t.expression_content with - | E_constructor {constructor=Constructor name;element} when (String.equal name "true" || String.equal name "false") && element.expression_content = e_unit () -> ok (bool_of_string name) - | _ -> simple_fail "not a bool" + | E_constructor {constructor=Constructor name;element} + when (String.equal name "true" || String.equal name "false") + && element.expression_content = e_unit () -> + Some (bool_of_string name) + | _ -> None let get_a_record_accessor = fun t -> match t.expression_content with - | E_record_accessor {record; path} -> ok (record, path) - | _ -> simple_fail "not an accessor" + | E_record_accessor {record; path} -> Some (record, path) + | _ -> None -let get_declaration_by_name : program -> string -> declaration result = fun p name -> +let get_declaration_by_name : program -> string -> declaration option = fun p name -> let aux : declaration -> bool = fun declaration -> match declaration with | Declaration_constant { binder ; expr=_ ; inline=_ } -> binder = Var.of_name name | Declaration_type _ -> false in - trace_option (Errors.declaration_not_found name ()) @@ List.find_opt aux @@ List.map Location.unwrap p diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index 4033d4e25..7377254b2 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -1,4 +1,3 @@ -open Trace open Types val make_n_t : type_variable -> type_expression -> named_type_content @@ -39,54 +38,35 @@ val t_shallow_closure : type_expression -> type_expression -> ?loc:Location.t -> val get_type_expression : expression -> type_expression val get_type' : type_expression -> type_content val get_expression : expression -> expression_content -val get_lambda : expression -> lambda result -val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result -val get_t_bool : type_expression -> unit result -(* -val get_t_int : type_expression -> unit result -val get_t_nat : type_expression -> unit result -val get_t_unit : type_expression -> unit result -val get_t_mutez : type_expression -> unit result -val get_t_bytes : type_expression -> unit result -val get_t_string : type_expression -> unit result -*) -val get_t_contract : type_expression -> type_expression result -val get_t_option : type_expression -> type_expression result -val get_t_list : type_expression -> type_expression result -val get_t_set : type_expression -> type_expression result -(* -val get_t_key : type_expression -> unit result -val get_t_signature : type_expression -> unit result -val get_t_key_hash : type_expression -> unit result -*) -val get_t_tuple : type_expression -> type_expression list result -val get_t_pair : type_expression -> ( type_expression * type_expression ) result -val get_t_function : type_expression -> ( type_expression * type_expression ) result -val get_t_function_opt : type_expression -> ( type_expression * type_expression ) option -val get_t_function_exn : type_expression -> ( type_expression * type_expression ) -val get_t_function_full : type_expression -> ( type_expression * type_expression ) result -val get_t_sum : type_expression -> ctor_content constructor_map result -val get_t_sum_opt : type_expression -> ctor_content constructor_map option +val get_lambda : expression -> lambda option +val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression)) option +val get_t_bool : type_expression -> unit option +val get_t_contract : type_expression -> type_expression option +val get_t_option : type_expression -> type_expression option +val get_t_list : type_expression -> type_expression option +val get_t_set : type_expression -> type_expression option +val get_t_tuple : type_expression -> type_expression list option +val get_t_pair : type_expression -> (type_expression * type_expression) option +val get_t_function : type_expression -> (type_expression * type_expression) option +val get_t_function_exn : type_expression -> (type_expression * type_expression) +val get_t_sum : type_expression -> ctor_content constructor_map option val get_t_sum_exn : type_expression -> ctor_content constructor_map -val get_t_record : type_expression -> field_content label_map result -val get_t_map : type_expression -> ( type_expression * type_expression ) result -val get_t_big_map : type_expression -> ( type_expression * type_expression ) result -val get_t_map_key : type_expression -> type_expression result -val get_t_map_value : type_expression -> type_expression result -val get_t_big_map_key : type_expression -> type_expression result -val get_t_big_map_value : type_expression -> type_expression result +val get_t_record : type_expression -> field_content label_map option +val get_t_map : type_expression -> (type_expression * type_expression) option +val get_t_big_map : type_expression -> (type_expression * type_expression) option +val get_t_map_key : type_expression -> type_expression option +val get_t_map_value : type_expression -> type_expression option +val get_t_big_map_key : type_expression -> type_expression option +val get_t_big_map_value : type_expression -> type_expression option -val assert_t_map : type_expression -> unit result val is_t_map : type_expression -> bool val is_t_big_map : type_expression -> bool -val assert_t_mutez : type_expression -> unit result -val assert_t_key : type_expression -> unit result -val assert_t_signature : type_expression -> unit result -val assert_t_key_hash : type_expression -> unit result - -val assert_t_list : type_expression -> unit result +val assert_t_mutez : type_expression -> unit option +val assert_t_key : type_expression -> unit option +val assert_t_signature : type_expression -> unit option +val assert_t_key_hash : type_expression -> unit option val is_t_list : type_expression -> bool val is_t_set : type_expression -> bool @@ -95,18 +75,14 @@ val is_t_string : type_expression -> bool val is_t_bytes : type_expression -> bool val is_t_int : type_expression -> bool -val assert_t_bytes : type_expression -> unit result -val assert_t_string : type_expression -> unit result -(* -val assert_t_operation : type_expression -> unit result -*) -val assert_t_list_operation : type_expression -> unit result -val assert_t_int : type_expression -> unit result -val assert_t_nat : type_expression -> unit result -val assert_t_bool : type_expression -> unit result -val assert_t_unit : type_expression -> unit result -val assert_t_contract : type_expression -> unit result -val assert_t_record : type_expression -> unit result +val assert_t_list_operation : type_expression -> unit option +val assert_t_int : type_expression -> unit option +val assert_t_nat : type_expression -> unit option +val assert_t_bool : type_expression -> unit option +val assert_t_unit : type_expression -> unit option +val assert_t_contract : type_expression -> unit option +val assert_t_bytes : type_expression -> unit option +val assert_t_string : type_expression -> unit option (* val e_record : ae_map -> expression val ez_e_record : ( string * expression ) list -> expression @@ -151,10 +127,10 @@ val e_a_variable : expression_variable -> type_expression -> expression val ez_e_a_record : ( label * expression ) list -> expression val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression -val get_a_int : expression -> Z.t result -val get_a_string : expression -> string result -val get_a_verbatim : expression -> string result -val get_a_unit : expression -> unit result -val get_a_bool : expression -> bool result -val get_a_record_accessor : expression -> (expression * label) result -val get_declaration_by_name : program -> string -> declaration result +val get_a_int : expression -> Z.t option +val get_a_string : expression -> string option +val get_a_verbatim : expression -> string option +val get_a_unit : expression -> unit option +val get_a_bool : expression -> bool option +val get_a_record_accessor : expression -> (expression * label) option +val get_declaration_by_name : program -> string -> declaration option diff --git a/src/stages/4-ast_typed/environment.ml b/src/stages/4-ast_typed/environment.ml index 0b9457466..df9706451 100644 --- a/src/stages/4-ast_typed/environment.ml +++ b/src/stages/4-ast_typed/environment.ml @@ -69,10 +69,10 @@ module PP = struct fprintf ppf "%a -> %a" PP.type_variable type_variable PP.type_expression type_ let expr_environment : _ -> expression_environment -> unit = fun ppf lst -> - fprintf ppf "E[%a]" (list_sep environment_element (tag "@,")) lst + fprintf ppf "Env:[%a]" (list_sep environment_element (tag "@,")) lst let type_environment = fun ppf lst -> - fprintf ppf "T[%a]" (list_sep type_environment_element (tag "@,")) lst + fprintf ppf "Type env:[%a]" (list_sep type_environment_element (tag "@,")) lst let environment : _ -> environment -> unit = fun ppf e -> fprintf ppf "- %a\t%a" diff --git a/src/stages/4-ast_typed/formatter.ml b/src/stages/4-ast_typed/formatter.ml new file mode 100644 index 000000000..319342fff --- /dev/null +++ b/src/stages/4-ast_typed/formatter.ml @@ -0,0 +1,14 @@ +open Display + +let program_ppformat ~display_format f (typed,_) = + match display_format with + | Human_readable | Dev -> PP.program f typed + +let program_jsonformat (typed,_) : json = + let core' = Format.asprintf "%a" PP.program typed in + `Assoc [("Typed(temp)" , `String core')] + +let program_format : 'a format = { + pp = program_ppformat; + to_json = program_jsonformat; +} diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml index e7b2c7ac1..82b59ea0a 100644 --- a/src/stages/4-ast_typed/helpers.ml +++ b/src/stages/4-ast_typed/helpers.ml @@ -134,10 +134,9 @@ let is_tuple_lmap m = List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m)) let get_pair m = - let open Trace in match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with - | Some {field_type=e1;_}, Some {field_type=e2;_} -> ok (e1,e2) - | _ -> simple_fail "not a pair" + | Some {field_type=e1;_}, Some {field_type=e2;_} -> Some (e1,e2) + | _ -> None let tuple_of_record (m: _ LMap.t) = let aux i = diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 37ee1a6a8..d899f19b1 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -1,190 +1,4 @@ -open Trace open Types -open Helpers - -module Errors = struct - let different_kinds a b () = - let title = (thunk "different kinds") in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) - ] in - error ~data title message () - - let different_constants a b () = - let title = (thunk "different type constructors") in - let message () = "Expected these two constant type constructors to be the same, but they're different" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.type_constant a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_constant b ) - ] in - error ~data title message () - let different_operators a b () = - let title = (thunk "different type constructors") in - let message () = "Expected these two n-ary type constructors to be the same, but they're different" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) a) ; - ("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) b) - ] in - error ~data title message () - - let different_operator_number_of_arguments opa opb lena lenb () = - let title = (thunk "different number of arguments to type constructors") in - assert (String.equal (type_operator_name opa) (type_operator_name opb)); - let message () = Format.asprintf - "Expected these two n-ary type constructors to be the same, but they have different numbers of arguments (both use the %s type constructor, but they have %d and %d arguments, respectively)" - (type_operator_name opa) lena lenb in - let data = [ - ("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opa) ; - ("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opb) ; - ("op" , fun () -> type_operator_name opa) ; - ("len_a" , fun () -> Format.asprintf "%d" lena) ; - ("len_b" , fun () -> Format.asprintf "%d" lenb) ; - ] in - error ~data title message () - - let different_size_type names a b () = - let title () = names ^ " have different sizes" in - let message () = "Expected these two types to be the same, but they're different (both are " ^ names ^ ", but with a different number of arguments)" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_expression b) - ] in - error ~data title message () - - let different_props_in_record a b ra rb ka kb () = - let names () = if Helpers.is_tuple_lmap ra && Helpers.is_tuple_lmap rb then "tuples" else "records" in - let title () = "different keys in " ^ (names ()) in - let message () = "" in - let data = [ - ("key_a" , fun () -> Format.asprintf "%s" ka) ; - ("key_b" , fun () -> Format.asprintf "%s" kb ) ; - ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) ; - ] in - error ~data title message () - - let different_kind_record_tuple a b ra rb () = - let name_a () = if Helpers.is_tuple_lmap ra then "tuple" else "record" in - let name_b () = if Helpers.is_tuple_lmap rb then "tuple" else "record" in - let title () = "different keys in " ^ (name_a ()) ^ " and " ^ (name_b ()) in - let message () = "Expected these two types to be the same, but they're different (one is a " ^ (name_a ()) ^ " and the other is a " ^ (name_b ()) ^ ")" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) ; - ] in - error ~data title message () - - - let _different_size_constants = different_size_type "type constructors" - - let different_size_sums = different_size_type "sums" - - let different_size_records_tuples a b ra rb = - different_size_type - (if Helpers.is_tuple_lmap ra && Helpers.is_tuple_lmap rb - then "tuples" - else "records") - a b - - let different_types name a b () = - let title () = name ^ " are different" in - let message () = "Expected these two types to be the same, but they're different" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) - ] in - error ~data title message () - - let different_literals name a b () = - let title () = name ^ " are different" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let different_values name a b () = - let title () = name ^ " are different" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.expression b ) - ] in - error ~data title message () - - let different_literals_because_different_types name a b () = - let title () = "literals have different types: " ^ name in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let different_values_because_different_types name a b () = - let title () = "values have different types: " ^ name in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.expression b) - ] in - error ~data title message () - - let error_uncomparable_literals name a b () = - let title () = name ^ " are not comparable" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let error_uncomparable_values name a b () = - let title () = name ^ " are not comparable" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.expression b ) - ] in - error ~data title message () - - let different_size_values name a b () = - let title () = name in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.expression a) ; - ("b" , fun () -> Format.asprintf "%a" PP.expression b ) - ] in - error ~data title message () - - let missing_key_in_record_value k () = - let title () = "missing keys in one of the records" in - let message () = "" in - let data = [ - ("missing_key" , fun () -> Format.asprintf "%s" k) - ] in - error ~data title message () - - let missing_entry_point name = - let title () = "missing entry point" in - let content () = "no entry point with the given name" in - let data = [ - ("name" , fun () -> name) ; - ] in - error ~data title content - - let not_functional_main location = - let title () = "not functional main" in - let content () = "main should be a function" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title content - -end module Free_variables = struct @@ -244,280 +58,172 @@ module Free_variables = struct end -(* module Dependencies = struct - * - * type bindings = string list - * let mem : string -> bindings -> bool = List.mem - * let singleton : string -> bindings = fun s -> [ s ] - * let union : bindings -> bindings -> bindings = (@) - * let unions : bindings list -> bindings = List.concat - * let empty : bindings = [] - * let of_list : string list -> bindings = fun x -> x - * - * let rec expression : bindings -> environment -> expression -> bindings = fun b _env e -> - * let self = annotated_expression b in - * match e with - * | E_lambda l -> - * let b' = union (singleton l.binder) b in - * let (b'', frees) = block' b' l.body in - * union (annotated_expression b'' l.result) frees - * | E_literal _ -> empty - * | E_constant (_ , lst) -> unions @@ List.map self lst - * | E_variable name -> ( - * match mem name b with - * | true -> empty - * | false -> singleton name - * ) - * | E_application (a, b) -> unions @@ List.map self [ a ; b ] - * | E_tuple lst -> unions @@ List.map self lst - * | E_constructor (_ , a) -> self a - * | E_record m -> unions @@ List.map self @@ Map.String.to_list m - * | E_record_accessor (a, _) -> self a - * | E_tuple_accessor (a, _) -> self a - * | E_list lst -> unions @@ List.map self lst - * | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m - * | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] - * | E_matching (a , cs) -> union (self a) (matching_expression b cs) - * | E_failwith a -> self a - * - * and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae -> - * let open Combinators in - * expression b (get_environment ae) (get_expression ae) - * - * and instruction' : bindings -> instruction -> bindings * bindings = fun b i -> - * match i with - * | I_declaration n -> union (singleton n.name) b , (annotated_expression b n.annotated_expression) - * | I_assignment n -> b , (annotated_expression b n.annotated_expression) - * | I_skip -> b , empty - * | I_do e -> b , annotated_expression b e - * | I_loop (a , bl) -> b , union (annotated_expression b a) (block b bl) - * | I_patch (_ , _ , a) -> b , annotated_expression b a - * | I_matching (a , cs) -> b , union (annotated_expression b a) (matching_block b cs) - * - * and block' : bindings -> block -> (bindings * bindings) = fun b bl -> - * let aux = fun (binds, frees) cur -> - * let (binds', frees') = instruction' binds cur in - * (binds', union frees frees') in - * List.fold_left aux (b , []) bl - * - * and block : bindings -> block -> bindings = fun b bl -> - * let (_ , frees) = block' b bl in - * frees - * - * and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor_name * name) * a) -> bindings = fun f b ((_,n),c) -> - * f (union (singleton n) b) c - * - * and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m -> - * match m with - * | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) - * | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c) - * | Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s) - * | Match_tuple (lst , a) -> f (union (of_list lst) b) a - * | Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst - * - * and matching_expression = fun x -> matching annotated_expression x - * - * and matching_block = fun x -> matching block x - * - * end *) +let assert_eq = fun a b -> if (a = b) then Some () else None +let assert_same_size = fun a b -> if (List.length a = List.length b) then Some () else None - -open Errors - - -let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : unit result = match (a.type_content, b.type_content) with - | T_constant ca, T_constant cb -> ( - trace_strong (different_constants ca cb) - @@ Assert.assert_true (ca = cb) - ) - | T_constant _, _ -> fail @@ different_kinds a b +let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : unit option = + let open Option in + match (a.type_content, b.type_content) with + | T_constant ca, T_constant cb -> assert_eq ca cb + | T_constant _, _ -> None | T_operator opa, T_operator opb -> ( - let%bind (lsta, lstb) = match (opa, opb) with + let aux = fun lsta lstb -> + if List.length lsta <> List.length lstb then None + else + List.fold_left + (fun acc (a,b) -> + match acc with | None -> None | Some () -> assert_type_expression_eq (a,b)) + (Some ()) + (List.combine lsta lstb) in + match (opa, opb) with | TC_option la, TC_option lb | TC_list la, TC_list lb | TC_contract la, TC_contract lb - | TC_set la, TC_set lb -> ok @@ ([la], [lb]) + | TC_set la, TC_set lb -> aux [la] [lb] | (TC_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb}) - | (TC_big_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_big_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb}) - -> ok @@ ([ka;va] ,[kb;vb]) + | (TC_big_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_big_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb}) -> + aux [ka;va] [kb;vb] | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ ), (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ ) - -> fail @@ different_operators opa opb - in - if List.length lsta <> List.length lstb then - fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) - else - trace (different_types "arguments to type operators" a b) - @@ bind_list_iter (fun (a,b) -> assert_type_expression_eq (a,b) )(List.combine lsta lstb) + -> None ) - | T_operator _, _ -> fail @@ different_kinds a b + | T_operator _, _ -> None | T_sum sa, T_sum sb -> ( let sa' = CMap.to_kv_list sa in let sb' = CMap.to_kv_list sb in let aux ((ka, {ctor_type=va;_}), (kb, {ctor_type=vb;_})) = - let%bind _ = - Assert.assert_true ~msg:"different keys in sum types" - @@ (ka = kb) in - assert_type_expression_eq (va, vb) + assert_eq ka kb >>= fun _ -> + assert_type_expression_eq (va, vb) in - let%bind _ = - trace_strong (different_size_sums a b) - @@ Assert.assert_list_same_size sa' sb' in - trace (different_types "sum type" a b) @@ - bind_list_iter aux (List.combine sa' sb') + assert_same_size sa' sb' >>= fun _ -> + List.fold_left (fun acc p -> match acc with | None -> None | Some () -> aux p) (Some ()) (List.combine sa' sb') ) - | T_sum _, _ -> fail @@ different_kinds a b + | T_sum _, _ -> None | T_record ra, T_record rb - when Helpers.is_tuple_lmap ra <> Helpers.is_tuple_lmap rb -> ( - fail @@ different_kind_record_tuple a b ra rb - ) + when Helpers.is_tuple_lmap ra <> Helpers.is_tuple_lmap rb -> None | T_record ra, T_record rb -> ( let sort_lmap r' = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) r' in let ra' = sort_lmap @@ LMap.to_kv_list ra in let rb' = sort_lmap @@ LMap.to_kv_list rb in let aux ((ka, {field_type=va;_}), (kb, {field_type=vb;_})) = - let%bind _ = - trace (different_types "records" a b) @@ - let Label ka = ka in - let Label kb = kb in - trace_strong (different_props_in_record a b ra rb ka kb) @@ - Assert.assert_true (ka = kb) in + let Label ka = ka in + let Label kb = kb in + assert_eq ka kb >>= fun _ -> assert_type_expression_eq (va, vb) in - let%bind _ = - trace_strong (different_size_records_tuples a b ra rb) - @@ Assert.assert_list_same_size ra' rb' in - trace (different_types "record type" a b) - @@ bind_list_iter aux (List.combine ra' rb') + assert_same_size ra' rb' >>= fun _ -> + List.fold_left (fun acc p -> match acc with | None -> None | Some () -> aux p) (Some ()) (List.combine ra' rb') ) - | T_record _, _ -> fail @@ different_kinds a b + | T_record _, _ -> None | T_arrow {type1;type2}, T_arrow {type1=type1';type2=type2'} -> - let%bind _ = assert_type_expression_eq (type1, type1') in - let%bind _ = assert_type_expression_eq (type2, type2') in - ok () - | T_arrow _, _ -> fail @@ different_kinds a b + assert_type_expression_eq (type1, type1') >>= fun _ -> + assert_type_expression_eq (type2, type2') + | T_arrow _, _ -> None | T_variable x, T_variable y -> let _ = (x = y) in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding" - | T_variable _, _ -> fail @@ different_kinds a b + | T_variable _, _ -> None -(* No information about what made it fail *) -let type_expression_eq ab = Trace.to_bool @@ assert_type_expression_eq ab +let type_expression_eq ab = Option.is_some @@ assert_type_expression_eq ab -let assert_literal_eq (a, b : literal * literal) : unit result = +let assert_literal_eq (a, b : literal * literal) : unit option = match (a, b) with - | Literal_int a, Literal_int b when a = b -> ok () - | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b - | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b - | Literal_nat a, Literal_nat b when a = b -> ok () - | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b - | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b - | Literal_timestamp a, Literal_timestamp b when a = b -> ok () - | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b - | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_mutez a, Literal_mutez b when a = b -> ok () - | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b - | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b - | Literal_string a, Literal_string b when a = b -> ok () - | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b - | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b - | Literal_bytes a, Literal_bytes b when a = b -> ok () - | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytes" a b - | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b - | Literal_void, Literal_void -> ok () - | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b - | Literal_unit, Literal_unit -> ok () - | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b - | Literal_address a, Literal_address b when a = b -> ok () - | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b - | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b - | Literal_signature a, Literal_signature b when a = b -> ok () - | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b - | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b - | Literal_key a, Literal_key b when a = b -> ok () - | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b - | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b - | Literal_key_hash a, Literal_key_hash b when a = b -> ok () - | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b - | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b - | Literal_chain_id a, Literal_chain_id b when a = b -> ok () - | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b - | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b - | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b - | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b + | Literal_int a, Literal_int b when a = b -> Some () + | Literal_int _, Literal_int _ -> None + | Literal_int _, _ -> None + | Literal_nat a, Literal_nat b when a = b -> Some () + | Literal_nat _, Literal_nat _ -> None + | Literal_nat _, _ -> None + | Literal_timestamp a, Literal_timestamp b when a = b -> Some () + | Literal_timestamp _, Literal_timestamp _ -> None + | Literal_timestamp _, _ -> None + | Literal_mutez a, Literal_mutez b when a = b -> Some () + | Literal_mutez _, Literal_mutez _ -> None + | Literal_mutez _, _ -> None + | Literal_string a, Literal_string b when a = b -> Some () + | Literal_string _, Literal_string _ -> None + | Literal_string _, _ -> None + | Literal_bytes a, Literal_bytes b when a = b -> Some () + | Literal_bytes _, Literal_bytes _ -> None + | Literal_bytes _, _ -> None + | Literal_void, Literal_void -> Some () + | Literal_void, _ -> None + | Literal_unit, Literal_unit -> Some () + | Literal_unit, _ -> None + | Literal_address a, Literal_address b when a = b -> Some () + | Literal_address _, Literal_address _ -> None + | Literal_address _, _ -> None + | Literal_signature a, Literal_signature b when a = b -> Some () + | Literal_signature _, Literal_signature _ -> None + | Literal_signature _, _ -> None + | Literal_key a, Literal_key b when a = b -> Some () + | Literal_key _, Literal_key _ -> None + | Literal_key _, _ -> None + | Literal_key_hash a, Literal_key_hash b when a = b -> Some () + | Literal_key_hash _, Literal_key_hash _ -> None + | Literal_key_hash _, _ -> None + | Literal_chain_id a, Literal_chain_id b when a = b -> Some () + | Literal_chain_id _, Literal_chain_id _ -> None + | Literal_chain_id _, _ -> None + | Literal_operation _, Literal_operation _ -> None + | Literal_operation _, _ -> None -let rec assert_value_eq (a, b: (expression*expression)) : unit result = - let error_content () = - Format.asprintf "\n%a vs %a" PP.expression a PP.expression b - in - trace (fun () -> error (thunk "not equal") error_content ()) @@ +let rec assert_value_eq (a, b: (expression*expression)) : unit option = + let open Option in match (a.expression_content, b.expression_content) with | E_literal a, E_literal b -> assert_literal_eq (a, b) | E_constant {cons_name=ca;arguments=lsta}, E_constant {cons_name=cb;arguments=lstb} when ca = cb -> ( - let%bind lst = - generic_try (different_size_values "constants with different number of elements" a b) - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_list @@ List.map assert_value_eq lst in - ok () - ) - | E_constant _, E_constant _ -> - fail @@ different_values "constants" a b - | E_constant _, _ -> - let error_content () = - Format.asprintf "%a vs %a" - PP.expression a - PP.expression b - in - fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ()) - + assert_same_size lsta lstb >>= fun _ -> + List.fold_left (fun acc p -> match acc with | None -> None | Some () -> assert_value_eq p) (Some ()) (List.combine lsta lstb) + ) + | E_constant _, E_constant _ -> None + | E_constant _, _ -> None | E_constructor {constructor=ca;element=a}, E_constructor {constructor=cb;element=b} when ca = cb -> ( - let%bind _eq = assert_value_eq (a, b) in - ok () - ) - | E_constructor _, E_constructor _ -> - fail @@ different_values "constructors" a b - | E_constructor _, _ -> - fail @@ different_values_because_different_types "constructor vs. non-constructor" a b + assert_value_eq (a, b) + ) + | E_constructor _, E_constructor _ -> None + | E_constructor _, _ -> None | E_record sma, E_record smb -> ( - let aux (Label k) a b = + let aux (Label _k) a b = match a, b with - | Some a, Some b -> Some (assert_value_eq (a, b)) - | _ -> Some (fail @@ missing_key_in_record_value k) + | Some a, Some b -> assert_value_eq (a, b) + | _ -> None in - let%bind _all = Helpers.bind_lmap @@ LMap.merge aux sma smb in - ok () + let all = LMap.merge aux sma smb in + if ((LMap.cardinal all) = (LMap.cardinal sma)) + || ((LMap.cardinal all) = (LMap.cardinal smb)) then + Some () + else None ) - | E_record _, _ -> - fail @@ (different_values_because_different_types "record vs. non-record" a b) - + | E_record _, _ | (E_literal _, _) | (E_variable _, _) | (E_application _, _) | (E_lambda _, _) | (E_let_in _, _) | (E_raw_code _, _) | (E_recursive _, _) | (E_record_accessor _, _) | (E_record_update _,_) | (E_matching _, _) - -> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b + -> None -let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result = +let merge_annotation (a:type_expression option) (b:type_expression option) assert_eq_fun : type_expression option = + let open Option in match a, b with - | None, None -> fail @@ err - | Some a, None -> ok a - | None, Some b -> ok b + | None, None -> None + | Some a, None -> Some a + | None, Some b -> Some b | Some a, Some b -> - let%bind _ = assert_type_expression_eq (a, b) in + assert_eq_fun (a, b) >>= fun _ -> match a.type_meta, b.type_meta with - | _, None -> ok a - | _, Some _ -> ok b + | _, None -> Some a + | _, Some _ -> Some b -let get_entry (lst : program) (name : string) : expression result = - trace_option (Errors.missing_entry_point name) @@ - let aux x = - match Location.unwrap x with - | Declaration_constant { binder ; expr ; inline=_ } -> ( - if Var.equal binder (Var.of_name name) - then Some expr - else None - ) - | Declaration_type _ -> None +let get_entry (lst : program) (name : string) : expression option = + let aux x = + match Location.unwrap x with + | Declaration_constant { binder ; expr ; inline=_ } -> ( + if Var.equal binder (Var.of_name name) + then Some expr + else None + ) + | Declaration_type _ -> None in List.find_map aux lst diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli index 71bb8a291..dc254e788 100644 --- a/src/stages/4-ast_typed/misc.mli +++ b/src/stages/4-ast_typed/misc.mli @@ -1,13 +1,11 @@ -open Trace open Types -val assert_value_eq : ( expression * expression ) -> unit result - -val assert_type_expression_eq : ( type_expression * type_expression ) -> unit result - -val merge_annotation : type_expression option -> type_expression option -> error_thunk -> type_expression result - -(* No information about what made it fail *) +val assert_value_eq : ( expression * expression ) -> unit option +val assert_type_expression_eq : ( type_expression * type_expression ) -> unit option +val merge_annotation : + type_expression option -> + type_expression option -> + (type_expression * type_expression -> 'a option) -> type_expression option val type_expression_eq : ( type_expression * type_expression ) -> bool val equal_variables : expression -> expression -> bool @@ -22,54 +20,13 @@ module Free_variables : sig val empty : bindings val singleton : expression_variable -> bindings - -(* - val mem : string -> bindings -> bool - val union : bindings -> bindings -> bindings - val unions : bindings list -> bindings - val of_list : string list -> bindings - - val expression : bindings -> expression -> bindings - - val matching_variant_case : (bindings -> 'a -> bindings) -> bindings -> ((constructor_name * name) * 'a) -> bindings - - val matching : (bindings -> 'a -> bindings) -> bindings -> 'a matching -> bindings - - *) end -module Errors : sig - (* - val different_kinds : type_expression -> type_expression -> unit -> error - val different_constants : string -> string -> unit -> error - val different_size_type : name -> type_expression -> type_expression -> unit -> error - val different_props_in_record : string -> string -> unit -> error - val different_size_constants : type_expression -> type_expression -> unit -> error - val different_size_tuples : type_expression -> type_expression -> unit -> error - val different_size_sums : type_expression -> type_expression -> unit -> error - val different_size_records : type_expression -> type_expression -> unit -> error - val different_size_tuples : type_expression -> type_expression -> unit -> error - val different_types : name -> type_expression -> type_expression -> unit -> error - val different_literals : name -> literal -> literal -> unit -> error - val different_values : name -> value -> value -> unit -> error - val different_literals_because_different_types : name -> literal -> literal -> unit -> error - val different_values_because_different_types : name -> value -> value -> unit -> error - val error_uncomparable_literals : name -> literal -> literal -> unit -> error - val error_uncomparable_values : name -> value -> value -> unit -> error - val different_size_values : name -> value -> value -> unit -> error - val missing_key_in_record_value : string -> unit -> error - *) - val not_functional_main : Location.t -> unit -> error -end - - - - (* val assert_literal_eq : ( literal * literal ) -> unit result *) -val get_entry : program -> string -> expression result +val get_entry : program -> string -> expression option val p_constant : constant_tag -> p_ctor_args -> type_value val c_equation : type_value -> type_value -> string -> type_constraint diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index b2667c50b..92a964586 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -1,36 +1,8 @@ open Trace open Types -open Combinators open Misc (* open Stage_common.Types *) -let program_to_main : program -> string -> lambda result = fun p s -> - let%bind (main , input_type , _) = - let pred = fun d -> - match d with - | Declaration_constant { binder; expr; inline=_ } when binder = Var.of_name s -> Some expr - | Declaration_constant _ -> None - | Declaration_type _ -> None - in - let%bind main = - trace_option (simple_error "no main with given name") @@ - List.find_map (Function.compose pred Location.unwrap) p in - let%bind (input_ty , output_ty) = - match (get_type' @@ get_type_expression main) with - | T_arrow {type1;type2} -> ok (type1 , type2) - | _ -> simple_fail "program main isn't a function" in - ok (main , input_ty , output_ty) - in - let binder = Var.of_name "@contract_input" in - let result = - let input_expr = e_a_variable binder input_type in - let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) in - e_a_application main_expr input_expr in - ok { - binder ; - result ; - } - module Captured_variables = struct type bindings = expression_variable list @@ -41,9 +13,9 @@ module Captured_variables = struct let empty : bindings = [] let of_list : expression_variable list -> bindings = fun x -> x - let rec expression : bindings -> expression -> bindings result = fun b e -> + let rec expression : bindings -> expression -> (bindings,_) result = fun b e -> expression_content b e.expression_content - and expression_content : bindings -> expression_content -> bindings result = fun b ec -> + and expression_content : bindings -> expression_content -> (bindings,_) result = fun b ec -> let self = expression b in match ec with | E_lambda l -> ok @@ Free_variables.lambda empty l @@ -78,10 +50,10 @@ module Captured_variables = struct let b' = union (singleton r.fun_name) b in expression_content b' @@ E_lambda r.lambda - and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } -> + and matching_variant_case : (bindings -> expression -> (bindings,_) result) -> bindings -> matching_content_case -> (bindings,_) result = fun f b { constructor=_ ; pattern ; body } -> f (union (singleton pattern) b) body - and matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result = fun f b m -> + and matching : (bindings -> expression -> (bindings,_) result) -> bindings -> matching_expr -> (bindings,_) result = fun f b m -> match m with | Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> let%bind n' = f b n in diff --git a/src/stages/4-ast_typed/misc_smart.mli b/src/stages/4-ast_typed/misc_smart.mli index 52fcb29c4..4f00e26e8 100644 --- a/src/stages/4-ast_typed/misc_smart.mli +++ b/src/stages/4-ast_typed/misc_smart.mli @@ -1,14 +1,13 @@ open Trace open Types -val program_to_main : program -> string -> lambda result - module Captured_variables : sig type bindings = expression_variable list - val matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result - val matching_expression : bindings -> matching_expr -> bindings result + val matching : (bindings -> expression -> (bindings , 'b) result) -> bindings -> matching_expr -> (bindings , 'b) result + + val matching_expression : bindings -> matching_expr -> (bindings , _) result val mem : expression_variable -> bindings -> bool (* diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 8b6138f56..134b990f4 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -36,7 +36,7 @@ type 'a extra_info__comparable = { compare : 'a -> 'a -> int ; } -let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result = +let fold_map__constructor_map : type a new_a state err. (state -> a -> (state * new_a, err) result) -> state -> a constructor_map -> (state * new_a constructor_map, err) result = fun f state m -> let aux k v acc = let%bind (state , m) = acc in @@ -45,7 +45,7 @@ let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new let%bind (state , m) = CMap.fold aux m (ok (state, CMap.empty)) in ok (state , m) -let fold_map__label_map : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a label_map -> (state * new_a label_map) result = +let fold_map__label_map : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a label_map -> (state * new_a label_map , err) result = fun f state m -> let aux k v acc = let%bind (state , m) = acc in @@ -54,7 +54,7 @@ let fold_map__label_map : type a state new_a . (state -> a -> (state * new_a) re let%bind (state , m) = LMap.fold aux m (ok (state, LMap.empty)) in ok (state , m) -let fold_map__list : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list -> (state * new_a list) Simple_utils.Trace.result = +let fold_map__list : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a list -> (state * new_a list , err) result = fun f state l -> let aux acc element = let%bind state , l = acc in @@ -62,12 +62,12 @@ let fold_map__list : type a state new_a . (state -> a -> (state * new_a) result) let%bind (state , l) = List.fold_left aux (ok (state , [])) l in ok (state , l) -let fold_map__location_wrap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a location_wrap -> (state * new_a location_wrap) Simple_utils.Trace.result = +let fold_map__location_wrap : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a location_wrap -> (state * new_a location_wrap , err) result = fun f state { wrap_content ; location } -> let%bind ( state , wrap_content ) = f state wrap_content in ok (state , ({ wrap_content ; location } : new_a location_wrap)) -let fold_map__list_ne : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list_ne -> (state * new_a list_ne) Simple_utils.Trace.result = +let fold_map__list_ne : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a list_ne -> (state * new_a list_ne , err) result = fun f state (first , l) -> let%bind (state , new_first) = f state first in let aux acc element = @@ -77,7 +77,7 @@ let fold_map__list_ne : type a state new_a . (state -> a -> (state * new_a) resu let%bind (state , l) = List.fold_left aux (ok (state , [])) l in ok (state , (new_first , l)) -let fold_map__option : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a option -> (state * new_a option) Simple_utils.Trace.result = +let fold_map__option : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a option -> (state * new_a option , err) result = fun f state o -> match o with | None -> ok (state, None) @@ -97,7 +97,7 @@ type 'v typeVariableMap = (type_variable, 'v) RedBlackTrees.PolyMap.t type 'a poly_set = 'a RedBlackTrees.PolySet.t -let fold_map__poly_unionfind : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result = +let fold_map__poly_unionfind : type a state new_a err . new_a extra_info__comparable -> (state -> a -> (state * new_a, err) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind, err) result = fun extra_info f state l -> ignore (extra_info, f, state, l) ; failwith "TODO let aux acc element = @@ -106,7 +106,7 @@ let fold_map__poly_unionfind : type a state new_a . new_a extra_info__comparable let%bind (state , l) = List.fold_left aux (ok (state , [])) l in ok (state , l)" -let fold_map__PolyMap : type k v state new_v . (state -> v -> (state * new_v) result) -> state -> (k, v) PolyMap.t -> (state * (k, new_v) PolyMap.t) result = +let fold_map__PolyMap : type k v state new_v err . (state -> v -> (state * new_v, err) result) -> state -> (k, v) PolyMap.t -> (state * (k, new_v) PolyMap.t , err) result = fun f state m -> let aux k v ~acc = let%bind (state , m) = acc in @@ -115,10 +115,10 @@ let fold_map__PolyMap : type k v state new_v . (state -> v -> (state * new_v) re let%bind (state , m) = PolyMap.fold_inc aux m ~init:(ok (state, PolyMap.empty m)) in ok (state , m) -let fold_map__typeVariableMap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a typeVariableMap -> (state * new_a typeVariableMap) result = +let fold_map__typeVariableMap : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a typeVariableMap -> (state * new_a typeVariableMap , err) result = fold_map__PolyMap -let fold_map__poly_set : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result = +let fold_map__poly_set : type a state new_a err . new_a extra_info__comparable -> (state -> a -> (state * new_a, err) result) -> state -> a poly_set -> (state * new_a poly_set, err) result = fun extra_info f state s -> let new_compare : (new_a -> new_a -> int) = extra_info.compare in let aux elt ~acc = diff --git a/src/stages/5-mini_c/PP.mli b/src/stages/5-mini_c/PP.mli index c036a5b07..cbbcea793 100644 --- a/src/stages/5-mini_c/PP.mli +++ b/src/stages/5-mini_c/PP.mli @@ -18,6 +18,7 @@ val type_expression : formatter -> type_expression -> unit val value_assoc : formatter -> (value * value) -> unit *) val expression_content : formatter -> expression_content -> unit +val type_constant : formatter -> type_base -> unit val expression : formatter -> expression -> unit val expression_with_type : formatter -> expression -> unit diff --git a/src/stages/5-mini_c/combinators.ml b/src/stages/5-mini_c/combinators.ml index f01eda745..5bcf5b3ba 100644 --- a/src/stages/5-mini_c/combinators.ml +++ b/src/stages/5-mini_c/combinators.ml @@ -1,4 +1,3 @@ -open Trace open Types module Expression = struct @@ -30,141 +29,136 @@ module Expression = struct end let get_bool (v:value) = match v with - | D_bool b -> ok b - | _ -> simple_fail "not a bool" + | D_bool b -> Some b + | _ -> None let get_int (v:value) = match v with - | D_int n -> ok n - | _ -> simple_fail "not an int" + | D_int n -> Some n + | _ -> None let get_nat (v:value) = match v with - | D_nat n -> ok n - | _ -> simple_fail "not a nat" + | D_nat n -> Some n + | _ -> None let get_mutez (v:value) = match v with - | D_mutez n -> ok n - | _ -> simple_fail "not a mutez" + | D_mutez n -> Some n + | _ -> None let get_timestamp (v:value) = match v with - | D_timestamp n -> ok n - | _ -> simple_fail "not a timestamp" + | D_timestamp n -> Some n + | _ -> None let get_string (v:value) = match v with - | D_string s -> ok s - | _ -> simple_fail "not a string" + | D_string s -> Some s + | _ -> None let get_bytes (v:value) = match v with - | D_bytes b -> ok b - | _ -> simple_fail "not a bytes" + | D_bytes b -> Some b + | _ -> None let get_unit (v:value) = match v with - | D_unit -> ok () - | _ -> simple_fail "not a unit" + | D_unit -> Some () + | _ -> None let get_option (v:value) = match v with - | D_none -> ok None - | D_some s -> ok (Some s) - | _ -> simple_fail "not an option" + | D_none -> Some None + | D_some s -> Some (Some s) + | _ -> None let get_map (v:value) = match v with - | D_map lst -> ok lst - | _ -> simple_fail "not a map" + | D_map lst -> Some lst + | _ -> None let get_big_map (v:value) = match v with - | D_big_map lst -> ok lst - | _ -> simple_fail "not a big_map" + | D_big_map lst -> Some lst + | _ -> None let get_list (v:value) = match v with - | D_list lst -> ok lst - | _ -> simple_fail "not a list" + | D_list lst -> Some lst + | _ -> None let get_set (v:value) = match v with - | D_set lst -> ok lst - | _ -> simple_fail "not a set" + | D_set lst -> Some lst + | _ -> None let get_function_with_ty (e : expression) = match (e.content , e.type_expression.type_content) with - | E_closure f , T_function ty -> ok (f , ty) - | _ -> simple_fail "not a function with functional type" + | E_closure f , T_function ty -> Some (f , ty) + | _ -> None let get_function (e : expression) = match (e.content) with - | E_closure f -> ok f - | _ -> simple_fail "not a function" + | E_closure f -> Some f + | _ -> None let get_t_function tv = match tv.type_content with - | T_function ty -> ok ty - | _ -> simple_fail "not a function" + | T_function ty -> Some ty + | _ -> None let get_t_option (v:type_expression) = match v.type_content with - | T_option t -> ok t - | _ -> simple_fail "not an option" + | T_option t -> Some t + | _ -> None let get_pair (v:value) = match v with - | D_pair (a, b) -> ok (a, b) - | _ -> simple_fail "not a pair" + | D_pair (a, b) -> Some (a, b) + | _ -> None let get_t_pair (t:type_expression) = match t.type_content with - | T_pair ((_, a), (_, b)) -> ok (a, b) - | _ -> simple_fail "not a type pair" + | T_pair ((_, a), (_, b)) -> Some (a, b) + | _ -> None let get_t_or (t:type_expression) = match t.type_content with - | T_or ((_, a), (_, b)) -> ok (a, b) - | _ -> simple_fail "not a type or" + | T_or ((_, a), (_, b)) -> Some (a, b) + | _ -> None let get_t_map (t:type_expression) = match t.type_content with - | T_map kv -> ok kv - | _ -> simple_fail "not a type map" + | T_map kv -> Some kv + | _ -> None let get_t_big_map (t:type_expression) = match t.type_content with - | T_big_map kv -> ok kv - | _ -> simple_fail "not a type big_map" + | T_big_map kv -> Some kv + | _ -> None let get_t_list (t:type_expression) = match t.type_content with - | T_list t -> ok t - | _ -> simple_fail "not a type list" + | T_list t -> Some t + | _ -> None let get_t_set (t:type_expression) = match t.type_content with - | T_set t -> ok t - | _ -> simple_fail "not a type set" + | T_set t -> Some t + | _ -> None let get_left (v:value) = match v with - | D_left b -> ok b - | _ -> simple_fail "not a left" + | D_left b -> Some b + | _ -> None let get_right (v:value) = match v with - | D_right b -> ok b - | _ -> simple_fail "not a right" + | D_right b -> Some b + | _ -> None let get_or (v:value) = match v with - | D_left b -> ok (false, b) - | D_right b -> ok (true, b) - | _ -> simple_fail "not a left/right" - -let wrong_type name t = - let title () = "not a " ^ name in - let content () = Format.asprintf "%a" PP.type_variable t in - error title content + | D_left b -> Some (false, b) + | D_right b -> Some (true, b) + | _ -> None let get_t_left t = match t.type_content with - | T_or ((_, a) , _) -> ok a - | _ -> fail @@ wrong_type "union" t + | T_or ((_, a) , _) -> Some a + | _ -> None let get_t_right t = match t.type_content with - | T_or (_ , (_, b)) -> ok b - | _ -> fail @@ wrong_type "union" t + | T_or (_ , (_, b)) -> Some b + | _ -> None let get_t_contract t = match t.type_content with - | T_contract x -> ok x - | _ -> fail @@ wrong_type "contract" t + | T_contract x -> Some x + | _ -> None let get_t_operation t = match t.type_content with - | T_base TB_operation -> ok t - | _ -> fail @@ wrong_type "operation" t + | T_base TB_operation -> Some t + | _ -> None let get_operation (v:value) = match v with - | D_operation x -> ok x - | _ -> simple_fail "not an operation" + | D_operation x -> Some x + | _ -> None let t_int ?loc () : type_expression = Expression.make_t ?loc @@ T_base TB_int diff --git a/src/stages/5-mini_c/combinators.mli b/src/stages/5-mini_c/combinators.mli index 3a9aab3ed..b6ba6f479 100644 --- a/src/stages/5-mini_c/combinators.mli +++ b/src/stages/5-mini_c/combinators.mli @@ -1,4 +1,3 @@ -open Trace open Types module Expression : sig @@ -17,41 +16,41 @@ module Expression : sig val pair : t -> t -> t' end -val get_bool : value ->bool result -val get_int : value -> Z.t result -val get_nat : value -> Z.t result -val get_mutez : value -> Z.t result -val get_timestamp : value -> Z.t result -val get_string : value -> string result -val get_bytes : value -> bytes result -val get_unit : value -> unit result -val get_option : value -> value option result -val get_map : value -> ( value * value ) list result -val get_big_map : value -> ( value * value ) list result -val get_list : value -> value list result -val get_set : value -> value list result -val get_function_with_ty : expression -> ( anon_function * ( type_expression * type_expression) ) result -val get_function : expression -> anon_function result -val get_t_function : type_expression -> ( type_expression * type_expression ) result -val get_t_option : type_expression -> type_expression result -val get_pair : value -> ( value * value ) result -val get_t_pair : type_expression -> ( type_expression * type_expression ) result -val get_t_or : type_expression -> ( type_expression * type_expression ) result -val get_t_map : type_expression -> ( type_expression * type_expression ) result -val get_t_big_map : type_expression -> ( type_expression * type_expression ) result -val get_t_list : type_expression -> type_expression result -val get_t_set : type_expression -> type_expression result -val get_left : value -> value result -val get_right : value -> value result -val get_or : value -> ( bool * value ) result +val get_bool : value -> bool option +val get_int : value -> Z.t option +val get_nat : value -> Z.t option +val get_mutez : value -> Z.t option +val get_timestamp : value -> Z.t option +val get_string : value -> string option +val get_bytes : value -> bytes option +val get_unit : value -> unit option +val get_option : value -> value option option +val get_map : value -> (value * value) list option +val get_big_map : value -> ( value * value ) list option +val get_list : value -> value list option +val get_set : value -> value list option +val get_function_with_ty : expression -> ( anon_function * ( type_expression * type_expression) ) option +val get_function : expression -> anon_function option +val get_t_function : type_expression -> ( type_expression * type_expression ) option +val get_t_option : type_expression -> type_expression option +val get_pair : value -> ( value * value ) option +val get_t_pair : type_expression -> ( type_expression * type_expression ) option +val get_t_or : type_expression -> ( type_expression * type_expression ) option +val get_t_map : type_expression -> ( type_expression * type_expression ) option +val get_t_big_map : type_expression -> ( type_expression * type_expression ) option +val get_t_list : type_expression -> type_expression option +val get_t_set : type_expression -> type_expression option +val get_left : value -> value option +val get_right : value -> value option +val get_or : value -> ( bool * value ) option (* -val wrong_type : string -> type_value -> unit -> error +val wrong_type : string -> type_expression -> unit -> error *) -val get_t_left : type_expression -> type_expression result -val get_t_right : type_expression -> type_expression result -val get_t_contract : type_expression -> type_expression result -val get_t_operation : type_expression -> type_expression result -val get_operation : value -> Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation result +val get_t_left : type_expression -> type_expression option +val get_t_right : type_expression -> type_expression option +val get_t_contract : type_expression -> type_expression option +val get_t_operation : type_expression -> type_expression option +val get_operation : value -> Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation option val t_int : ?loc:Location.t -> unit -> type_expression val t_unit : ?loc:Location.t -> unit -> type_expression @@ -60,7 +59,7 @@ val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_e val t_pair : ?loc:Location.t -> type_expression annotated -> type_expression annotated -> type_expression val t_union : ?loc:Location.t -> type_expression annotated -> type_expression annotated -> type_expression (* -val quote : string -> type_value -> type_value -> Expression.t -> anon_function +val quote : string -> type_expression -> type_expression -> Expression.t -> anon_function val e_int : Expression.t' -> Expression.t diff --git a/src/stages/5-mini_c/formatter.ml b/src/stages/5-mini_c/formatter.ml new file mode 100644 index 000000000..6c4bacdc1 --- /dev/null +++ b/src/stages/5-mini_c/formatter.ml @@ -0,0 +1,26 @@ +open Display +open Types + +(* this type is not necessary if the output of CLI command 'print-mini-c' have the + same type when optimized and when not *) +type optim = + | Optimized of expression + | Raw of program + +let program_ppformat ~display_format f (p,_) = + match display_format with + | Human_readable | Dev -> ( match p with + | Optimized e -> PP.expression f e + | Raw e -> PP.program f e + ) + +let program_jsonformat (p,_) : json = + let s = ( match p with + | Optimized e -> Format.asprintf "%a" PP.expression e + | Raw e -> Format.asprintf "%a" PP.program e ) in + `Assoc [("Typed(temp)" , `String s)] + +let program_format : 'a format = { + pp = program_ppformat; + to_json = program_jsonformat; +} \ No newline at end of file diff --git a/src/stages/5-mini_c/mini_c.ml b/src/stages/5-mini_c/mini_c.ml index 0eca16a75..27e9862a3 100644 --- a/src/stages/5-mini_c/mini_c.ml +++ b/src/stages/5-mini_c/mini_c.ml @@ -1,4 +1,5 @@ module Types = Types +module Formatter = Formatter include Types module PP = PP diff --git a/src/stages/5-mini_c/misc.ml b/src/stages/5-mini_c/misc.ml index 8a87401ae..17a3a7d0c 100644 --- a/src/stages/5-mini_c/misc.ml +++ b/src/stages/5-mini_c/misc.ml @@ -1,26 +1,5 @@ open Types open Combinators -open Trace - -module Errors = struct - - let missing_entry_point name = - let title () = "missing entry point" in - let content () = "no entry point with the given name" in - let data = [ - ("name" , fun () -> name) ; - ] in - error ~data title content - - let not_functional_main name = - let title () = "not functional main" in - let content () = "main should be a function" in - let data = [ - ("name" , fun () -> Format.asprintf "%s" name) ; - ] in - error ~data title content - -end module Free_variables = struct @@ -116,9 +95,8 @@ module Free_variables = struct end -let get_entry (lst : program) (name : string) : (expression * int) result = - let%bind entry_expression = - trace_option (Errors.missing_entry_point name) @@ +let get_entry (lst : program) (name : string) : (expression * int) option = + let entry_expression = let aux x = let (((decl_name , _, decl_expr) , _)) = x in if (Var.equal decl_name (Var.of_name name)) @@ -127,20 +105,23 @@ let get_entry (lst : program) (name : string) : (expression * int) result = in List.find_map aux (List.rev lst) in - let entry_index = - let aux x = - let (((decl_name , _, _) , _)) = x in - Var.equal decl_name (Var.of_name name) - in - (List.length lst) - (List.find_index aux (List.rev lst)) - 1 - in - ok (entry_expression , entry_index) + match entry_expression with + | Some exp -> + let entry_index = + let aux x = + let (((decl_name , _, _) , _)) = x in + Var.equal decl_name (Var.of_name name) + in + (List.length lst) - (List.find_index aux (List.rev lst)) - 1 + in + Some (exp, entry_index) + | None -> None type form_t = | ContractForm of expression | ExpressionForm of expression -let aggregate_entry (lst : program) (form : form_t) : expression result = +let aggregate_entry (lst : program) (form : form_t) : expression option = let wrapper = let aux prec cur = let (((name , inline, expr) , _)) = cur in @@ -158,8 +139,8 @@ let aggregate_entry (lst : program) (form : form_t) : expression result = type_expression = entry_expression.type_expression ; location = entry_expression.location; } in - ok e' + Some e' ) - | _ -> simple_fail "a contract must be a closure" ) + | _ -> None ) | ExpressionForm entry_expression -> - ok @@ wrapper entry_expression + Some (wrapper entry_expression) diff --git a/src/stages/adt_generator/common.ml b/src/stages/adt_generator/common.ml index 890711eb9..6c6d2e650 100644 --- a/src/stages/adt_generator/common.ml +++ b/src/stages/adt_generator/common.ml @@ -1,3 +1,3 @@ -type ('a,'err) monad = ('a) Simple_utils.Trace.result;; +type ('a,'err) monad = ('a,'err) Simple_utils.Trace.result;; let (>>?) v f = Simple_utils.Trace.bind f v;; let return v = Simple_utils.Trace.ok v;; diff --git a/src/stages/common/helpers.ml b/src/stages/common/helpers.ml index dded3a7d8..64f104c21 100644 --- a/src/stages/common/helpers.ml +++ b/src/stages/common/helpers.ml @@ -42,10 +42,9 @@ let is_tuple_lmap m = List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m)) let get_pair m = - let open Trace in match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with - | Some e1, Some e2 -> ok (e1,e2) - | _ -> simple_fail "not a pair" + | Some e1, Some e2 -> Some (e1,e2) + | _ -> None let tuple_of_record (m: _ LMap.t) = let aux i = diff --git a/src/stages/common/helpers.mli b/src/stages/common/helpers.mli index 03817d6d4..0282f6ae6 100644 --- a/src/stages/common/helpers.mli +++ b/src/stages/common/helpers.mli @@ -1,34 +1,41 @@ +open Trace open Types val bind_lmap : - ('a * 'b list, 'c) result Types.label_map -> - ('a Types.label_map * 'b list, 'c) result + ('a, 'c) result label_map -> ('a label_map , 'c) result + val bind_cmap : - ('a * 'b list, 'c) result Types.constructor_map -> - ('a Types.constructor_map * 'b list, 'c) result + ('a, 'c) result constructor_map -> ('a constructor_map , 'c) result + val bind_fold_lmap : - ('a -> Types.label -> 'b -> ('a * 'c list, 'd) result) -> - ('a * 'c list, 'd) result -> - 'b Types.label_map -> ('a * 'c list, 'd) result + ('a -> label -> 'b -> ('a , 'd) result) -> ('a , 'd) result -> + 'b label_map -> ('a , 'd) result + val bind_map_lmap : - ('a -> ('b * 'c list, 'd) result) -> - 'a Types.label_map -> ('b Types.label_map * 'c list, 'd) result -val bind_map_cmap : + ('a -> ('b , 'd) result) -> + 'a label_map -> ('b label_map , 'd) result + +(* val bind_map_cmap : ('a -> ('b * 'c list, 'd) result) -> 'a Types.constructor_map -> - ('b Types.constructor_map * 'c list, 'd) result + ('b Types.constructor_map * 'c list, 'd) result *) + val is_tuple_lmap : 'a Types.label_map -> bool -val get_pair : - 'a Types.label_map -> - (('a * 'a) * 'b list, unit -> Trace.error) result + +val get_pair : 'a Types.label_map -> ('a * 'a) option + val tuple_of_record : 'a LMap.t -> (label * 'a) list val list_of_record_or_tuple : 'a LMap.t -> 'a list val kv_list_of_record_or_tuple : 'a LMap.t -> (label * 'a) list +val bind_map_cmap : + ('a -> ('b , 'd) result) -> + 'a constructor_map -> ('b constructor_map , 'd) result val bind_map_lmapi : - (Types.label -> 'a -> ('b * 'c list, 'd) result) -> - 'a Types.label_map -> ('b Types.label_map * 'c list, 'd) result + (label -> 'a -> ('b , 'd) result) -> + 'a label_map -> ('b label_map , 'd) result + val bind_map_cmapi : - (Types.constructor' -> 'a -> ('b * 'c list, 'd) result) -> - 'a Types.constructor_map -> ('b Types.constructor_map * 'c list, 'd) result + (constructor' -> 'a -> ('b , 'd) result) -> + 'a constructor_map -> ('b constructor_map , 'd) result diff --git a/src/stages/ligo_interpreter/combinators.ml b/src/stages/ligo_interpreter/combinators.ml index d01ef460f..b40789b0f 100644 --- a/src/stages/ligo_interpreter/combinators.ml +++ b/src/stages/ligo_interpreter/combinators.ml @@ -16,19 +16,16 @@ let v_some : value -> value = let v_none : unit -> value = fun () -> V_Construct ("None", v_unit ()) -let extract_pair : value -> (value * value) result = +let extract_pair : value -> (value * value , _) result = fun p -> - let err = simple_error "value is not a pair" in ( match p with | V_Record lmap -> - let%bind fst = trace_option err @@ - LMap.find_opt (Label "0") lmap in - let%bind snd = trace_option err @@ - LMap.find_opt (Label "1") lmap in + let fst = LMap.find (Label "0") lmap in + let snd = LMap.find (Label "1") lmap in ok (fst,snd) - | _ -> fail err ) + | _ -> failwith "value is not a pair" ) -let is_true : value -> bool result = +let is_true : value -> (bool , _) result = fun b -> match b with | V_Ct (C_bool b) -> ok b - | _ -> simple_fail "value is not a bool" + | _ -> failwith "value is not a bool" diff --git a/src/stages/ligo_interpreter/environment.ml b/src/stages/ligo_interpreter/environment.ml index 5c1da4661..5373fbc4f 100644 --- a/src/stages/ligo_interpreter/environment.ml +++ b/src/stages/ligo_interpreter/environment.ml @@ -6,9 +6,9 @@ let extend : = fun env (var,exp) -> Env.add var exp env let lookup : - env -> expression_variable -> value result + env -> expression_variable -> (value,_) result = fun env var -> match Env.find_opt var env with | Some res -> ok res - | None -> simple_fail "TODO: not found in env" + | None -> failwith "TODO: not found in env" let empty_env = Env.empty \ No newline at end of file diff --git a/src/stages/ligo_interpreter/formatter.ml b/src/stages/ligo_interpreter/formatter.ml new file mode 100644 index 000000000..5a906f33b --- /dev/null +++ b/src/stages/ligo_interpreter/formatter.ml @@ -0,0 +1,15 @@ +open Display + +let program_ppformat ~display_format f (program_as_string,_) = + match display_format with + | Human_readable | Dev -> + Format.pp_print_string f program_as_string + +let program_jsonformat (program_as_string,_) : json = + let s = Format.asprintf "%s" program_as_string in + `Assoc [("Typed(temp)" , `String s)] + +let program_format : 'a format = { + pp = program_ppformat; + to_json = program_jsonformat; +} diff --git a/src/stages/ligo_interpreter/ligo_interpreter.ml b/src/stages/ligo_interpreter/ligo_interpreter.ml index 60ca6311e..a5c50769f 100644 --- a/src/stages/ligo_interpreter/ligo_interpreter.ml +++ b/src/stages/ligo_interpreter/ligo_interpreter.ml @@ -1,4 +1,5 @@ module Types = Types module PP = PP module Environment = Environment -module Combinators = Combinators \ No newline at end of file +module Combinators = Combinators +module Formatter = Formatter \ No newline at end of file diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index 8fa44fa87..eb707b5f5 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -30,33 +30,31 @@ type type_expression = Ast_typed.type_expression let fresh_type_variable : ?name:string -> unit -> type_variable = Var.fresh -open Trace -let type_expression'_of_simple_c_constant : constant_tag * type_expression list -> Ast_typed.type_content result = fun (c, l) -> +let type_expression'_of_simple_c_constant : constant_tag * type_expression list -> Ast_typed.type_content option = fun (c, l) -> match c, l with - | C_contract , [x] -> ok @@ Ast_typed.T_operator(TC_contract x) - | C_option , [x] -> ok @@ Ast_typed.T_operator(TC_option x) - | C_list , [x] -> ok @@ Ast_typed.T_operator(TC_list x) - | C_set , [x] -> ok @@ Ast_typed.T_operator(TC_set x) - | C_map , [k ; v] -> ok @@ Ast_typed.T_operator(TC_map {k ; v}) - | C_big_map , [k ; v] -> ok @@ Ast_typed.T_operator(TC_big_map {k ; v}) - | C_arrow , [x ; y] -> ok @@ Ast_typed.T_arrow {type1=x ; type2=y} (* For now, the arrow type constructor is special *) - | C_record , _lst -> ok @@ failwith "records are not supported yet: T_record lst" - | C_variant , _lst -> ok @@ failwith "sums are not supported yet: T_sum lst" - | (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow ), _ -> - failwith "internal error: wrong number of arguments for type operator" + | C_contract , [x] -> Some (Ast_typed.T_operator(TC_contract x)) + | C_option , [x] -> Some (Ast_typed.T_operator(TC_option x)) + | C_list , [x] -> Some (Ast_typed.T_operator(TC_list x)) + | C_set , [x] -> Some (Ast_typed.T_operator(TC_set x)) + | C_map , [k ; v] -> Some (Ast_typed.T_operator(TC_map {k ; v})) + | C_big_map , [k ; v] -> Some (Ast_typed.T_operator(TC_big_map {k ; v})) + | C_arrow , [x ; y] -> Some (Ast_typed.T_arrow {type1=x ; type2=y}) (* For now, the arrow type constructor is special *) + | C_record , _lst -> None + | C_variant , _lst -> None + | (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow ), _ -> None - | C_unit , [] -> ok @@ Ast_typed.T_constant(TC_unit) - | C_string , [] -> ok @@ Ast_typed.T_constant(TC_string) - | C_bytes , [] -> ok @@ Ast_typed.T_constant(TC_bytes) - | C_nat , [] -> ok @@ Ast_typed.T_constant(TC_nat) - | C_int , [] -> ok @@ Ast_typed.T_constant(TC_int) - | C_mutez , [] -> ok @@ Ast_typed.T_constant(TC_mutez) - | C_operation , [] -> ok @@ Ast_typed.T_constant(TC_operation) - | C_address , [] -> ok @@ Ast_typed.T_constant(TC_address) - | C_key , [] -> ok @@ Ast_typed.T_constant(TC_key) - | C_key_hash , [] -> ok @@ Ast_typed.T_constant(TC_key_hash) - | C_chain_id , [] -> ok @@ Ast_typed.T_constant(TC_chain_id) - | C_signature , [] -> ok @@ Ast_typed.T_constant(TC_signature) - | C_timestamp , [] -> ok @@ Ast_typed.T_constant(TC_timestamp) + | C_unit , [] -> Some (Ast_typed.T_constant(TC_unit)) + | C_string , [] -> Some (Ast_typed.T_constant(TC_string)) + | C_bytes , [] -> Some (Ast_typed.T_constant(TC_bytes)) + | C_nat , [] -> Some (Ast_typed.T_constant(TC_nat)) + | C_int , [] -> Some (Ast_typed.T_constant(TC_int)) + | C_mutez , [] -> Some (Ast_typed.T_constant(TC_mutez)) + | C_operation , [] -> Some (Ast_typed.T_constant(TC_operation)) + | C_address , [] -> Some (Ast_typed.T_constant(TC_address)) + | C_key , [] -> Some (Ast_typed.T_constant(TC_key)) + | C_key_hash , [] -> Some (Ast_typed.T_constant(TC_key_hash)) + | C_chain_id , [] -> Some (Ast_typed.T_constant(TC_chain_id)) + | C_signature , [] -> Some (Ast_typed.T_constant(TC_signature)) + | C_timestamp , [] -> Some (Ast_typed.T_constant(TC_timestamp)) | (C_unit | C_string | C_bytes | C_nat | C_int | C_mutez | C_operation | C_address | C_key | C_key_hash | C_chain_id | C_signature | C_timestamp), _::_ -> - failwith "internal error: wrong number of arguments for type constant" + None diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 076a47484..389f93e89 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -12,7 +12,7 @@ module Substitution = struct type substs = variable:type_variable -> T.type_content option (* this string is a type_name or type_variable I think *) let mk_substs ~v ~expr = (v , expr) - type 'a w = substs:substs -> 'a -> 'a result + type ('a, 'err) w = substs:substs -> 'a -> ('a,'err) result let rec rec_yes = true and s_environment_element_definition ~substs = function @@ -21,47 +21,43 @@ module Substitution = struct let%bind expr = s_expression ~substs expr in let%bind free_variables = bind_map_list (s_variable ~substs) free_variables in ok @@ T.ED_declaration {expr ; free_variables} - and s_expr_environment : T.expression_environment w = fun ~substs env -> + and s_expr_environment : (T.expression_environment,_) w = fun ~substs env -> bind_map_list (fun T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }} -> let%bind type_value = s_type_expression ~substs type_value in let%bind source_environment = s_environment ~substs source_environment in let%bind definition = s_environment_element_definition ~substs definition in ok @@ T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }}) env - and s_type_environment : T.type_environment w = fun ~substs tenv -> + and s_type_environment : (T.type_environment,_) w = fun ~substs tenv -> bind_map_list (fun T.{type_variable ; type_} -> let%bind type_ = s_type_expression ~substs type_ in ok @@ T.{type_variable ; type_}) tenv - and s_environment : T.environment w = fun ~substs T.{expression_environment ; type_environment} -> + and s_environment : (T.environment,_) w = fun ~substs T.{expression_environment ; type_environment} -> let%bind expression_environment = s_expr_environment ~substs expression_environment in let%bind type_environment = s_type_environment ~substs type_environment in ok @@ T.{ expression_environment ; type_environment } - (* and s_environment : T.environment w = fun ~substs (a , b) -> - let%bind a = s_environment ~substs a in - let%bind b = bind_map_list (s_environment ~substs) b in - ok (a , b) *) - and s_variable : T.expression_variable w = fun ~substs var -> + and s_variable : (T.expression_variable,_) w = fun ~substs var -> let () = ignore @@ substs in ok var - and s_label : T.label w = fun ~substs l -> + and s_label : (T.label,_) w = fun ~substs l -> let () = ignore @@ substs in ok l - and s_build_in : T.constant' w = fun ~substs b -> + and s_build_in : (T.constant',_) w = fun ~substs b -> let () = ignore @@ substs in ok b - and s_constructor : T.constructor' w = fun ~substs c -> + and s_constructor : (T.constructor',_) w = fun ~substs c -> let () = ignore @@ substs in ok c - and s_type_name_constant : T.type_constant w = fun ~substs type_name -> + and s_type_name_constant : (T.type_constant,_) w = fun ~substs type_name -> (* TODO: we don't need to subst anything, right? *) let () = ignore @@ substs in ok @@ type_name - and s_type_content : T.type_content w = fun ~substs -> function + and s_type_content : (T.type_content,_) w = fun ~substs -> function | T.T_sum s -> let aux T.{ ctor_type; michelson_annotation ; ctor_decl_pos } = let%bind ctor_type = s_type_expression ~substs ctor_type in @@ -86,7 +82,7 @@ module Substitution = struct let%bind type2 = s_type_expression ~substs type2 in ok @@ T.T_arrow { type1; type2 } - and s_abstr_type_content : Ast_core.type_content w = fun ~substs -> function + and s_abstr_type_content : (Ast_core.type_content,_) w = fun ~substs -> function | Ast_core.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression sum" | Ast_core.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record" | Ast_core.T_arrow _ -> failwith "TODO: subst: unimplemented case s_type_expression arrow" @@ -100,15 +96,15 @@ module Substitution = struct | Ast_core.T_constant constant -> ok @@ Ast_core.T_constant constant - and s_abstr_type_expression : Ast_core.type_expression w = fun ~substs {type_content;location;type_meta} -> + and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {type_content;location;type_meta} -> let%bind type_content = s_abstr_type_content ~substs type_content in ok @@ Ast_core.{type_content;location;type_meta} - and s_type_expression : T.type_expression w = fun ~substs { type_content; location; type_meta } -> + and s_type_expression : (T.type_expression,_) w = fun ~substs { type_content; location; type_meta } -> let%bind type_content = s_type_content ~substs type_content in let%bind type_meta = bind_map_option (s_abstr_type_expression ~substs) type_meta in ok @@ T.{ type_content; location; type_meta} - and s_literal : T.literal w = fun ~substs -> function + and s_literal : (T.literal,_) w = fun ~substs -> function | T.Literal_unit -> let () = ignore @@ substs in ok @@ T.Literal_unit @@ -128,14 +124,14 @@ module Substitution = struct | (T.Literal_chain_id _ as x) | (T.Literal_operation _ as x) -> ok @@ x - and s_matching_expr : T.matching_expr w = fun ~substs _ -> + and s_matching_expr : (T.matching_expr,_) w = fun ~substs _ -> let _TODO = substs in failwith "TODO: subst: unimplemented case s_matching" - and s_accessor : T.record_accessor w = fun ~substs _ -> + and s_accessor : (T.record_accessor,_) w = fun ~substs _ -> let _TODO = substs in failwith "TODO: subst: unimplemented case s_access_path" - and s_expression_content : T.expression_content w = fun ~(substs : substs) -> function + and s_expression_content : (T.expression_content,_) w = fun ~(substs : substs) -> function | T.E_literal x -> let%bind x = s_literal ~substs x in ok @@ T.E_literal x @@ -193,13 +189,13 @@ module Substitution = struct let%bind cases = s_matching_expr ~substs cases in ok @@ T.E_matching {matchee;cases} - and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; location } -> + and s_expression : (T.expression,_) w = fun ~(substs:substs) { expression_content; type_expression; location } -> let%bind expression_content = s_expression_content ~substs expression_content in let%bind type_expr = s_type_expression ~substs type_expression in let location = location in ok T.{ expression_content;type_expression=type_expr; location } - and s_declaration : T.declaration w = fun ~substs -> + and s_declaration : (T.declaration,_) w = fun ~substs -> function | Ast_typed.Declaration_constant {binder ; expr ; inline} -> let%bind binder = s_variable ~substs binder in @@ -207,12 +203,12 @@ module Substitution = struct ok @@ Ast_typed.Declaration_constant {binder; expr; inline} | Declaration_type t -> ok (Ast_typed.Declaration_type t) - and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d -> + and s_declaration_wrap : (T.declaration Location.wrap,_) w = fun ~substs d -> Trace.bind_map_location (s_declaration ~substs) d (* Replace the type variable ~v with ~expr everywhere within the program ~p. TODO: issues with scoping/shadowing. *) - and s_program : Ast_typed.program w = fun ~substs p -> + and s_program : (Ast_typed.program,_) w = fun ~substs p -> Trace.bind_map_list (s_declaration_wrap ~substs) p (* diff --git a/src/test/adt_generator/dune b/src/test/adt_generator/dune index 16af71a00..0d4ebe9c4 100644 --- a/src/test/adt_generator/dune +++ b/src/test/adt_generator/dune @@ -7,7 +7,7 @@ (executable (name test_adt_generator) - (libraries adt_generator simple-utils) + (libraries adt_generator simple-utils ligo) (preprocess (pps ppx_let bisect_ppx --conditional) ) diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index e6277f76e..f7fec8c15 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -6,17 +6,11 @@ module O = Fold.O let (|>) v f = f v -module Errors = struct - let test_fail msg = - let title () = "test failed" in - let message () = msg in - error title message -end - (* TODO: how should we plug these into our test framework? *) -let test (x : unit result) : unit = match x with +let test (x : (unit,_) result) : unit = match x with | Ok (() , _annotation_thunk) -> () -| Error err -> failwith (Yojson.Basic.to_string @@ err ()) +(* | Error err -> failwith (Yojson.Basic.to_string @@ err ()) *) +| Error _err -> failwith ("TODO") let () = test @@ @@ -31,7 +25,8 @@ let () = let state = 0 in let%bind (state , _) = fold_map__root op state some_root in if state != 2 then - fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state) + (* expected folder to count 2 nodes, but it counted 'state' nodes *) + fail @@ Main_errors.test_internal __LOC__ else ok () @@ -43,7 +38,8 @@ let () = let state = 0 in let%bind (state , _) = fold_map__root op state some_root in if state != 2 then - fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state) + (* expected folder to count 2 nodes, but it counted 'state' nodes *) + fail @@ Main_errors.test_internal __LOC__ else ok () @@ -54,14 +50,15 @@ let () = let state = 0 in let%bind (state , _) = fold_map__root op state some_root in if state != 2 then - fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state) + (* expected folder to count 2 nodes, but it counted 'state' nodes *) + fail @@ Main_errors.test_internal __LOC__ else ok () (* Test that the same fold_map_config can be ascibed with different 'a type arguments *) -let _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) -let _nob : (bool, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) +let _noi : (int, _) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) +let _nob : (bool, _) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) type no_state = NoState let () = diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index c1cc1d680..f37a06910 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -2,6 +2,7 @@ open Trace open Test_helpers +open Main_errors let type_file f = let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" (Contract "main") in @@ -123,18 +124,17 @@ let buy () = in let%bind () = let%bind amount = - trace_option (simple_error "getting amount for run") @@ - Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in + trace_option (test_internal "getting amount for run") @@ + Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount ~sender:second_contract () in expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in let%bind () = let%bind amount = - trace_option (simple_error "getting amount for run") @@ - Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in + trace_option (test_internal "getting amount for run") @@ + Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount ~sender:second_contract () in - trace_strong (simple_error "could buy without money") @@ - Assert.assert_fail - @@ expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in + Assert.assert_fail (test_internal "could buy without money") @@ + expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in ok () in ok () @@ -162,18 +162,17 @@ let dispatch_buy () = in let%bind () = let%bind amount = - trace_option (simple_error "getting amount for run") @@ + trace_option (test_internal "getting amount for run") @@ Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount ~sender:second_contract () in expect_eq_n_pos_small ~options program "main" make_input make_expected in let%bind () = let%bind amount = - trace_option (simple_error "getting amount for run") @@ + trace_option (test_internal "getting amount for run") @@ Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount ~sender:second_contract () in - trace_strong (simple_error "could buy without money") @@ - Assert.assert_fail - @@ expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in + Assert.assert_fail (test_internal "could buy without money") @@ + expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in ok () in ok () @@ -220,16 +219,19 @@ let sell () = let storage = basic 100 1000 cards (2 * n) in e_pair sell_action storage in - let make_expecter : int -> Ast_core.expression -> unit result = fun n result -> - let%bind (ops , storage) = Ast_core.get_e_pair result.expression_content in + let make_expecter : int -> Ast_core.expression -> (unit,_) result = fun n result -> + let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ + Ast_core.get_e_pair result.expression_content in let%bind () = - let%bind lst = Ast_core.get_e_list ops.expression_content in - Assert.assert_list_size lst 1 in + let%bind lst = trace_option (test_internal __LOC__) @@ + Ast_core.get_e_list ops.expression_content in + Assert.assert_list_size (test_internal __LOC__) lst 1 in let expected_storage = let cards = List.hds @@ cards_ez first_owner n in basic 99 1000 cards (2 * n) in let%bind expected_storage = Test_helpers.expression_to_core expected_storage in - Ast_core.Misc.assert_value_eq (expected_storage , storage) + trace_option (test_internal __LOC__) @@ + Ast_core.Misc.assert_value_eq (expected_storage , storage) in let%bind () = let amount = Memory_proto_alpha.Protocol.Alpha_context.Tez.zero in diff --git a/src/test/hash_lock_tests.ml b/src/test/hash_lock_tests.ml index b7bbe7bf1..ba8221e1f 100644 --- a/src/test/hash_lock_tests.ml +++ b/src/test/hash_lock_tests.ml @@ -1,6 +1,7 @@ open Trace open Test_helpers open Ast_imperative +open Main_errors let type_file f = let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" (Contract "main") in @@ -29,7 +30,7 @@ let call msg = e_constructor "Call" msg let mk_time st = match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with | Some s -> ok s - | None -> simple_fail "bad timestamp notation" + | None -> fail @@ test_internal "bad timestamp notation" let to_sec t = Tezos_utils.Time.Protocol.to_seconds t let storage hashed used commits = e_record_ez [("hashed", hashed); diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 04c31d577..e9d283458 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1,5 +1,6 @@ open Trace open Test_helpers +open Main_errors open Ast_imperative.Combinators @@ -10,16 +11,16 @@ let mtype_file f = let type_file f = Ligo.Compile.Utils.type_file f "pascaligo" Env -let type_alias () : unit result = +let type_alias () : (unit,_) result = let%bind program = type_file "./contracts/type-alias.ligo" in expect_eq_evaluate program "foo" (e_int 23) -let function_ () : unit result = +let function_ () : (unit,_) result = let%bind program = type_file "./contracts/function.ligo" in let make_expect = fun n -> n in expect_eq_n_int program "main" make_expect -let blockless () : unit result = +let blockless () : (unit,_) result = let%bind program = type_file "./contracts/blockless.ligo" in let make_expect = fun n-> n + 10 in expect_eq_n_int program "blockless" make_expect @@ -30,12 +31,12 @@ let blockless () : unit result = let make_expect = fun n -> n + 1 in expect_eq_n_int program "main" make_expect *) -let assign () : unit result = +let assign () : (unit,_) result = let%bind program = type_file "./contracts/assign.ligo" in let make_expect = fun n -> n + 1 in expect_eq_n_int program "main" make_expect -let annotation () : unit result = +let annotation () : (unit,_) result = let%bind program = type_file "./contracts/annotation.ligo" in let%bind () = expect_eq_evaluate program "lst" (e_list []) @@ -45,19 +46,19 @@ let annotation () : unit result = in ok () -let complex_function () : unit result = +let complex_function () : (unit,_) result = let%bind program = type_file "./contracts/function-complex.ligo" in let make_expect = fun n -> (3 * n + 2) in expect_eq_n_int program "main" make_expect -let anon_function () : unit result = +let anon_function () : (unit, _) result = let%bind program = type_file "./contracts/function-anon.ligo" in let%bind () = expect_eq_evaluate program "x" (e_int 42) in ok () -let application () : unit result = +let application () : (unit, _) result = let%bind program = type_file "./contracts/application.ligo" in let%bind () = let expected = e_int 42 in @@ -70,7 +71,7 @@ let application () : unit result = expect_eq_evaluate program "z" expected in ok () -let variant () : unit result = +let variant () : (unit, _) result = let%bind program = type_file "./contracts/variant.ligo" in let%bind () = let expected = e_constructor "Foo" (e_int 42) in @@ -83,7 +84,7 @@ let variant () : unit result = expect_eq_evaluate program "kee" expected in ok () -let variant_mligo () : unit result = +let variant_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/variant.mligo" in let%bind () = let expected = e_constructor "Foo" (e_int 42) in @@ -96,7 +97,7 @@ let variant_mligo () : unit result = expect_eq_evaluate program "kee" expected in ok () -let variant_religo () : unit result = +let variant_religo () : (unit, _) result = let%bind program = retype_file "./contracts/variant.religo" in let%bind () = let expected = e_constructor "Foo" (e_int 42) in @@ -110,7 +111,7 @@ let variant_religo () : unit result = ok () -let variant_matching () : unit result = +let variant_matching () : (unit, _) result = let%bind program = type_file "./contracts/variant-matching.ligo" in let%bind () = let make_input = fun n -> e_constructor "Foo" (e_int n) in @@ -123,7 +124,7 @@ let variant_matching () : unit result = in ok () -let closure () : unit result = +let closure () : (unit, _) result = let%bind program = type_file "./contracts/closure.ligo" in let%bind program_1 = type_file "./contracts/closure-1.ligo" in let%bind program_2 = type_file "./contracts/closure-2.ligo" in @@ -146,7 +147,7 @@ let closure () : unit result = in ok () -let closure_mligo () : unit result = +let closure_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/closure.mligo" in let%bind _ = let input = e_int 0 in @@ -155,7 +156,7 @@ let closure_mligo () : unit result = in ok () -let closure_religo () : unit result = +let closure_religo () : (unit, _) result = let%bind program = retype_file "./contracts/closure.religo" in let%bind _ = let input = e_int 0 in @@ -165,12 +166,12 @@ let closure_religo () : unit result = ok () -let shadow () : unit result = +let shadow () : (unit, _) result = let%bind program = type_file "./contracts/shadow.ligo" in let make_expect = fun _ -> 0 in expect_eq_n_int program "foo" make_expect -let higher_order () : unit result = +let higher_order () : (unit, _) result = let%bind program = type_file "./contracts/high-order.ligo" in let make_expect = fun n -> n in let%bind _ = expect_eq_n_int program "foobar" make_expect in @@ -181,7 +182,7 @@ let higher_order () : unit result = (* let%bind _ = applies_expect_eq_n_int program "foobar5" make_expect in *) ok () -let higher_order_mligo () : unit result = +let higher_order_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/high-order.mligo" in let make_expect = fun n -> n in let%bind _ = expect_eq_n_int program "foobar" make_expect in @@ -191,7 +192,7 @@ let higher_order_mligo () : unit result = let%bind _ = expect_eq_n_int program "foobar5" make_expect in ok () -let higher_order_religo () : unit result = +let higher_order_religo () : (unit, _) result = let%bind program = retype_file "./contracts/high-order.religo" in let make_expect = fun n -> n in let%bind _ = expect_eq_n_int program "foobar" make_expect in @@ -201,7 +202,7 @@ let higher_order_religo () : unit result = let%bind _ = expect_eq_n_int program "foobar5" make_expect in ok () -let shared_function () : unit result = +let shared_function () : (unit, _) result = let%bind program = type_file "./contracts/function-shared.ligo" in let%bind () = let make_expect = fun n -> (n + 1) in @@ -224,7 +225,7 @@ let shared_function () : unit result = in ok () -let shared_function_mligo () : unit result = +let shared_function_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/function-shared.mligo" in let%bind () = let make_expect = fun n -> (2 * n + 70) in @@ -232,7 +233,7 @@ let shared_function_mligo () : unit result = in ok () -let shared_function_religo () : unit result = +let shared_function_religo () : (unit, _) result = let%bind program = retype_file "./contracts/function-shared.religo" in let%bind () = let make_expect = fun n -> (2 * n + 70) in @@ -240,7 +241,7 @@ let shared_function_religo () : unit result = in ok () -let bool_expression () : unit result = +let bool_expression () : (unit, _) result = let%bind program = type_file "./contracts/boolean_operators.ligo" in let%bind _ = let aux (name , f) = expect_eq_b_bool program name f in @@ -253,7 +254,7 @@ let bool_expression () : unit result = ] in ok () -let bool_expression_mligo () : unit result = +let bool_expression_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/boolean_operators.mligo" in let%bind _ = let aux (name, f) = expect_eq_b_bool program name f in @@ -266,7 +267,7 @@ let bool_expression_mligo () : unit result = ] in ok () -let bool_expression_religo () : unit result = +let bool_expression_religo () : (unit, _) result = let%bind program = retype_file "./contracts/boolean_operators.religo" in let%bind _ = let aux (name, f) = expect_eq_b_bool program name f in @@ -279,7 +280,7 @@ let bool_expression_religo () : unit result = ] in ok () -let arithmetic () : unit result = +let arithmetic () : (unit, _) result = let%bind program = type_file "./contracts/arithmetic.ligo" in let%bind _ = let aux (name , f) = expect_eq_n_int program name f in @@ -295,7 +296,7 @@ let arithmetic () : unit result = let%bind () = expect_eq_n_pos program "ediv_op" e_int (fun n -> e_some (e_pair (e_int (n/2)) (e_nat (n mod 2)))) in ok () -let arithmetic_mligo () : unit result = +let arithmetic_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/arithmetic.mligo" in let%bind _ = let aux (name, f) = expect_eq_n_int program name f in @@ -311,7 +312,7 @@ let arithmetic_mligo () : unit result = let%bind () = expect_eq_n_pos program "ediv_op" e_int (fun n -> e_some (e_pair (e_int (n/2)) (e_nat (n mod 2)))) in ok () -let arithmetic_religo () : unit result = +let arithmetic_religo () : (unit, _) result = let%bind program = retype_file "./contracts/arithmetic.religo" in let%bind _ = let aux (name, f) = expect_eq_n_int program name f in @@ -327,7 +328,7 @@ let arithmetic_religo () : unit result = let%bind () = expect_eq_n_pos program "ediv_op" e_int (fun n -> e_some (e_pair (e_int (n/2)) (e_nat (n mod 2)))) in ok () -let bitwise_arithmetic () : unit result = +let bitwise_arithmetic () : (unit, _) result = let%bind program = type_file "./contracts/bitwise_arithmetic.ligo" in let%bind () = expect_eq program "or_op" (e_nat 7) (e_nat 7) in let%bind () = expect_eq program "or_op" (e_nat 3) (e_nat 7) in @@ -345,7 +346,7 @@ let bitwise_arithmetic () : unit result = let%bind () = expect_eq program "lsr_op" (e_nat 128000) (e_nat 1000) in ok () -let bitwise_arithmetic_mligo () : unit result = +let bitwise_arithmetic_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/bitwise_arithmetic.mligo" in let%bind () = expect_eq program "or_op" (e_nat 7) (e_nat 7) in let%bind () = expect_eq program "or_op" (e_nat 3) (e_nat 7) in @@ -363,7 +364,7 @@ let bitwise_arithmetic_mligo () : unit result = let%bind () = expect_eq program "lsr_op" (e_nat 128000) (e_nat 1000) in ok () -let bitwise_arithmetic_religo () : unit result = +let bitwise_arithmetic_religo () : (unit, _) result = let%bind program = retype_file "./contracts/bitwise_arithmetic.religo" in let%bind () = expect_eq program "or_op" (e_nat 7) (e_nat 7) in let%bind () = expect_eq program "or_op" (e_nat 3) (e_nat 7) in @@ -381,7 +382,7 @@ let bitwise_arithmetic_religo () : unit result = let%bind () = expect_eq program "lsr_op" (e_nat 128000) (e_nat 1000) in ok () -let string_arithmetic () : unit result = +let string_arithmetic () : (unit, _) result = let%bind program = type_file "./contracts/string_arithmetic.ligo" in let%bind () = expect_eq program "concat_op" (e_string "foo") (e_string "foototo") in let%bind () = expect_eq program "concat_op" (e_string "") (e_string "toto") in @@ -390,7 +391,7 @@ let string_arithmetic () : unit result = let%bind () = expect_fail program "slice_op" (e_string "ba") in ok () -let string_arithmetic_mligo () : unit result = +let string_arithmetic_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/string_arithmetic.mligo" in let%bind () = expect_eq program "size_op" (e_string "tata") (e_nat 4) in let%bind () = expect_eq program "slice_op" (e_string "tata") (e_string "at") in @@ -398,7 +399,7 @@ let string_arithmetic_mligo () : unit result = let%bind () = expect_eq program "concat_syntax" (e_string "string_") (e_string "string_test_literal") in ok () -let string_arithmetic_religo () : unit result = +let string_arithmetic_religo () : (unit, _) result = let%bind program = retype_file "./contracts/string_arithmetic.religo" in let%bind () = expect_eq program "size_op" (e_string "tata") (e_nat 4) in let%bind () = expect_eq program "slice_op" (e_string "tata") (e_string "at") in @@ -407,15 +408,15 @@ let string_arithmetic_religo () : unit result = in ok () -let bytes_arithmetic () : unit result = +let bytes_arithmetic () : (unit, _) result = let%bind program = type_file "./contracts/bytes_arithmetic.ligo" in - let%bind foo = e_bytes_hex "0f00" in - let%bind foototo = e_bytes_hex "0f007070" in - let%bind toto = e_bytes_hex "7070" in - let%bind empty = e_bytes_hex "" in - let%bind tata = e_bytes_hex "ff7a7aff" in - let%bind at = e_bytes_hex "7a7a" in - let%bind ba = e_bytes_hex "ba" in + let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in + let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in + let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex "7070" in + let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex "" in + let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex "ff7a7aff" in + let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex "7a7a" in + let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex "ba" in let%bind () = expect_eq program "concat_op" foo foototo in let%bind () = expect_eq program "concat_op" empty toto in let%bind () = expect_eq program "slice_op" tata at in @@ -424,10 +425,10 @@ let bytes_arithmetic () : unit result = let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman" foo in let%bind () = expect_eq_core program "hasherman" foo b1 in let%bind b3 = Test_helpers.run_typed_program_with_imperative_input program "hasherman" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b3 , b1) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b3 , b1) in ok () -let comparable_mligo () : unit result = +let comparable_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/comparable.mligo" in let%bind () = expect_eq program "int_" (e_int 1) (e_bool false) in let%bind () = expect_eq program "nat_" (e_nat 1) (e_bool false) in @@ -451,57 +452,57 @@ let comparable_mligo () : unit result = let%bind () = expect_eq program "comb_record" comb (e_bool false) in ok () -let crypto () : unit result = +let crypto () : (unit, _) result = let%bind program = type_file "./contracts/crypto.ligo" in - let%bind foo = e_bytes_hex "0f00" in - let%bind foototo = e_bytes_hex "0f007070" in + let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in + let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foo in let%bind () = expect_eq_core program "hasherman512" foo b1 in let%bind b2 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b2 , b1) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b2 , b1) in let%bind b4 = Test_helpers.run_typed_program_with_imperative_input program "hasherman_blake" foo in let%bind () = expect_eq_core program "hasherman_blake" foo b4 in let%bind b5 = Test_helpers.run_typed_program_with_imperative_input program "hasherman_blake" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b5 , b4) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b5 , b4) in ok () -let crypto_mligo () : unit result = +let crypto_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/crypto.mligo" in - let%bind foo = e_bytes_hex "0f00" in - let%bind foototo = e_bytes_hex "0f007070" in + let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in + let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foo in let%bind () = expect_eq_core program "hasherman512" foo b1 in let%bind b2 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b2 , b1) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b2 , b1) in let%bind b4 = Test_helpers.run_typed_program_with_imperative_input program "hasherman_blake" foo in let%bind () = expect_eq_core program "hasherman_blake" foo b4 in let%bind b5 = Test_helpers.run_typed_program_with_imperative_input program "hasherman_blake" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b5 , b4) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b5 , b4) in ok () -let crypto_religo () : unit result = +let crypto_religo () : (unit, _) result = let%bind program = retype_file "./contracts/crypto.religo" in - let%bind foo = e_bytes_hex "0f00" in - let%bind foototo = e_bytes_hex "0f007070" in + let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in + let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foo in let%bind () = expect_eq_core program "hasherman512" foo b1 in let%bind b2 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b2 , b1) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b2 , b1) in let%bind b4 = Test_helpers.run_typed_program_with_imperative_input program "hasherman_blake" foo in let%bind () = expect_eq_core program "hasherman_blake" foo b4 in let%bind b5 = Test_helpers.run_typed_program_with_imperative_input program "hasherman_blake" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b5 , b4) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b5 , b4) in ok () -let bytes_arithmetic_mligo () : unit result = +let bytes_arithmetic_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/bytes_arithmetic.mligo" in - let%bind foo = e_bytes_hex "0f00" in - let%bind foototo = e_bytes_hex "0f007070" in - let%bind toto = e_bytes_hex "7070" in - let%bind empty = e_bytes_hex "" in - let%bind tata = e_bytes_hex "ff7a7aff" in - let%bind at = e_bytes_hex "7a7a" in - let%bind ba = e_bytes_hex "ba" in + let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in + let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in + let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex "7070" in + let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex "" in + let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex "ff7a7aff" in + let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex "7a7a" in + let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex "ba" in let%bind () = expect_eq program "concat_op" foo foototo in let%bind () = expect_eq program "concat_op" empty toto in let%bind () = expect_eq program "slice_op" tata at in @@ -510,18 +511,18 @@ let bytes_arithmetic_mligo () : unit result = let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman" foo in let%bind () = expect_eq_core program "hasherman" foo b1 in let%bind b3 = Test_helpers.run_typed_program_with_imperative_input program "hasherman" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b3 , b1) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b3 , b1) in ok () -let bytes_arithmetic_religo () : unit result = +let bytes_arithmetic_religo () : (unit, _) result = let%bind program = retype_file "./contracts/bytes_arithmetic.religo" in - let%bind foo = e_bytes_hex "0f00" in - let%bind foototo = e_bytes_hex "0f007070" in - let%bind toto = e_bytes_hex "7070" in - let%bind empty = e_bytes_hex "" in - let%bind tata = e_bytes_hex "ff7a7aff" in - let%bind at = e_bytes_hex "7a7a" in - let%bind ba = e_bytes_hex "ba" in + let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in + let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in + let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex "7070" in + let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex "" in + let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex "ff7a7aff" in + let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex "7a7a" in + let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex "ba" in let%bind () = expect_eq program "concat_op" foo foototo in let%bind () = expect_eq program "concat_op" empty toto in let%bind () = expect_eq program "slice_op" tata at in @@ -530,10 +531,10 @@ let bytes_arithmetic_religo () : unit result = let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program"hasherman" foo in let%bind () = expect_eq_core program "hasherman" foo b1 in let%bind b3 = Test_helpers.run_typed_program_with_imperative_input program "hasherman" foototo in - let%bind () = Assert.assert_fail @@ Ast_core.Misc.assert_value_eq (b3 , b1) in + let%bind () = trace_assert_fail_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (b3 , b1) in ok () -let set_arithmetic () : unit result = +let set_arithmetic () : (unit, _) result = let%bind program = type_file "./contracts/set_arithmetic.ligo" in let%bind program_1 = type_file "./contracts/set_arithmetic-1.ligo" in let%bind () = @@ -596,7 +597,7 @@ let set_arithmetic () : unit result = in ok () -let set_arithmetic_mligo () : unit result = +let set_arithmetic_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/set_arithmetic.mligo" in let%bind program_1 = type_file "./contracts/set_arithmetic-1.ligo" in let%bind () = @@ -631,7 +632,7 @@ let set_arithmetic_mligo () : unit result = in ok () -let set_arithmetic_religo () : unit result = +let set_arithmetic_religo () : (unit, _) result = let%bind program = retype_file "./contracts/set_arithmetic.religo" in let%bind program_1 = type_file "./contracts/set_arithmetic-1.ligo" in let%bind () = @@ -666,24 +667,24 @@ let set_arithmetic_religo () : unit result = in ok () -let unit_expression () : unit result = +let unit_expression () : (unit, _) result = let%bind program = type_file "./contracts/unit.ligo" in expect_eq_evaluate program "u" (e_unit ()) -let string_expression () : unit result = +let string_expression () : (unit, _) result = let%bind program = type_file "./contracts/string.ligo" in let%bind _ = expect_eq_evaluate program "s" (e_string "toto") in expect_eq_evaluate program "y" (e_string "foototobar") -let include_ () : unit result = +let include_ () : (unit, _) result = let%bind program = type_file "./contracts/includer.ligo" in expect_eq_evaluate program "bar" (e_int 144) -let include_mligo () : unit result = +let include_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/includer.mligo" in expect_eq_evaluate program "bar" (e_int 144) -let include_religo () : unit result = +let include_religo () : (unit, _) result = let%bind program = retype_file "./contracts/includer.religo" in expect_eq_evaluate program "bar" (e_int 144) @@ -693,7 +694,7 @@ let record_ez_int names n = let tuple_ez_int names n = e_tuple @@ List.map (fun _ -> e_int n) names -let multiple_parameters () : unit result = +let multiple_parameters () : (unit, _) result = let%bind program = type_file "./contracts/multiple-parameters.ligo" in let aux ((name : string) , make_input , make_output) = let make_output' = fun n -> e_int @@ make_output n in @@ -706,7 +707,7 @@ let multiple_parameters () : unit result = ] in ok () -let multiple_parameters_mligo () : unit result = +let multiple_parameters_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/multiple-parameters.mligo" in let aux ((name : string) , make_input , make_output) = let make_output' = fun n -> e_int @@ make_output n in @@ -718,7 +719,7 @@ let multiple_parameters_mligo () : unit result = ] in ok () -let multiple_parameters_religo () : unit result = +let multiple_parameters_religo () : (unit, _) result = let%bind program = retype_file "./contracts/multiple-parameters.religo" in let aux ((name : string) , make_input , make_output) = let make_output' = fun n -> e_int @@ make_output n in @@ -730,7 +731,7 @@ let multiple_parameters_religo () : unit result = ] in ok () -let record () : unit result = +let record () : (unit, _) result = let%bind program = type_file "./contracts/record.ligo" in let%bind () = let expected = record_ez_int ["foo" ; "bar"] 0 in @@ -776,7 +777,7 @@ let record () : unit result = in ok () -let record_mligo () : unit result = +let record_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/record.mligo" in let%bind () = let expected = record_ez_int ["foo" ; "bar"] 0 in @@ -822,7 +823,7 @@ let record_mligo () : unit result = in ok () -let record_religo () : unit result = +let record_religo () : (unit, _) result = let%bind program = retype_file "./contracts/record.religo" in let%bind () = let expected = record_ez_int ["foo" ; "bar"] 0 in @@ -868,7 +869,7 @@ let record_religo () : unit result = in ok () -let tuple () : unit result = +let tuple () : (unit, _) result = let%bind program = type_file "./contracts/tuple.ligo" in let ez n = e_tuple (List.map e_int n) in @@ -907,7 +908,7 @@ let tuple () : unit result = in ok () -let tuple_mligo () : unit result = +let tuple_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/tuple.mligo" in let ez n = e_tuple (List.map e_int n) in @@ -932,7 +933,7 @@ let tuple_mligo () : unit result = ok () -let tuple_religo () : unit result = +let tuple_religo () : (unit, _) result = let%bind program = retype_file "./contracts/tuple.religo" in let ez n = e_tuple (List.map e_int n) in @@ -956,7 +957,7 @@ let tuple_religo () : unit result = in ok () -let option () : unit result = +let option () : (unit, _) result = let%bind program = type_file "./contracts/option.ligo" in let%bind () = let expected = e_some (e_int 42) in @@ -972,7 +973,7 @@ let option () : unit result = in ok () -let moption () : unit result = +let moption () : (unit, _) result = let%bind program = mtype_file "./contracts/option.mligo" in let%bind () = let expected = e_some (e_int 42) in @@ -984,7 +985,7 @@ let moption () : unit result = in ok () -let reoption () : unit result = +let reoption () : (unit, _) result = let%bind program = retype_file "./contracts/option.religo" in let%bind () = let expected = e_some (e_int 42) in @@ -997,7 +998,7 @@ let reoption () : unit result = ok () -let map_ type_f path : unit result = +let map_ type_f path : (unit, _) result = let%bind program = type_f path in let ez lst = let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in @@ -1085,7 +1086,7 @@ let map_ type_f path : unit result = in ok () -let big_map_ type_f path : unit result = +let big_map_ type_f path : (unit, _) result = let%bind program = type_f path in let ez lst = let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in @@ -1117,15 +1118,15 @@ let big_map_ type_f path : unit result = ok () -let map () : unit result = map_ type_file "./contracts/map.ligo" -let mmap () : unit result = map_ mtype_file "./contracts/map.mligo" -let remap () : unit result = map_ retype_file "./contracts/map.religo" -let big_map () : unit result = big_map_ type_file "./contracts/big_map.ligo" -let mbig_map () : unit result = big_map_ mtype_file "./contracts/big_map.mligo" -let rebig_map () : unit result = big_map_ retype_file "./contracts/big_map.religo" +let map () : (unit, _) result = map_ type_file "./contracts/map.ligo" +let mmap () : (unit, _) result = map_ mtype_file "./contracts/map.mligo" +let remap () : (unit, _) result = map_ retype_file "./contracts/map.religo" +let big_map () : (unit, _) result = big_map_ type_file "./contracts/big_map.ligo" +let mbig_map () : (unit, _) result = big_map_ mtype_file "./contracts/big_map.mligo" +let rebig_map () : (unit, _) result = big_map_ retype_file "./contracts/big_map.religo" -let list () : unit result = +let list () : (unit, _) result = let%bind program = type_file "./contracts/list.ligo" in let ez lst = let lst' = List.map e_int lst in @@ -1169,7 +1170,7 @@ let list () : unit result = in ok () -let condition () : unit result = +let condition () : (unit, _) result = let%bind program = type_file "./contracts/condition.ligo" in let%bind _ = let make_input = e_int in @@ -1182,7 +1183,7 @@ let condition () : unit result = in ok () -let condition_mligo () : unit result = +let condition_mligo () : (unit, _) result = let%bind _ = let aux file = let%bind program = mtype_file file in @@ -1196,7 +1197,7 @@ let condition_mligo () : unit result = ] in ok () -let condition_religo () : unit result = +let condition_religo () : (unit, _) result = let%bind _ = let aux file = let%bind program = retype_file file in @@ -1210,7 +1211,7 @@ let condition_religo () : unit result = ] in ok () -let sequence_mligo () : unit result = +let sequence_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/sequence.mligo" in expect_eq program "y" (e_unit ()) (e_nat 1) @@ -1227,25 +1228,25 @@ let eq_bool_common program = in ok () -let eq_bool () : unit result = +let eq_bool () : (unit, _) result = let%bind program = type_file "./contracts/eq_bool.ligo" in eq_bool_common program -let eq_bool_mligo () : unit result = +let eq_bool_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/eq_bool.mligo" in eq_bool_common program -let eq_bool_religo () : unit result = +let eq_bool_religo () : (unit, _) result = let%bind program = retype_file "./contracts/eq_bool.religo" in eq_bool_common program -let condition_simple () : unit result = +let condition_simple () : (unit, _) result = let%bind program = type_file "./contracts/condition-simple.ligo" in let make_input = e_int in let make_expected = fun _ -> e_int 42 in expect_eq_n program "main" make_input make_expected -let loop () : unit result = +let loop () : (unit, _) result = let%bind program = type_file "./contracts/loop.ligo" in let%bind () = let make_input = e_nat in @@ -1316,12 +1317,12 @@ let loop () : unit result = ok () (* Don't know how to assert parse error happens in this test framework -let for_fail () : unit result = +let for_fail () : (unit, _) result = let%bind program = type_file "./contracts/for_fail.ligo" in let%bind () = expect_fail program "main" (e_nat 0) in ok () *) -let loop_mligo () : unit result = +let loop_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/loop.mligo" in let%bind () = let input = e_int 0 in @@ -1339,7 +1340,7 @@ let loop_mligo () : unit result = expect_eq program "counter_nest" input expected in ok () -let loop_religo () : unit result = +let loop_religo () : (unit, _) result = let%bind program = retype_file "./contracts/loop.religo" in let%bind () = let input = e_int 0 in @@ -1358,7 +1359,7 @@ let loop_religo () : unit result = in ok () -let matching () : unit result = +let matching () : (unit, _) result = let%bind program = type_file "./contracts/match.ligo" in let%bind () = let make_input = e_int in @@ -1378,7 +1379,6 @@ let matching () : unit result = let expected = e_int (match n with | Some s -> s | None -> 23) in - trace (simple_error (Format.asprintf "on input %a" PP_helpers.(option int) n)) @@ expect_eq program "match_option" input expected in bind_iter_list aux @@ -1392,7 +1392,6 @@ let matching () : unit result = let expected = e_int (match n with | Some s -> s | None -> 42) in - trace (simple_error (Format.asprintf "on input %a" PP_helpers.(option int) n)) @@ expect_eq program "match_expr_option" input expected in bind_iter_list aux @@ -1407,38 +1406,38 @@ let matching () : unit result = in ok () -let declarations () : unit result = +let declarations () : (unit, _) result = let%bind program = type_file "./contracts/declarations.ligo" in let make_input = e_int in let make_expected = fun n -> e_int (42 + n) in expect_eq program "main" (make_input 0) (make_expected 0) >>? fun () -> expect_eq_n program "main" make_input make_expected -let declaration_local () : unit result = +let declaration_local () : (unit, _) result = let%bind program = type_file "./contracts/declaration-local.ligo" in let make_input = e_int in let make_expected = fun _ -> e_int 42 in expect_eq_n program "main" make_input make_expected -let quote_declaration () : unit result = +let quote_declaration () : (unit, _) result = let%bind program = type_file "./contracts/quote-declaration.ligo" in let make_input = e_int in let make_expected = fun n -> e_int (42 + 2 * n) in expect_eq_n program "main" make_input make_expected -let quote_declarations () : unit result = +let quote_declarations () : (unit, _) result = let%bind program = type_file "./contracts/quote-declarations.ligo" in let make_input = e_int in let make_expected = fun n -> e_int (74 + 2 * n) in expect_eq_n program "main" make_input make_expected -let counter_contract () : unit result = +let counter_contract () : (unit, _) result = let%bind program = type_file "./contracts/counter.ligo" in let make_input = fun n-> e_pair (e_int n) (e_int 42) in let make_expected = fun n -> e_pair (e_typed_list [] (t_operation ())) (e_int (42 + n)) in expect_eq_n program "main" make_input make_expected -let super_counter_contract () : unit result = +let super_counter_contract () : (unit, _) result = let%bind program = type_file "./contracts/super-counter.ligo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1448,7 +1447,7 @@ let super_counter_contract () : unit result = e_pair (e_typed_list [] (t_operation ())) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected -let super_counter_contract_mligo () : unit result = +let super_counter_contract_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/super-counter.mligo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1458,7 +1457,7 @@ let super_counter_contract_mligo () : unit result = e_pair (e_typed_list [] (t_operation ())) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected -let super_counter_contract_religo () : unit result = +let super_counter_contract_religo () : (unit, _) result = let%bind program = retype_file "./contracts/super-counter.religo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1469,7 +1468,7 @@ let super_counter_contract_religo () : unit result = expect_eq_n program "main" make_input make_expected -let dispatch_counter_contract () : unit result = +let dispatch_counter_contract () : (unit, _) result = let%bind program = type_file "./contracts/dispatch-counter.ligo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1479,7 +1478,7 @@ let dispatch_counter_contract () : unit result = e_pair (e_typed_list [] (t_operation())) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected -let failwith_ligo () : unit result = +let failwith_ligo () : (unit, _) result = let%bind program = type_file "./contracts/failwith.ligo" in let should_fail = expect_fail program "main" in let should_work input = expect_eq program "main" input (e_pair (e_typed_list [] (t_operation())) (e_unit ())) in @@ -1494,17 +1493,17 @@ let failwith_ligo () : unit result = let%bind () = should_work 5 6 in ok () -let failwith_mligo () : unit result = +let failwith_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/failwith.mligo" in let make_input = e_pair (e_unit ()) (e_unit ()) in expect_fail program "main" make_input -let failwith_religo () : unit result = +let failwith_religo () : (unit, _) result = let%bind program = retype_file "./contracts/failwith.religo" in let make_input = e_pair (e_unit ()) (e_unit ()) in expect_fail program "main" make_input -let assert_mligo () : unit result = +let assert_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/assert.mligo" in let make_input b = e_pair (e_bool b) (e_unit ()) in let make_expected = e_pair (e_typed_list [] (t_operation())) (e_unit ()) in @@ -1512,7 +1511,7 @@ let assert_mligo () : unit result = let%bind _ = expect_eq program "main" (make_input true) make_expected in ok () -let assert_religo () : unit result = +let assert_religo () : (unit, _) result = let%bind program = retype_file "./contracts/assert.religo" in let make_input b = e_pair (e_bool b) (e_unit ()) in let make_expected = e_pair (e_typed_list [] (t_operation())) (e_unit ()) in @@ -1520,7 +1519,7 @@ let assert_religo () : unit result = let%bind _ = expect_eq program "main" (make_input true) make_expected in ok () -let recursion_ligo () : unit result = +let recursion_ligo () : (unit, _) result = let%bind program = type_file "./contracts/recursion.ligo" in let%bind _ = let make_input = e_pair (e_int 10) (e_int 0) in @@ -1534,7 +1533,7 @@ let recursion_ligo () : unit result = in ok () -let recursion_mligo () : unit result = +let recursion_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/recursion.mligo" in let%bind _ = let make_input = e_pair (e_int 10) (e_int 0) in @@ -1547,7 +1546,7 @@ let recursion_mligo () : unit result = expect_eq program "fibo" make_input make_expected in ok () -let recursion_religo () : unit result = +let recursion_religo () : (unit, _) result = let%bind program = retype_file "./contracts/recursion.religo" in let%bind _ = let make_input = e_pair (e_int 10) (e_int 0) in @@ -1560,34 +1559,34 @@ let recursion_religo () : unit result = expect_eq program "fibo" make_input make_expected in ok () -let guess_string_mligo () : unit result = +let guess_string_mligo () : (unit, _) result = let%bind program = type_file "./contracts/guess_string.mligo" in let make_input = fun n -> e_pair (e_int n) (e_int 42) in let make_expected = fun n -> e_pair (e_typed_list [] (t_operation())) (e_int (42 + n)) in expect_eq_n program "main" make_input make_expected -let basic_mligo () : unit result = +let basic_mligo () : (unit, _) result = let%bind typed = mtype_file "./contracts/basic.mligo" in expect_eq_evaluate typed "foo" (e_int (42+127)) -let basic_religo () : unit result = +let basic_religo () : (unit, _) result = let%bind typed = retype_file "./contracts/basic.religo" in expect_eq_evaluate typed "foo" (e_int (42+127)) -let counter_mligo () : unit result = +let counter_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/counter.mligo" in let make_input n = e_pair (e_int n) (e_int 42) in let make_expected n = e_pair (e_typed_list [] (t_operation ())) (e_int (42 + n)) in expect_eq_n program "main" make_input make_expected -let counter_religo () : unit result = +let counter_religo () : (unit, _) result = let%bind program = retype_file "./contracts/counter.religo" in let make_input n = e_pair (e_int n) (e_int 42) in let make_expected n = e_pair (e_typed_list [] (t_operation ())) (e_int (42 + n)) in expect_eq_n program "main" make_input make_expected -let let_in_mligo () : unit result = +let let_in_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/letin.mligo" in let%bind () = let make_input n = e_pair (e_int n) (e_pair (e_int 3) (e_int 5)) in @@ -1604,7 +1603,7 @@ let let_in_mligo () : unit result = in ok () -let let_in_religo () : unit result = +let let_in_religo () : (unit, _) result = let%bind program = retype_file "./contracts/letin.religo" in let%bind () = let make_input n = e_pair (e_int n) (e_pair (e_int 3) (e_int 5)) in @@ -1621,7 +1620,7 @@ let let_in_religo () : unit result = in ok () -let match_variant () : unit result = +let match_variant () : (unit, _) result = let%bind program = mtype_file "./contracts/match.mligo" in let%bind () = let make_input n = @@ -1651,7 +1650,7 @@ let match_variant () : unit result = expect_eq_n program "match_option" make_input make_expected in ok () -let match_variant_re () : unit result = +let match_variant_re () : (unit, _) result = let%bind program = retype_file "./contracts/match.religo" in let make_input n = e_pair (e_constructor "Sub" (e_int n)) (e_int 3) in @@ -1660,7 +1659,7 @@ let match_variant_re () : unit result = in expect_eq_n program "main" make_input make_expected -let match_matej () : unit result = +let match_matej () : (unit, _) result = let%bind program = mtype_file "./contracts/match_bis.mligo" in let make_input n = e_pair (e_constructor "Decrement" (e_int n)) (e_int 3) in @@ -1668,7 +1667,7 @@ let match_matej () : unit result = e_pair (e_typed_list [] (t_operation ())) (e_int (3-n)) in expect_eq_n program "main" make_input make_expected -let match_matej_re () : unit result = +let match_matej_re () : (unit, _) result = let%bind program = retype_file "./contracts/match_bis.religo" in let make_input n = e_pair (e_constructor "Decrement" (e_int n)) (e_int 3) in @@ -1677,7 +1676,7 @@ let match_matej_re () : unit result = in expect_eq_n program "main" make_input make_expected -let mligo_list () : unit result = +let mligo_list () : (unit, _) result = let%bind program = mtype_file "./contracts/list.mligo" in let%bind () = expect_eq program "size_" (e_list [e_int 0; e_int 1; e_int 2]) (e_nat 3) in let aux lst = e_list @@ List.map e_int lst in @@ -1699,7 +1698,7 @@ let mligo_list () : unit result = let%bind () = expect_eq program "iter_op" (aux [2 ; 3 ; 4 ; 5]) (e_unit ()) in ok () -let religo_list () : unit result = +let religo_list () : (unit, _) result = let%bind program = retype_file "./contracts/list.religo" in let%bind () = expect_eq program "size_" (e_list [e_int 0; e_int 1; e_int 2]) (e_nat 3) in let aux lst = e_list @@ List.map e_int lst in @@ -1721,66 +1720,66 @@ let religo_list () : unit result = let%bind () = expect_eq program "iter_op" (aux [2 ; 3 ; 4 ; 5]) (e_unit ()) in ok () -let lambda_mligo () : unit result = +let lambda_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/lambda.mligo" in let make_input = e_pair (e_unit ()) (e_unit ()) in let make_expected = (e_unit ()) in expect_eq program "main" make_input make_expected -let lambda_religo () : unit result = +let lambda_religo () : (unit, _) result = let%bind program = retype_file "./contracts/lambda.religo" in let make_input = e_pair (e_unit ()) (e_unit ()) in let make_expected = (e_unit ()) in expect_eq program "main" make_input make_expected -let lambda_ligo () : unit result = +let lambda_ligo () : (unit, _) result = let%bind program = type_file "./contracts/lambda.ligo" in let make_input = e_pair (e_unit ()) (e_unit ()) in let make_expected = (e_unit ()) in expect_eq program "main" make_input make_expected -let lambda2_mligo () : unit result = +let lambda2_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/lambda2.mligo" in let make_input = e_pair (e_unit ()) (e_unit ()) in let make_expected = (e_unit ()) in expect_eq program "main" make_input make_expected -let lambda2_religo () : unit result = +let lambda2_religo () : (unit, _) result = let%bind program = retype_file "./contracts/lambda2.religo" in let make_input = e_pair (e_unit ()) (e_unit ()) in let make_expected = (e_unit ()) in expect_eq program "main" make_input make_expected -let fibo_mligo () : unit result = +let fibo_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/fibo.mligo" in let make_input = e_pair (e_unit ()) (e_unit ()) in let make_expected = (e_int 42) in expect_eq program "main" make_input make_expected -let michelson_insertion program : unit result = +let michelson_insertion program : (unit, _) result = let%bind program = program in let make_input = fun n -> e_pair (e_nat n) (e_nat 1) in let make_expected = fun n -> e_nat (n+1) in expect_eq_n_pos program "michelson_add" make_input make_expected -let michelson_insertion_ligo () : unit result = +let michelson_insertion_ligo () : (unit, _) result = michelson_insertion @@ type_file "./contracts/michelson_insertion.ligo" -let michelson_insertion_mligo () : unit result = +let michelson_insertion_mligo () : (unit, _) result = michelson_insertion @@ mtype_file "./contracts/michelson_insertion.mligo" -let michelson_insertion_religo () : unit result = +let michelson_insertion_religo () : (unit, _) result = michelson_insertion @@ retype_file "./contracts/michelson_insertion.religo" -let website1_ligo () : unit result = +let website1_ligo () : (unit, _) result = let%bind program = type_file "./contracts/website1.ligo" in let make_input = fun n-> e_pair (e_int n) (e_int 42) in let make_expected = fun _n -> e_pair (e_typed_list [] (t_operation ())) (e_int (42 + 1)) in expect_eq_n program "main" make_input make_expected -let website2_ligo () : unit result = +let website2_ligo () : (unit, _) result = let%bind program = type_file "./contracts/website2.ligo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1790,7 +1789,7 @@ let website2_ligo () : unit result = e_pair (e_typed_list [] (t_operation ())) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected -let tez_ligo () : unit result = +let tez_ligo () : (unit, _) result = let%bind program = type_file "./contracts/tez.ligo" in let%bind _ = expect_eq_evaluate program "add_tez" (e_mutez 42) in let%bind _ = expect_eq_evaluate program "sub_tez" (e_mutez 1) in @@ -1805,7 +1804,7 @@ let tez_ligo () : unit result = let%bind _ = expect_eq_evaluate program "tez_mod_tez3" (e_mutez 100) in ok () -let tez_mligo () : unit result = +let tez_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/tez.mligo" in let%bind _ = expect_eq_evaluate program "add_tez" (e_mutez 42) in let%bind _ = expect_eq_evaluate program "sub_tez" (e_mutez 1) in @@ -1813,7 +1812,7 @@ let tez_mligo () : unit result = let%bind _ = expect_eq_evaluate program "add_more_tez" (e_mutez 111111000) in ok () -let website2_mligo () : unit result = +let website2_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/website2.mligo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1823,7 +1822,7 @@ let website2_mligo () : unit result = e_pair (e_typed_list [] (t_operation ())) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected -let website2_religo () : unit result = +let website2_religo () : (unit, _) result = let%bind program = retype_file "./contracts/website2.religo" in let make_input = fun n -> let action = if n mod 2 = 0 then "Increment" else "Decrement" in @@ -1834,7 +1833,7 @@ let website2_religo () : unit result = expect_eq_n program "main" make_input make_expected -let mligo_let_multiple () : unit result = +let mligo_let_multiple () : (unit, _) result = let%bind program = mtype_file "./contracts/let_multiple.mligo" in let%bind () = let input = e_unit () in @@ -1868,7 +1867,7 @@ let mligo_let_multiple () : unit result = in ok () -let religo_let_multiple () : unit result = +let religo_let_multiple () : (unit, _) result = let%bind program = retype_file "./contracts/let_multiple.religo" in let%bind () = let input = e_unit () in @@ -1889,11 +1888,11 @@ let religo_let_multiple () : unit result = let balance_test_options () = - let%bind balance = trace_option (simple_error "could not convert balance") @@ + let%bind balance = trace_option (test_internal "could not convert balance") @@ Memory_proto_alpha.Protocol.Alpha_context.Tez.of_string "4000000" in ok @@ Proto_alpha_utils.Memory_proto_alpha.make_options ~balance () -let balance_constant () : unit result = +let balance_constant () : (unit, _) result = let%bind program = type_file "./contracts/balance_constant.ligo" in let input = e_tuple [e_unit () ; e_mutez 0] in let expected = e_tuple [e_list []; e_mutez 4000000000000] in @@ -1901,21 +1900,21 @@ let balance_constant () : unit result = expect_eq ~options program "main" input expected -let balance_constant_mligo () : unit result = +let balance_constant_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/balance_constant.mligo" in let input = e_tuple [e_unit () ; e_mutez 0] in let expected = e_tuple [e_list []; e_mutez 4000000000000] in let%bind options = balance_test_options () in expect_eq ~options program "main" input expected -let balance_constant_religo () : unit result = +let balance_constant_religo () : (unit, _) result = let%bind program = retype_file "./contracts/balance_constant.religo" in let input = e_tuple [e_unit () ; e_mutez 0] in let expected = e_tuple [e_list []; e_mutez 4000000000000] in let%bind options = balance_test_options () in expect_eq ~options program "main" input expected -let amount () : unit result = +let amount () : (unit, _) result = let%bind program = type_file "./contracts/amount.ligo" in let input = e_unit () in let expected = e_int 42 in @@ -1927,7 +1926,7 @@ let amount () : unit result = let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount () in expect_eq ~options program "check" input expected -let amount_mligo () : unit result = +let amount_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/amount.mligo" in let input = e_unit () in let expected = e_int 42 in @@ -1939,7 +1938,7 @@ let amount_mligo () : unit result = let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount () in expect_eq ~options program "check_" input expected -let amount_religo () : unit result = +let amount_religo () : (unit, _) result = let%bind program = retype_file "./contracts/amount.religo" in let input = e_unit () in let expected = e_int 42 in @@ -1960,49 +1959,49 @@ let addr_test program = (List.nth dummy_environment.identities 0).public_key_hash in expect_eq program "main" (e_key_hash key_hash) (e_address addr) -let address () : unit result = +let address () : (unit, _) result = let%bind program = type_file "./contracts/address.ligo" in addr_test program -let address_mligo () : unit result = +let address_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/address.mligo" in addr_test program -let address_religo () : unit result = +let address_religo () : (unit, _) result = let%bind program = retype_file "./contracts/address.religo" in addr_test program -let self_address () : unit result = +let self_address () : (unit, _) result = let%bind _ = type_file "./contracts/self_address.ligo" in ok () -let self_address_mligo () : unit result = +let self_address_mligo () : (unit, _) result = let%bind _ = mtype_file "./contracts/self_address.mligo" in ok () -let self_address_religo () : unit result = +let self_address_religo () : (unit, _) result = let%bind _ = retype_file "./contracts/self_address.religo" in ok () -let implicit_account () : unit result = +let implicit_account () : (unit, _) result = let%bind _ = type_file "./contracts/implicit_account.ligo" in ok () -let implicit_account_mligo () : unit result = +let implicit_account_mligo () : (unit, _) result = let%bind _ = mtype_file "./contracts/implicit_account.mligo" in ok () -let implicit_account_religo () : unit result = +let implicit_account_religo () : (unit, _) result = let%bind _ = retype_file "./contracts/implicit_account.religo" in ok () -let tuples_sequences_functions_religo () : unit result = +let tuples_sequences_functions_religo () : (unit, _) result = let%bind _ = retype_file "./contracts/tuples_sequences_functions.religo" in ok () -let is_nat () : unit result = +let is_nat () : (unit, _) result = let%bind program = type_file "./contracts/isnat.ligo" in let%bind () = let input = e_int 10 in @@ -2015,7 +2014,7 @@ let is_nat () : unit result = expect_eq program "main" input expected in ok () -let is_nat_mligo () : unit result = +let is_nat_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/isnat.mligo" in let%bind () = let input = e_int 10 in @@ -2028,7 +2027,7 @@ let is_nat_mligo () : unit result = expect_eq program "main" input expected in ok () -let is_nat_religo () : unit result = +let is_nat_religo () : (unit, _) result = let%bind program = retype_file "./contracts/isnat.religo" in let%bind () = let input = e_int 10 in @@ -2042,13 +2041,13 @@ let is_nat_religo () : unit result = in ok () -let simple_access_ligo () : unit result = +let simple_access_ligo () : (unit, _) result = let%bind program = type_file "./contracts/simple_access.ligo" in let make_input = e_tuple [e_int 0; e_int 1] in let make_expected = e_int 2 in expect_eq program "main" make_input make_expected -let deep_access_ligo () : unit result = +let deep_access_ligo () : (unit, _) result = let%bind program = type_file "./contracts/deep_access.ligo" in let%bind () = let make_input = e_unit () in @@ -2065,7 +2064,7 @@ let deep_access_ligo () : unit result = expect_eq program "nested_record" make_input make_expected in ok () -let attributes_ligo () : unit result = +let attributes_ligo () : (unit, _) result = let%bind program = type_file "./contracts/attributes.ligo" in let%bind () = let input = e_int 3 in @@ -2074,7 +2073,7 @@ let attributes_ligo () : unit result = in ok () -let attributes_mligo () : unit result = +let attributes_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/attributes.mligo" in let%bind () = let input = e_int 3 in @@ -2083,7 +2082,7 @@ let attributes_mligo () : unit result = in ok () -let attributes_religo () : unit result = +let attributes_religo () : (unit, _) result = let%bind program = retype_file "./contracts/attributes.religo" in let%bind () = let input = e_int 3 in @@ -2092,17 +2091,17 @@ let attributes_religo () : unit result = in ok () -let get_contract_ligo () : unit result = +let get_contract_ligo () : (unit, _) result = let%bind program = type_file "./contracts/get_contract.ligo" in let%bind () = let make_input = fun _n -> e_unit () in - let make_expected : int -> Ast_core.expression -> unit result = fun _n result -> - let%bind (ops , storage) = Ast_core.get_e_pair result.expression_content in + let make_expected : int -> Ast_core.expression -> (unit, _) result = fun _n result -> + let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.expression_content in let%bind () = - let%bind lst = Ast_core.get_e_list ops.expression_content in - Assert.assert_list_size lst 1 in + let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.expression_content in + Assert.assert_list_size (test_internal __LOC__) lst 1 in let expected_storage = Ast_core.e_unit () in - Ast_core.Misc.assert_value_eq (expected_storage , storage) + trace_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (expected_storage , storage) in let%bind () = let amount = Memory_proto_alpha.Protocol.Alpha_context.Tez.zero in @@ -2113,12 +2112,12 @@ let get_contract_ligo () : unit result = in ok() -let entrypoints_ligo () : unit result = +let entrypoints_ligo () : (unit, _) result = let%bind _program = type_file "./contracts/entrypoints.ligo" in (* hmm... *) ok () -let chain_id () : unit result = +let chain_id () : (unit, _) result = let%bind program = type_file "./contracts/chain_id.ligo" in let pouet = Tezos_crypto.Base58.simple_encode Tezos_base__TzPervasives.Chain_id.b58check_encoding @@ -2128,7 +2127,7 @@ let chain_id () : unit result = let%bind () = expect_eq program "chain_id" make_input make_expected in ok () -let key_hash () : unit result = +let key_hash () : (unit, _) result = let open Tezos_crypto in let (raw_pkh,raw_pk,_) = Signature.generate_key () in let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in @@ -2139,7 +2138,7 @@ let key_hash () : unit result = let%bind () = expect_eq program "check_hash_key" make_input make_expected in ok () -let key_hash_mligo () : unit result = +let key_hash_mligo () : (unit, _) result = let open Tezos_crypto in let (raw_pkh,raw_pk,_) = Signature.generate_key () in let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in @@ -2150,7 +2149,7 @@ let key_hash_mligo () : unit result = let%bind () = expect_eq program "check_hash_key" make_input make_expected in ok () -let key_hash_religo () : unit result = +let key_hash_religo () : (unit, _) result = let open Tezos_crypto in let (raw_pkh,raw_pk,_) = Signature.generate_key () in let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in @@ -2161,7 +2160,7 @@ let key_hash_religo () : unit result = let%bind () = expect_eq program "check_hash_key" make_input make_expected in ok () -let check_signature () : unit result = +let check_signature () : (unit, _) result = let open Tezos_crypto in let (_, raw_pk, sk) = Signature.generate_key () in let pk_str = Signature.Public_key.to_b58check raw_pk in @@ -2174,7 +2173,7 @@ let check_signature () : unit result = let%bind () = expect_eq program "check_signature" make_input make_expected in ok () -let check_signature_mligo () : unit result = +let check_signature_mligo () : (unit, _) result = let open Tezos_crypto in let (_, raw_pk, sk) = Signature.generate_key () in let pk_str = Signature.Public_key.to_b58check raw_pk in @@ -2188,7 +2187,7 @@ let check_signature_mligo () : unit result = let%bind () = expect_eq_evaluate program "example" (e_bool true) in ok () -let check_signature_religo () : unit result = +let check_signature_religo () : (unit, _) result = let open Tezos_crypto in let (_, raw_pk, sk) = Signature.generate_key () in let pk_str = Signature.Public_key.to_b58check raw_pk in @@ -2201,7 +2200,7 @@ let check_signature_religo () : unit result = let%bind () = expect_eq program "check_signature" make_input make_expected in ok () -let curry () : unit result = +let curry () : (unit, _) result = let%bind program = mtype_file "./contracts/curry.mligo" in let%bind () = expect_eq program "main" (e_int 2) (e_int 12) @@ -2211,7 +2210,7 @@ let curry () : unit result = in ok () -let set_delegate () : unit result = +let set_delegate () : (unit, _) result = let open Tezos_crypto in let (raw_pkh,_,_) = Signature.generate_key () in let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in @@ -2219,7 +2218,7 @@ let set_delegate () : unit result = let%bind () = expect_eq program "main" (e_key_hash pkh_str) (e_typed_list [] (t_operation ())) in ok () -let set_delegate_mligo () : unit result = +let set_delegate_mligo () : (unit, _) result = let open Tezos_crypto in let (raw_pkh,_,_) = Signature.generate_key () in let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in @@ -2227,7 +2226,7 @@ let set_delegate_mligo () : unit result = let%bind () = expect_eq program "main" (e_key_hash pkh_str) (e_typed_list [] (t_operation ())) in ok () -let set_delegate_religo () : unit result = +let set_delegate_religo () : (unit, _) result = let open Tezos_crypto in let (raw_pkh,_,_) = Signature.generate_key () in let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in @@ -2235,25 +2234,25 @@ let set_delegate_religo () : unit result = let%bind () = expect_eq program "main" (e_key_hash pkh_str) (e_typed_list [] (t_operation ())) in ok () -let type_tuple_destruct () : unit result = +let type_tuple_destruct () : (unit, _) result = let%bind program = mtype_file "./contracts/type_tuple_destruct.mligo" in let%bind () = expect_eq program "type_tuple_d" (e_unit ()) (e_int 35) in let%bind () = expect_eq program "type_tuple_d_2" (e_unit ()) (e_string "helloworld") in ok () -let tuple_param_destruct () : unit result = +let tuple_param_destruct () : (unit, _) result = let%bind program = mtype_file "./contracts/tuple_param_destruct.mligo" in let%bind () = expect_eq program "sum" (e_tuple [e_int 20; e_int 10]) (e_int 10) in let%bind () = expect_eq program "parentheses" (e_tuple [e_int 20; e_int 10]) (e_int 10) in ok () -let tuple_param_destruct_religo () : unit result = +let tuple_param_destruct_religo () : (unit, _) result = let%bind program = retype_file "./contracts/tuple_param_destruct.religo" in let%bind () = expect_eq program "sum" (e_tuple [e_int 20; e_int 10]) (e_int 10) in let%bind () = expect_eq program "parentheses" (e_tuple [e_int 20; e_int 10]) (e_int 10) in ok () -let let_in_multi_bind () : unit result = +let let_in_multi_bind () : (unit, _) result = let%bind program = mtype_file "./contracts/let_in_multi_bind.mligo" in let%bind () = expect_eq program "sum" (e_tuple [e_int 10; e_int 10]) (e_int 20) in let%bind () = expect_eq program "sum2" @@ -2265,7 +2264,7 @@ let let_in_multi_bind () : unit result = (e_string "mynameisbob") in ok () -let bytes_unpack () : unit result = +let bytes_unpack () : (unit, _) result = let%bind program = type_file "./contracts/bytes_unpack.ligo" in let%bind () = expect_eq program "id_string" (e_string "teststring") (e_some (e_string "teststring")) in let%bind () = expect_eq program "id_int" (e_int 42) (e_some (e_int 42)) in @@ -2275,7 +2274,7 @@ let bytes_unpack () : unit result = let%bind () = expect_eq program "id_address" (e_address addr) (e_some (e_address addr)) in ok () -let bytes_unpack_mligo () : unit result = +let bytes_unpack_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/bytes_unpack.mligo" in let%bind () = expect_eq program "id_string" (e_string "teststring") (e_some (e_string "teststring")) in let%bind () = expect_eq program "id_int" (e_int 42) (e_some (e_int 42)) in @@ -2285,7 +2284,7 @@ let bytes_unpack_mligo () : unit result = let%bind () = expect_eq program "id_address" (e_address addr) (e_some (e_address addr)) in ok () -let bytes_unpack_religo () : unit result = +let bytes_unpack_religo () : (unit, _) result = let%bind program = retype_file "./contracts/bytes_unpack.religo" in let%bind () = expect_eq program "id_string" (e_string "teststring") (e_some (e_string "teststring")) in let%bind () = expect_eq program "id_int" (e_int 42) (e_some (e_int 42)) in @@ -2295,7 +2294,7 @@ let bytes_unpack_religo () : unit result = let%bind () = expect_eq program "id_address" (e_address addr) (e_some (e_address addr)) in ok () -let empty_case () : unit result = +let empty_case () : (unit, _) result = let%bind program = type_file "./contracts/empty_case.ligo" in let%bind () = let input _ = e_constructor "Bar" (e_int 1) in @@ -2309,7 +2308,7 @@ let empty_case () : unit result = in ok () -let empty_case_mligo () : unit result = +let empty_case_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/empty_case.mligo" in let%bind () = let input _ = e_constructor "Bar" (e_int 1) in @@ -2323,7 +2322,7 @@ let empty_case_mligo () : unit result = in ok () -let empty_case_religo () : unit result = +let empty_case_religo () : (unit, _) result = let%bind program = retype_file "./contracts/empty_case.religo" in let%bind () = let input _ = e_constructor "Bar" (e_int 1) in @@ -2337,7 +2336,7 @@ let empty_case_religo () : unit result = in ok () -let tuple_type_mligo () : unit result = +let tuple_type_mligo () : (unit, _) result = let%bind program = mtype_file "./contracts/tuple_type.mligo" in let%bind () = let input _ = e_int 0 in @@ -2351,7 +2350,7 @@ let tuple_type_mligo () : unit result = in ok () -let tuple_type_religo () : unit result = +let tuple_type_religo () : (unit, _) result = let%bind program = retype_file "./contracts/tuple_type.religo" in let%bind () = let input _ = e_int 0 in @@ -2375,7 +2374,7 @@ let tuple_type_religo () : unit result = in ok () -let no_semicolon_religo () : unit result = +let no_semicolon_religo () : (unit, _) result = let%bind program = retype_file "./contracts/no_semicolon.religo" in let%bind () = let input _ = e_int 2 in @@ -2384,15 +2383,15 @@ let no_semicolon_religo () : unit result = in ok () -let tuple_list_religo () : unit result = +let tuple_list_religo () : (unit, _) result = let%bind _ = retype_file "./contracts/tuple_list.religo" in ok () -let single_record_expr_religo () : unit result = +let single_record_expr_religo () : (unit, _) result = let%bind _ = retype_file "./contracts/single_record_item.religo" in ok () -let loop_bugs_ligo () : unit result = +let loop_bugs_ligo () : (unit, _) result = let%bind program = type_file "./contracts/loop_bugs.ligo" in let input = e_unit () in let%bind () = diff --git a/src/test/md_file_tests.ml b/src/test/md_file_tests.ml index 57ad2d8b2..818f76381 100644 --- a/src/test/md_file_tests.ml +++ b/src/test/md_file_tests.ml @@ -1,18 +1,9 @@ open Trace open Test_helpers +open Main_errors module SnippetsGroup = Map.Make(struct type t = (string * string) let compare a b = compare a b end) -let failed_to_compile_md_file md_file (s,group,prg) = - let title () = "Failed to compile ```"^s^" block (group '"^group^"') in file '"^md_file^"'" in - let content () = "\n"^prg in - error title content - -let bad_code_block_argument arg = - let title () = Format.asprintf "Bad code block argument '%s'" arg in - let content () = "only 'group=NAME' or 'skip' are allowed" in - error title content - (** binds the snippets by (syntax, group_name) e.g. :(pascaligo, a) -> "let .. in let .. in" @@ -31,7 +22,7 @@ let get_groups md_file = let%bind () = bind_iter_list (fun arg -> match arg with | Md.Field "" | Md.Field "skip" | Md.NameValue ("group",_) -> ok () - | Md.Field f | Md.NameValue (f,_) -> fail @@ bad_code_block_argument f) + | Md.Field f | Md.NameValue (f,_) -> fail @@ test_code_block_arg f) el.arguments in match el.arguments with | [Md.Field ""] -> @@ -63,10 +54,10 @@ let get_groups md_file = (** evaluate each expression in each programs from the snippets group map **) -let compile_groups _filename grp_list = +let compile_groups filename grp_list = let%bind (_michelsons : Compiler.compiled_expression list list) = bind_map_list (fun ((s,grp),contents) -> - trace (failed_to_compile_md_file _filename (s,grp,contents)) @@ + trace (test_md_file_tracer filename s grp contents) @@ let%bind v_syntax = Compile.Helpers.syntax_to_variant (Syntax_name s) None in let%bind imperative = Compile.Of_source.compile_string contents v_syntax in let%bind sugar = Ligo.Compile.Of_imperative.compile imperative in diff --git a/src/test/parser_negative_tests.ml b/src/test/parser_negative_tests.ml index 9e25411ec..1aeb9b14f 100644 --- a/src/test/parser_negative_tests.ml +++ b/src/test/parser_negative_tests.ml @@ -1,7 +1,8 @@ open Test_helpers open Trace +open Main_errors -type 'a sdata = { erroneous_source_file : string ; parser : string -> 'a result } +type ('a,'err) sdata = { erroneous_source_file : string ; parser : string -> ('a,'err) result } let pascaligo_sdata = { erroneous_source_file = "../passes/01-parser/pascaligo/all.ligo" ; parser = Parser.Pascaligo.parse_expression } @@ -25,7 +26,7 @@ let get_exp_as_string filename = let assert_syntax_error sdata () = let%bind _l = bind_iter_list - (fun entry -> Assert.assert_fail @@ sdata.parser entry) + (fun entry -> Assert.assert_fail (test_internal __LOC__) @@ sdata.parser entry) (get_exp_as_string sdata.erroneous_source_file) in ok () diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 89983f082..7ca0e5e24 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -1,25 +1,31 @@ open Trace +open Main_errors type test_case = unit Alcotest.test_case type test = | Test_suite of (string * test list) | Test of test_case +let test_format : 'a Simple_utils.Display.format = { + (* do not display anything if test succeed *) + pp = (fun ~display_format _ _ -> ignore display_format; ()) ; + to_json = (fun _ -> (`Null:Display.json)) ; +} + let wrap_test name f = let result = - trace (error (thunk "running test") (thunk name)) @@ - f () in + trace (test_tracer name) @@ + f () + in + let format = Display.bind_format test_format Main.Formatter.error_format in + let disp = Simple_utils.Display.Displayable {value=result ; format} in + let s = Simple_utils.Display.convert ~display_format:(Human_readable) disp in match result with | Ok ((), annotations) -> ignore annotations; () - | Error err -> - Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ()) ; + | Error _ -> + Format.printf "%s\n%!" s ; raise Alcotest.Test_error -let wrap_test_raw f = - match f () with - | Ok ((), annotations) -> ignore annotations; () - | Error err -> - Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ()) let test name f = Test ( @@ -36,7 +42,7 @@ let expression_to_core expression = open Ast_imperative -let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result = +let pack_payload (program:Ast_typed.program) (payload:expression) : (bytes,_) result = let%bind code = let env = Ast_typed.program_environment Environment.default program in @@ -51,7 +57,7 @@ let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result Ligo.Run.Of_michelson.evaluate_expression code.expr code.expr_ty in Ligo.Run.Of_michelson.pack_payload payload payload_ty -let sign_message (program:Ast_typed.program) (payload : expression) sk : string result = +let sign_message (program:Ast_typed.program) (payload : expression) sk : (string,_) result = let open Tezos_crypto in let%bind packed_payload = pack_payload program payload in let signed_data = Signature.sign sk packed_payload in @@ -87,7 +93,7 @@ open Ast_imperative.Combinators let typed_program_with_imperative_input_to_michelson ((program , state): Ast_typed.program * Typesystem.Solver_types.typer_state) (entry_point: string) - (input: Ast_imperative.expression) : Compiler.compiled_expression result = + (input: Ast_imperative.expression) : (Compiler.compiled_expression,_) result = Printexc.record_backtrace true; let env = Ast_typed.program_environment Environment.default program in let%bind sugar = Compile.Of_imperative.compile_expression input in @@ -100,81 +106,62 @@ let typed_program_with_imperative_input_to_michelson let run_typed_program_with_imperative_input ?options ((program , state): Ast_typed.program * Typesystem.Solver_types.typer_state) (entry_point: string) - (input: Ast_imperative.expression) : Ast_core.expression result = + (input: Ast_imperative.expression) : (Ast_core.expression, _) result = let%bind michelson_program = typed_program_with_imperative_input_to_michelson (program , state) entry_point input in let%bind michelson_output = Ligo.Run.Of_michelson.run_no_failwith ?options michelson_program.expr michelson_program.expr_ty in - Uncompile.uncompile_typed_program_entry_function_result program entry_point michelson_output + let%bind res = Uncompile.uncompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in + match res with + | Runned_result.Success exp -> ok exp + | Runned_result.Fail _ -> fail test_not_expected_to_fail let expect ?options program entry_point input expecter = let%bind result = - let run_error = - let title () = "expect run" in - let content () = Format.asprintf "Entry_point: %s" entry_point in - error title content - in - trace run_error @@ + trace (test_run_tracer entry_point) @@ run_typed_program_with_imperative_input ?options program entry_point input in expecter result let expect_fail ?options program entry_point input = - let run_error = - let title () = "expect run" in - let content () = Format.asprintf "Entry_point: %s" entry_point in - error title content - in - trace run_error @@ - Assert.assert_fail @@ - run_typed_program_with_imperative_input ?options program entry_point input + trace (test_run_tracer entry_point) @@ + Assert.assert_fail (test_expected_to_fail) @@ + run_typed_program_with_imperative_input ?options program entry_point input let expect_string_failwith ?options program entry_point input expected_failwith = let%bind michelson_program = typed_program_with_imperative_input_to_michelson program entry_point input in let%bind err = Ligo.Run.Of_michelson.run_failwith ?options michelson_program.expr michelson_program.expr_ty in match err with - | Ligo.Run.Of_michelson.Failwith_string s -> Assert.assert_equal_string expected_failwith s - | _ -> simple_fail "Expected to fail with a string" + | Runned_result.Failwith_string s when String.equal s expected_failwith -> ok () + | _ -> fail test_expected_to_fail let expect_eq ?options program entry_point input expected = let%bind expected = expression_to_core expected in let expecter = fun result -> - let expect_error = - let title () = "expect result" in - let content () = Format.asprintf "Expected %a, got %a" - Ast_core.PP.expression expected - Ast_core.PP.expression result in - error title content in - trace expect_error @@ + trace_option (test_expect expected result) @@ Ast_core.Misc.assert_value_eq (expected,result) in expect ?options program entry_point input expecter let expect_eq_core ?options program entry_point input expected = let expecter = fun result -> - let expect_error = - let title () = "expect result" in - let content () = Format.asprintf "Expected %a, got %a" - Ast_core.PP.expression expected - Ast_core.PP.expression result in - error title content in - trace expect_error @@ + trace_option (test_expect expected result) @@ Ast_core.Misc.assert_value_eq (expected,result) in expect ?options program entry_point input expecter let expect_evaluate (program, _state) entry_point expecter = - let error = - let title () = "expect evaluate" in - let content () = Format.asprintf "Entry_point: %s" entry_point in - error title content in - trace error @@ + trace (test_run_tracer entry_point) @@ let%bind mini_c = Ligo.Compile.Of_typed.compile program in - let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in + let%bind (exp,_) = trace_option unknown @@ Mini_c.get_entry mini_c entry_point in let%bind michelson_value = Ligo.Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in let%bind res_michelson = Ligo.Run.Of_michelson.run_no_failwith michelson_value.expr michelson_value.expr_ty in - let%bind res_simpl = Uncompile.uncompile_typed_program_entry_expression_result program entry_point res_michelson in - expecter res_simpl + let%bind res = Uncompile.uncompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in + let%bind res' = match res with + | Runned_result.Success exp -> ok exp + | Runned_result.Fail _ -> fail test_not_expected_to_fail in + expecter res' let expect_eq_evaluate ((program , state) : Ast_typed.program * Typesystem.Solver_types.typer_state) entry_point expected = let%bind expected = expression_to_core expected in let expecter = fun result -> + trace_option (test_expect expected result) @@ Ast_core.Misc.assert_value_eq (expected , result) in expect_evaluate (program, state) entry_point expecter @@ -182,7 +169,7 @@ let expect_n_aux ?options lst program entry_point make_input make_expecter = let aux n = let input = make_input n in let expecter = make_expecter n in - trace (simple_error ("expect_n " ^ (string_of_int n))) @@ + trace (test_expect_n_tracer n) @@ let result = expect ?options program entry_point input expecter in result in @@ -193,7 +180,7 @@ let expect_eq_n_trace_aux ?options lst program entry_point make_input make_expec let aux n = let%bind input = make_input n in let%bind expected = make_expected n in - trace (simple_error ("expect_eq_n " ^ (string_of_int n))) @@ + trace (test_expect_n_tracer n) @@ let result = expect_eq ?options program entry_point input expected in result in @@ -204,8 +191,7 @@ let expect_eq_exp_trace_aux ?options explst program entry_point make_input make_ let aux exp = let%bind input = make_input exp in let%bind expected = make_expected exp in - let pps = Format.asprintf "%a" Ast_core.PP.expression exp in - trace (simple_error ("expect_eq_exp " ^ pps )) @@ + trace (test_expect_exp_tracer exp) @@ let result = expect_eq ?options program entry_point input expected in result in @@ -216,8 +202,7 @@ let expect_failwith_exp_trace_aux ?options explst program entry_point make_input let aux exp = let%bind input = make_input exp in let%bind expected = make_expected_failwith exp in - let pps = Format.asprintf "%a" Ast_core.PP.expression exp in - trace (simple_error ("expect_eq_exp " ^ pps )) @@ + trace (test_expect_exp_tracer exp) @@ let result = expect_string_failwith ?options program entry_point input expected in result in @@ -228,7 +213,7 @@ let expect_eq_n_aux ?options lst program entry_point make_input make_expected = let aux n = let input = make_input n in let expected = make_expected n in - trace (simple_error ("expect_eq_n " ^ (string_of_int n))) @@ + trace (test_expect_eq_n_tracer n) @@ let result = expect_eq ?options program entry_point input expected in result in diff --git a/src/test/time_lock_repeat_tests.ml b/src/test/time_lock_repeat_tests.ml index efadf31a2..cab060c1c 100644 --- a/src/test/time_lock_repeat_tests.ml +++ b/src/test/time_lock_repeat_tests.ml @@ -1,6 +1,7 @@ open Trace open Test_helpers open Ast_imperative +open Main_errors let type_file f = let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" (Contract "main") in @@ -35,7 +36,7 @@ let call msg = e_constructor "Call" msg let mk_time st = match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with | Some s -> ok s - | None -> simple_fail "bad timestamp notation" + | None -> fail @@ test_internal "bad timestamp notation" let to_sec t = Tezos_utils.Time.Protocol.to_seconds t let storage st interval execute = e_record_ez [("next_use", e_timestamp (Int64.to_int @@ to_sec st)) ; diff --git a/src/test/time_lock_tests.ml b/src/test/time_lock_tests.ml index ee99d1542..9dd75b606 100644 --- a/src/test/time_lock_tests.ml +++ b/src/test/time_lock_tests.ml @@ -1,4 +1,5 @@ open Trace +open Main_errors open Test_helpers let type_file f = @@ -36,7 +37,7 @@ let call msg = e_constructor "Call" msg let mk_time st = match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with | Some s -> ok s - | None -> simple_fail "bad timestamp notation" + | None -> fail @@ test_internal "bad timestamp notation" let to_sec t = Tezos_utils.Time.Protocol.to_seconds t let storage st = e_timestamp (Int64.to_int @@ to_sec st) diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index c26e690ba..ca897fcf4 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -1,22 +1,23 @@ open Trace open Ast_core open Test_helpers +open Main_errors module Typed = Ast_typed module Typer = Typer module Simplified = Ast_core -let int () : unit result = +let int () : (unit, _) result = let open Combinators in let pre = e_int (Z.of_int 32) in let open Typer in let e = Environment.empty in let state = Typer.Solver.initial_state in - let%bind (post , new_state) = type_expression_subst e state pre in + let%bind (post , new_state) = trace typer_tracer @@ type_expression_subst e state pre in let () = Typer.Solver.discard_state new_state in let open! Typed in let open Combinators in - let%bind () = assert_type_expression_eq (post.type_expression, t_int ()) in + let%bind () = trace_option (test_internal __LOC__) @@ assert_type_expression_eq (post.type_expression, t_int ()) in ok () module TestExpressions = struct @@ -27,34 +28,34 @@ module TestExpressions = struct let pre = expr in let open Typer in let open! Typed in - let%bind (post , new_state) = type_expression_subst env state pre in + let%bind (post , new_state) = trace typer_tracer @@ type_expression_subst env state pre in let () = Typer.Solver.discard_state new_state in - let%bind () = assert_type_expression_eq (post.type_expression, test_expected_ty) in + let%bind () = trace_option (test_internal __LOC__) @@ assert_type_expression_eq (post.type_expression, test_expected_ty) in ok () module I = Simplified.Combinators module O = Typed.Combinators module E = Typed.Environment - let unit () : unit result = test_expression I.(e_unit ()) O.(t_unit ()) - let int () : unit result = test_expression I.(e_int (Z.of_int 32)) O.(t_int ()) - let bool () : unit result = test_expression I.(e_bool true) O.(t_bool ()) - let string () : unit result = test_expression I.(e_string (Standard "s")) O.(t_string ()) - let bytes () : unit result = - let%bind b = I.e_bytes_hex "0b" in + let unit () : (unit, _) result = test_expression I.(e_unit ()) O.(t_unit ()) + let int () : (unit, _) result = test_expression I.(e_int (Z.of_int 32)) O.(t_int ()) + let bool () : (unit, _) result = test_expression I.(e_bool true) O.(t_bool ()) + let string () : (unit, _) result = test_expression I.(e_string (Standard "s")) O.(t_string ()) + let bytes () : (unit, _) result = + let b = I.e_bytes_hex "0b" in test_expression b O.(t_bytes ()) - let lambda () : unit result = + let lambda () : (unit, _) result = test_expression I.(e_lambda (Var.of_name "x") (Some (t_int ())) (Some (t_int ())) (e_var "x")) O.(t_function (t_int ()) (t_int ()) ()) - let tuple () : unit result = + let tuple () : (unit, _) result = test_expression I.(e_record @@ LMap.of_list [(Label "0",e_int (Z.of_int 32)); (Label "1", e_string (Standard "foo"))]) O.(make_t_ez_record [("0",t_int ()); ("1",t_string ())]) - let constructor () : unit result = + let constructor () : (unit, _) result = let variant_foo_bar : (Typed.constructor' * Typed.ctor_content) list = [ (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None ; ctor_decl_pos = 0}); (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ] @@ -63,7 +64,7 @@ module TestExpressions = struct I.(e_constructor "foo" (e_int (Z.of_int 32))) O.(make_t_ez_sum variant_foo_bar) - let record () : unit result = + let record () : (unit, _) result = test_expression I.(e_record @@ LMap.of_list [(Label "foo", e_int (Z.of_int 32)); (Label "bar", e_string (Standard "foo"))]) O.(make_t_ez_record [("foo", t_int ()); ("bar", t_string ())]) diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml index 89f829a86..6cb88f8ca 100644 --- a/src/test/vote_tests.ml +++ b/src/test/vote_tests.ml @@ -1,5 +1,6 @@ open Trace open Test_helpers +open Main_errors let type_file f = Ligo.Compile.Utils.type_file f "cameligo" (Contract "main") @@ -39,12 +40,12 @@ let init_vote () = let%bind result = Test_helpers.run_typed_program_with_imperative_input (program, state) "main" (e_pair yea (init_storage "basic")) in - let%bind (_, storage) = Ast_core.extract_pair result in - let%bind storage' = Ast_core.extract_record storage in + let%bind (_, storage) = trace_option (test_internal __LOC__) @@ Ast_core.extract_pair result in + let%bind storage' = trace_option (test_internal __LOC__) @@ Ast_core.extract_record storage in (* let votes = List.assoc (Label "voters") storage' in let%bind votes' = extract_map votes in *) let yea = List.assoc (Label "yea") storage' in - let%bind () = Ast_core.Misc.assert_value_eq (yea, Ast_core.e_nat Z.one) in + let%bind () = trace_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (yea, Ast_core.e_nat Z.one) in ok () let main = test_suite "Vote" [ diff --git a/vendors/ligo-utils/proto-alpha-utils/trace.ml b/vendors/ligo-utils/proto-alpha-utils/trace.ml index 54bf77db3..edb771c97 100644 --- a/vendors/ligo-utils/proto-alpha-utils/trace.ml +++ b/vendors/ligo-utils/proto-alpha-utils/trace.ml @@ -3,43 +3,28 @@ include Simple_utils.Trace module AE = Memory_proto_alpha.Alpha_environment module TP = Tezos_base__TzPervasives -let of_tz_error (err:X_error_monad.error) : error_thunk = - let str () = X_error_monad.(to_string err) in - error (thunk "alpha error") str +type tezos_alpha_error = [`Tezos_alpha_error of TP.error] + +let of_tz_error (err:X_error_monad.error) : tezos_alpha_error = + `Tezos_alpha_error err let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err) -let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result = - function - | Ok x -> ok x - | Error errs -> fail @@ thunk @@ patch_children (List.map of_alpha_tz_error errs) (err ()) - -let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = - trace_alpha_tzresult error @@ Lwt_main.run x - -let trace_tzresult err = - function - | Ok x -> ok x - | Error errs -> fail @@ thunk @@ patch_children (List.map of_tz_error errs) (err ()) - -(* TODO: should be a combination of trace_tzresult and trace_r *) -let trace_tzresult_r err_thunk_may_fail = - function +let trace_alpha_tzresult : + (tezos_alpha_error list -> 'b) -> 'a AE.Error_monad.tzresult -> ('a, 'b) result = + fun tracer err -> match err with | Ok x -> ok x | Error errs -> - let tz_errs = List.map of_tz_error errs in - match err_thunk_may_fail () with - | Ok (err, annotations) -> - ignore annotations ; - Error (fun () -> patch_children tz_errs (err ())) - | Error errors_while_generating_error -> - (* TODO: the complexity could be O(n*n) in the worst case, - this should use some catenable lists. *) - Error (errors_while_generating_error) + fail @@ tracer (List.map of_alpha_tz_error errs) + +let trace_alpha_tzresult_lwt tracer (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = + trace_alpha_tzresult tracer @@ Lwt_main.run x + +let trace_tzresult : + (tezos_alpha_error list -> _) -> ('a, TP.error list) Pervasives.result -> ('a, _) result = + fun tracer err -> match err with + | Ok x -> ok x + | Error errs -> fail @@ tracer (List.map of_tz_error errs) let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result = trace_tzresult err @@ Lwt_main.run x - -let trace_tzresult_lwt_r err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result = - trace_tzresult_r err @@ Lwt_main.run x - diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index 863d19a62..58038fee4 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml @@ -1077,7 +1077,7 @@ let make_options = let tezos_context = { tezos_context with predecessor_timestamp } in let tezos_context_error = - Trace.trace_alpha_tzresult_lwt (Trace.simple_error "lol") @@ + Trace.trace_alpha_tzresult_lwt (fun _ -> `Vendors "could not set balance") @@ Alpha_context.Contract.set_balance tezos_context self balance in let tezos_context = match tezos_context_error with @@ -1085,7 +1085,6 @@ let make_options | Error _ -> tezos_context in { tezos_context ; - (* yep *) source = sender ; payer = source ; self ; diff --git a/vendors/ligo-utils/simple-utils/dictionary.ml b/vendors/ligo-utils/simple-utils/dictionary.ml deleted file mode 100644 index 130c01af8..000000000 --- a/vendors/ligo-utils/simple-utils/dictionary.ml +++ /dev/null @@ -1,53 +0,0 @@ -open Trace - -module type DICTIONARY = sig - type ('a, 'b) t - - val get_exn : ('a, 'b) t -> 'a -> 'b - val get : ('a, 'b) t -> 'a -> 'b result - - val set : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - - val del : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> ('a, 'b) t - - val to_list : ('a, 'b) t -> ('a * 'b) list -end - -module Assoc : DICTIONARY = struct - - type ('a, 'b) t = ('a * 'b) list - - let get_exn x y = List.assoc y x - - let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y - - let set ?equal lst a b = - let equal : 'a -> 'a -> bool = - X_option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux ((key, b) :: acc) tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - - let del ?equal lst a = - let equal : 'a -> 'a -> bool = - X_option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux acc tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - - let to_list x = x -end diff --git a/vendors/ligo-utils/simple-utils/display.ml b/vendors/ligo-utils/simple-utils/display.ml new file mode 100644 index 000000000..0b52d5635 --- /dev/null +++ b/vendors/ligo-utils/simple-utils/display.ml @@ -0,0 +1,46 @@ +type json = Yojson.Basic.t + +type 'a display_format = + | Human_readable : string display_format + | Dev : string display_format + | Json : json display_format + +type ex_display_format = Ex_display_format : 'a display_format -> ex_display_format + +let human_readable = Ex_display_format Human_readable +let dev = Ex_display_format Dev +let json = Ex_display_format Json + +type 'a pp = display_format:(string display_format) -> Format.formatter -> 'a -> unit +type 'a format = { + pp : 'a pp ; + to_json : 'a -> json ; +} + +type 'a with_format = { + value : 'a ; + format : 'a format ; +} + +type displayable = Displayable : 'a with_format -> displayable + +let convert : type output . display_format:(output display_format) -> displayable -> output = + fun ~display_format (Displayable { value ; format }) -> + match display_format with + | Json -> format.to_json value + | Dev -> Format.asprintf "%a" (format.pp ~display_format) value + | Human_readable -> Format.asprintf "%a" (format.pp ~display_format) value + +let to_json : displayable -> json = convert ~display_format:Json + +let bind_format : + 'value format -> 'error format -> ('value,'error) result format = + fun value_format error_format -> + let pp ~display_format f a = match a with + | Error e -> error_format.pp ~display_format f e + | Ok v -> value_format.pp ~display_format f v in + let to_json a = match a with + | Error e -> error_format.to_json e + | Ok v -> value_format.to_json v in + { pp ; to_json } + diff --git a/vendors/ligo-utils/simple-utils/display.mli b/vendors/ligo-utils/simple-utils/display.mli new file mode 100644 index 000000000..e8fe2d1bf --- /dev/null +++ b/vendors/ligo-utils/simple-utils/display.mli @@ -0,0 +1,31 @@ +type json = Yojson.Basic.t + +type 'a display_format = + | Human_readable : string display_format + | Dev : string display_format + | Json : json display_format + +type ex_display_format = Ex_display_format : 'a display_format -> ex_display_format + +val human_readable : ex_display_format +val dev : ex_display_format +val json : ex_display_format + +type 'a pp = display_format:(string display_format) -> Format.formatter -> 'a -> unit +type 'a format = { + pp : 'a pp ; + to_json : 'a -> json ; +} + +type 'a with_format = { + value : 'a ; + format : 'a format ; +} + +type displayable = Displayable : 'a with_format -> displayable + +val convert : display_format:'output display_format -> displayable -> 'output + +val to_json : displayable -> json + +val bind_format : 'value format -> 'error format -> ('value,'error) result format \ No newline at end of file diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 32411d072..96c361f3d 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -14,7 +14,7 @@ type t = let pp = fun ppf t -> match t with - | Virtual s -> Format.fprintf ppf "%s" s + | Virtual _s -> Format.fprintf ppf "" | File f -> Format.fprintf ppf "%s" (f#to_string `Point) let compare a b = match a,b with diff --git a/vendors/ligo-utils/simple-utils/runned_result.ml b/vendors/ligo-utils/simple-utils/runned_result.ml new file mode 100644 index 000000000..062c42a9a --- /dev/null +++ b/vendors/ligo-utils/simple-utils/runned_result.ml @@ -0,0 +1,10 @@ +type failwith = + | Failwith_int of int + | Failwith_string of string + | Failwith_bytes of bytes + +type 'a runned_result = + | Success of 'a + | Fail of failwith + +type check_type = Check_parameter | Check_storage \ No newline at end of file diff --git a/vendors/ligo-utils/simple-utils/simple_utils.ml b/vendors/ligo-utils/simple-utils/simple_utils.ml index c0748367b..2df09573f 100644 --- a/vendors/ligo-utils/simple-utils/simple_utils.ml +++ b/vendors/ligo-utils/simple-utils/simple_utils.ml @@ -9,9 +9,11 @@ module Option = X_option module Int = X_int module Tuple = Tuple module Map = X_map -module Dictionary = Dictionary module Tree = Tree module Region = Region module Pos = Pos module Var = Var module Ligo_string = X_string +module Display = Display +module Runned_result = Runned_result + diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index fb143e27c..19c0e42bd 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -214,74 +214,12 @@ end (* end Trace_tutorial. *) module J = Yojson.Basic -module JSON_string_utils = struct - let member n x = - match x with - `Null -> `Null - | x -> J.Util.member n x - - let string = J.Util.to_string_option - - let to_list_option = fun x -> - try Some (J.Util.to_list x) with _ -> None - - let to_assoc_option = fun x -> - try Some (J.Util.to_assoc x) with _ -> None - - let list = to_list_option - - let assoc = to_assoc_option - - let int = J.Util.to_int_option - - let patch j k v = - match assoc j with - None -> j - | Some assoc -> `Assoc ( - List.map (fun (k', v') -> (k', if k = k' then v else v')) assoc) - - let swap f l r = f r l - - let unit x = Some x - - let bind f = function None -> None | Some x -> Some (f x) - - let bind2 f l r = - match l, r with - None, None -> None - | None, Some _ -> None - | Some _, None -> None - | Some l, Some r -> Some (f l r) - - let default d = function - Some x -> x - | None -> d - - let string_of_int = bind string_of_int - - let (||) l r = l |> default r - - let (|^) = bind2 (^) -end - -type 'a thunk = unit -> 'a - -(* Errors are encoded in JSON. This is because different libraries - will implement their own helpers, and we do not want to hardcode - in their type how they are supposed to interact. *) - -type error = J.t - -(* Thunks are used because computing some errors can be costly, and - we do not want to spend most of our time building errors. Instead, - their computation is deferred.*) - -type error_thunk = error thunk (* Annotations should be used in debug mode to aggregate information about some value history. Where it was produced, when it was modified, etc. It is currently not being used. *) +type 'a thunk = unit -> 'a type annotation = J.t (* Even in debug mode, building annotations can be quite @@ -290,16 +228,7 @@ type annotation = J.t type annotation_thunk = annotation thunk -(* Types of traced elements. It might be good to rename it [trace] at - some point. *) - -type nonrec 'a result = ('a * annotation_thunk list, error_thunk) result - -(* -= Ok of 'a * annotation_thunk list -| Error of error_thunk -*) - +type nonrec ('value, 'error) result = ('value * annotation_thunk list, 'error) result (** {1 Constructors} *) @@ -353,83 +282,15 @@ end let thunk x () = x -(* Build a standard error, with a title, a message, an error code and - some data. *) - -let mk_error - ?(error_code : int thunk option) ?(message : string thunk option) - ?(data : (string * string thunk) list option) - ?(children = []) ?(infos = []) - ~(title : string thunk) () : error = - let error_code' = X_option.map (fun x -> ("error_code" , `Int (x ()))) error_code in - let title' = X_option.some ("title" , `String (title ())) in - let data' = - let aux (key , value) = (key , `String (value ())) in - X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in - let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in - let type' = Some ("type" , `String "error") in - let children' = Some ("children" , `List children) in - let infos' = Some ("infos" , `List infos) in - `Assoc (X_option.collapse_list - [error_code'; title'; message'; data'; type'; children'; infos']) - -let error ?data ?error_code ?children ?infos title message () = - mk_error ?data ?error_code ?children ?infos ~title ~message () - -let prepend_child = fun child err -> - let open JSON_string_utils in - let children_opt = err |> member "children" |> list in - let children = match children_opt with - | Some children -> (child ()) :: children - | None -> [ child () ] in - patch err "children" (`List children) - -let patch_children = fun children err -> - let open JSON_string_utils in - patch err "children" (`List (List.map (fun f -> f ()) children)) - -(* Build a standard info, with a title, a message, an info code and some data. *) - -let mk_info - ?(info_code : int thunk option) ?(message : string thunk option) - ?(data : (string * string thunk) list option) - ~(title : string thunk) () : error = - let error_code' = X_option.map (fun x -> ("error_code" , `Int (x ()))) info_code in - let title' = X_option.some ("title" , `String (title ())) in - let data' = - let aux (key , value) = (key , `String (value ())) in - X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in - let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in - let type' = Some ("type" , `String "info") in - `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ; type' ]) - -let info ?data ?info_code title message () = - mk_info ?data ?info_code ~title ~message () - -let prepend_info = fun info err -> - let open JSON_string_utils in - let infos_opt = err |> member "infos" |> list in - let infos = match infos_opt with - | Some infos -> info :: infos - | None -> [ info ] in - patch err "infos" (`List infos) - - -(* Helpers that ideally should not be used in production. *) - -let simple_error str () = mk_error ~title:(thunk str) () -let simple_info str () = mk_info ~title:(thunk str) () -let simple_fail str = fail @@ simple_error str -let internal_assertion_failure str = simple_error ("assertion failed: " ^ str) - (* To be used when you only want to signal an error. It can be useful when followed by [trace_strong]. *) -let dummy_fail = simple_fail "dummy" - -let trace info = function +(* let trace info = function Ok _ as o -> o -| Error err -> Error (fun () -> prepend_info (info ()) (err ())) +| Error err -> Error (fun () -> prepend_info (info ()) (err ())) *) +let trace tracer v = match v with + | Ok v' -> Ok v' + | Error err -> Error (tracer err) (* Erase the current error stack, and replace it by the given error. It's useful when using [Assert] and you want to discard its @@ -439,32 +300,6 @@ let trace_strong err = function Ok _ as o -> o | Error _ -> Error err -(* Sometimes, when you have a list of potentially erroneous elements, you need - to retrieve all the errors, instead of just the first one. In that case, do: - [let type_list lst = - let%bind lst' = - trace_list (simple_error "Error while typing a list") @@ - List.map type_element lst in - ...] - Where before you would have written: - [let type_list lst = - let%bind lst' = bind_map_list type_element lst in - ...] *) -let trace_list err lst = - let oks = - let aux = function - | Ok (x , _) -> Some x - | _ -> None in - X_list.filter_map aux lst in - let errs = - let aux = function - | Error x -> Some x - | _ -> None in - X_list.filter_map aux lst in - match errs with - | [] -> ok oks - | errs -> fail (fun () -> patch_children errs err) - (* Trace, but with an error which generation may itself fail. *) let trace_r err_thunk_may_fail = function @@ -477,25 +312,6 @@ let trace_r err_thunk_may_fail = function this should use some catenable lists. *) Error (errors_while_generating_error) -(* [trace_f f error] yields a function that acts the same as `f`, but with an - error frame that has one more error. *) - -let trace_f f error x = trace error @@ f x -(* Same, but for functions with 2 parameters. *) - -let trace_f_2 f error x y = - trace error @@ f x y - -(** - Same, but with a prototypical error. -*) -let trace_f_ez f name = - trace_f f (error (thunk "in function") name) - -let trace_f_2_ez f name = - trace_f_2 f (error (thunk "in function") name) - - (** Check if there is no error. Useful for tests. *) @@ -512,7 +328,11 @@ let to_option = function *) let trace_option error = function None -> fail error -| Some s -> ok s + | Some s -> ok s + +let trace_assert_fail_option error = function + None -> ok () + | Some _s -> fail error (** Utilities to interact with other data-structure. [bind_t] takes an ['a result t] and makes a ['a t result] out of it. It "lifts" the @@ -549,7 +369,7 @@ let bind_fold_smap f init (smap : _ X_map.String.t) = let bind_map_smap f smap = bind_smap (X_map.String.map f smap) -let bind_concat (l1:'a list result) (l2: 'a list result) = +let bind_concat l1 l2 = let%bind l1' = l1 in let%bind l2' = l2 in ok @@ (l1' @ l2') @@ -564,9 +384,10 @@ let rec bind_map_list_seq f lst = match lst with let%bind tl' = bind_map_list_seq f tl in ok (hd' :: tl') -let bind_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = +let bind_map_ne_list : _ -> 'a X_list.Ne.t -> ('b X_list.Ne.t,_) result = fun f lst -> bind_ne_list (X_list.Ne.map f lst) -let bind_iter_list : (_ -> unit result) -> _ list -> unit result = + +let bind_iter_list : (_ -> (unit,_) result) -> _ list -> (unit,_) result = fun f lst -> bind_map_list f lst >>? fun _ -> ok () let bind_location (x:_ Location.wrap) = @@ -651,21 +472,6 @@ let bind_or (a, b) = let bind_map_or (fa, fb) c = bind_or (fa c, fb c) -let bind_lr (type a b) ((a : a result), (b:b result)) - : [`Left of a | `Right of b] result = - match (a, b) with - | (Ok _ as o), _ -> map (fun x -> `Left x) o - | _, (Ok _ as o) -> map (fun x -> `Right x) o - | _, Error b -> Error b - -let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) - : [`Left of a | `Right of b] result = - match a with - | Ok _ as o -> map (fun x -> `Left x) o - | _ -> match b() with - | Ok _ as o -> map (fun x -> `Right x) o - | Error b -> Error b - let bind_and (a, b) = a >>? fun a -> b >>? fun b -> @@ -691,19 +497,19 @@ let bind_map_triple f (a, b, c) = bind_and3 (f a, f b, f c) let bind_list_cons v lst = lst >>? fun lst -> ok (v::lst) -let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> +let rec bind_chain : ('a -> ('a,_) result) list -> 'a -> ('a,_) result = fun fs x -> match fs with | [] -> ok x | hd :: tl -> ( - let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in + let aux : 'a -> ('a,_) result = fun x -> bind (bind_chain tl) (hd x) in bind aux (ok x) ) -let rec bind_chain_ignore_acc : ('a -> ('b * 'a) result) list -> 'a -> 'a result = fun fs x -> +let rec bind_chain_ignore_acc : ('a -> ('b * 'a, _) result) list -> 'a -> ('a,_) result = fun fs x -> match fs with | [] -> ok x | hd :: tl -> ( - let aux : 'a -> 'a result = fun x -> + let aux : 'a -> ('a,_) result = fun x -> hd x >>? fun (_,aa) -> bind (bind_chain_ignore_acc tl) (ok aa) in bind aux (ok x) @@ -721,125 +527,25 @@ let generic_try err f = try ok @@ f () with _ -> fail err let specific_try handler f = try ok @@ f () with exn -> fail (handler exn) -(** - Same, but tailored to `Sys_error`s, found in `Sys` from `Pervasives`. -*) -let sys_try f = - let handler = function - Sys_error str -> error (thunk "Sys_error") (fun () -> str) - | exn -> raise exn - in specific_try handler f - -(** - Same, but for a given command. -*) -let sys_command command = - sys_try (fun () -> Sys.command command) >>? function - | 0 -> ok () - | n -> fail (fun () -> error (thunk "Nonzero return code.") - (fun () -> (string_of_int n)) ()) - (** Assertion module. - Would make sense to move it outside Trace. + (* Would make sense to move it outside Trace. *) *) module Assert = struct - let assert_fail ?(msg="Did not fail.") = function - Ok _ -> simple_fail msg + let assert_fail err = function + Ok _ -> fail err | _ -> ok () - let assert_true ?(msg="Not true.") = function - true -> ok () - | false -> simple_fail msg - - let assert_true_err err = function + let assert_true err = function | true -> ok () | false -> fail err - let assert_equal ?msg expected actual = - assert_true ?msg (expected = actual) + let assert_list_size err lst n = + assert_true err List.(length lst = n) - let assert_equal_string ?msg expected actual = - let msg = - let default = - Format.asprintf "Not equal string: Expected \"%s\", got \"%s\"" - expected actual - in X_option.unopt ~default msg - in assert_equal ~msg expected actual + let assert_list_empty err lst = + assert_true err List.(length lst = 0) - let assert_equal_int ?msg expected actual = - let msg = - let default = - Format.asprintf "Not equal int : expected %d, got %d" - expected actual - in X_option.unopt ~default msg - in assert_equal ~msg expected actual - - let assert_equal_bool ?msg expected actual = - let msg = - let default = - Format.asprintf "Not equal bool: expected %b, got %b" - expected actual in - X_option.unopt ~default msg in - assert_equal ~msg expected actual - - let assert_none ?(msg="Not a None value.") opt = match opt with - | None -> ok () - | _ -> simple_fail msg - - let assert_list_size ?(msg="Wrong list size.") lst n = - assert_true ~msg List.(length lst = n) - - let assert_list_empty ?(msg="Non-empty list.") lst = - assert_true ~msg List.(length lst = 0) - - let assert_list_same_size ?(msg="Lists with different lengths.") a b = - assert_true ~msg List.(length a = length b) - - let assert_list_size_2 ~msg = function - | [a;b] -> ok (a, b) - | _ -> simple_fail msg - - let assert_list_size_1 ~msg = function - | [a] -> ok a - | _ -> simple_fail msg end let json_of_error = J.to_string - -let error_pp out (e : error) = - let open JSON_string_utils in - let message = - let opt = e |> member "message" |> string in - X_option.unopt ~default:"" opt 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 - X_option.unopt ~default:"" opt in - let data = - let data = e |> member "data" in - match data with - | `Null -> "" - | _ -> J.to_string data in - Format.fprintf out "%s (%s): %s. %s" title error_code message data - - -let error_pp_short out (e : error) = - let open JSON_string_utils in - let title = e |> member "title" |> string || "(no title)" in - let error_code = e |> member "error_code" |> int |> string_of_int || "no error code" in - Format.fprintf out "%s (%s)" title error_code - -let errors_pp = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - error_pp - -let errors_pp_short = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - error_pp_short diff --git a/vendors/ligo-utils/simple-utils/x_option.ml b/vendors/ligo-utils/simple-utils/x_option.ml index 77096546f..d5f710f8d 100644 --- a/vendors/ligo-utils/simple-utils/x_option.ml +++ b/vendors/ligo-utils/simple-utils/x_option.ml @@ -35,6 +35,9 @@ let bind_eager_or = fun a b -> match (a , b) with | _ , Some b -> Some b | _ -> None +let map_pair_or = fun (fa, fb) p -> + bind_eager_or (fa p) (fb p) + let bind_union (a , b) = match (a , b) with | Some x , _ -> Some (`Left x) | None , Some x -> Some (`Right x) @@ -85,3 +88,13 @@ let compare compare x y = | (None, Some _) -> -1 | (Some _, None) -> 1 | (Some x, Some y) -> compare x y + +let is_some x = + match x with + | Some _ -> true + | None -> false + +let is_none x = + match x with + | Some _ -> false + | None -> true \ No newline at end of file diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 6bb075cf2..02ebc4d49 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -91,16 +91,18 @@ let pp ppf (michelson:michelson) = let node = printable string_of_prim canonical in print_expr ppf node -let pp_json ppf (michelson : michelson) = +let get_json (michelson : michelson) = let open Micheline_printer in let canonical = strip_locations michelson in let node = printable string_of_prim canonical in - let json = Tezos_data_encoding.( + Tezos_data_encoding.( Json.construct (Micheline.erased_encoding ~variant:"???" {comment = None} Data_encoding.string) node ) - in + +let pp_json ppf (michelson : michelson) = + let json = get_json michelson in Format.fprintf ppf "%a" Tezos_data_encoding.Json.pp json let pp_hex ppf (michelson : michelson) = @@ -113,3 +115,39 @@ let measure (michelson : michelson) = let canonical = strip_locations michelson in let bytes = Tezos_data_encoding.Binary_writer.to_bytes_exn Script_repr.expr_encoding canonical in Bytes.length bytes + +type michelson_format = [ + | `Text + | `Json + | `Hex +] + +let michelson_ppformat michelson_format ~display_format f (a,_) = + let mich_pp = fun michelson_format -> match michelson_format with + | `Text -> pp + | `Json -> pp_json + | `Hex -> pp_hex in + match display_format with + | Display.Human_readable | Dev -> ( + let m = Format.asprintf "%a\n" (mich_pp michelson_format) a in + Format.pp_print_string f m + ) + +let michelson_jsonformat michelson_format (a,_) : Display.json = match michelson_format with + | `Text -> + let code_as_str = Format.asprintf "%a" pp a in + `Assoc [("text_code" , `String code_as_str)] + | `Hex -> + let code_as_hex = Format.asprintf "%a" pp_hex a in + `Assoc [("hex_code" , `String code_as_hex)] + | `Json -> + (* Ideally , would like to do that : + Michelson.get_json a *) + let code_as_str = Format.asprintf "%a" pp_json a in + `Assoc [("json_code" , `String code_as_str)] + + +let michelson_format : michelson_format -> 'a Display.format = fun mf -> { + pp = michelson_ppformat mf; + to_json = michelson_jsonformat mf; +}