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

Merge branch 'refactor/display-and-result' into 'dev'

Browse Source 
Refactoring:  errors / formatting / display

See merge request ligolang/ligo!519
This commit is contained in:
Rémi Lesenechal 2020-06-15 14:46:50 +00:00
commit 429a1dc412
188 changed files with 7391 additions and 6750 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

458
src/bin/cli.ml
View File

@ -106,14 +106,15 @@ let predecessor_timestamp =
let display_format = let display_format =
let open Arg in let open Arg in
let open Display in
let info = let info =
let docv = "DISPLAY_FORMAT" in 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 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 info ~docv ~doc ["format" ; "display-format"] in
value @@ value @@
opt opt
(enum [("human-readable", `Human_readable); ("dev", `Dev); ("json", `Json)]) (enum [("human-readable", human_readable); ("dev", dev); ("json", json)])
`Human_readable human_readable
info info
let michelson_code_format = let michelson_code_format =
@ -127,110 +128,6 @@ let michelson_code_format =
(enum [("text", `Text); ("json", `Json); ("hex", `Hex)]) (enum [("text", `Text); ("json", `Json); ("hex", `Hex)])
`Text info `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 optimize =
let open Arg in let open Arg in
let docv = "ENTRY_POINT" in let docv = "ENTRY_POINT" in
@ -239,17 +136,108 @@ let optimize =
info ~docv ~doc ["optimize"] in info ~docv ~doc ["optimize"] in
value @@ opt (some string) None info 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 print_mini_c =
let f source_file syntax display_format optimize = ( let f source_file syntax display_format optimize =
toplevel ~display_format @@ return_result ~display_format (Mini_c.Formatter.program_format) @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind mini_c = Compile.Of_typed.compile typed in let%bind mini_c = Compile.Of_typed.compile typed in
match optimize with match optimize with
| None -> ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c | None -> ok @@ Mini_c.Formatter.Raw mini_c
| Some entry_point -> | Some entry_point ->
let%bind mini_c = Compile.Of_mini_c.aggregate_contract mini_c entry_point in let%bind o = Compile.Of_mini_c.aggregate_contract mini_c entry_point in
ok @@ Format.asprintf "%a\n" Mini_c.PP.expression mini_c ok @@ Mini_c.Formatter.Optimized o
)
in in
let term = Term.(const f $ source_file 0 $ syntax $ display_format $ optimize) in let term = Term.(const f $ source_file 0 $ syntax $ display_format $ optimize) in
let cmdname = "print-mini-c" in let cmdname = "print-mini-c" in
@ -257,11 +245,12 @@ let print_mini_c =
(Term.ret term, Term.info ~doc cmdname) (Term.ret term, Term.info ~doc cmdname)
let measure_contract = let measure_contract =
let f source_file entry_point syntax display_format = let f source_file entry_point syntax display_format =
toplevel ~display_format @@ let value =
let%bind contract = Compile.Utils.compile_file source_file syntax entry_point in let%bind contract = Compile.Utils.compile_file source_file syntax entry_point in
let open Tezos_utils in ok @@ Tezos_utils.Michelson.measure contract in
ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract) 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 in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format) in
@ -271,24 +260,23 @@ let measure_contract =
let compile_parameter = let compile_parameter =
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
toplevel ~display_format @@ 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 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 mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let env = Ast_typed.program_environment Environment.default typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state 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 mini_c_param = Compile.Of_typed.compile_expression typed_param in
let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
let%bind () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in let%bind () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_parameter michelson_prg compiled_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 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 Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in
in
let term = 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 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 let cmdname = "compile-parameter" in
@ -297,27 +285,21 @@ let compile_parameter =
let interpret = let interpret =
let f expression init_file syntax amount balance sender source predecessor_timestamp display_format = let f expression init_file syntax amount balance sender source predecessor_timestamp display_format =
toplevel ~display_format @@ return_result ~display_format (Uncompile.Formatter.expression_format) @@
let%bind (decl_list,state,env) = match init_file with let%bind (decl_list,state,env) = match init_file with
| Some init_file -> | Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in 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%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let env = Ast_typed.program_environment Environment.default typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
ok (mini_c_prg,state,env) ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Environment.default) in | 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 (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 mini_c_exp = Compile.Of_typed.compile_expression typed_exp in
let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
match runres with Uncompile.uncompile_expression typed_exp.type_expression runres
| 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
in in
let term = let term =
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
@ -327,10 +309,9 @@ let interpret =
let temp_ligo_interpreter = let temp_ligo_interpreter =
let f source_file syntax display_format = let f source_file syntax display_format =
toplevel ~display_format @@ return_result ~display_format (Ligo_interpreter.Formatter.program_format) @@
let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in let%bind typed,_ = Compile.Utils.type_file source_file syntax Env in
let%bind res = Compile.Of_typed.some_interpret typed in Compile.Of_typed.some_interpret typed
ok @@ Format.asprintf "%s\n" res
in in
let term = let term =
Term.(const f $ source_file 0 $ syntax $ display_format ) in Term.(const f $ source_file 0 $ syntax $ display_format ) in
@ -340,24 +321,22 @@ let temp_ligo_interpreter =
let compile_storage = let compile_storage =
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
toplevel ~display_format @@ 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 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 mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let env = Ast_typed.program_environment Environment.default typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
let%bind (typed_param,_) = Compile.Utils.type_expression (Some source_file) syntax expression env state 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 mini_c_param = Compile.Of_typed.compile_expression typed_param in
let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
let%bind () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in let%bind () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_storage michelson_prg compiled_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 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 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 term = 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 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 let cmdname = "compile-storage" in
@ -366,28 +345,22 @@ let compile_storage =
let dry_run = let dry_run =
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ 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%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 env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
let%bind compiled_params = Compile.Utils.compile_storage storage input source_file syntax env state mini_c_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 args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
match runres with Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
| Fail fail_res -> in
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 term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "dry-run" in let cmdname = "dry-run" in
@ -396,31 +369,25 @@ let dry_run =
let run_function = let run_function =
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ return_result ~display_format (Uncompile.Formatter.expression_format) @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in 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 env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) 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 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 sugar_param = Compile.Of_imperative.compile_expression imperative_param in
let%bind core_param = Compile.Of_sugar.compile_expression sugar_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 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 (typed_app,_) = Compile.Of_core.compile_expression ~env ~state app in
let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in
match runres with Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
| Fail fail_res -> in
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 term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "run-function" in let cmdname = "run-function" in
@ -429,16 +396,15 @@ let run_function =
let evaluate_value = let evaluate_value =
let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ return_result ~display_format Uncompile.Formatter.expression_format @@
let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in 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 mini_c = Compile.Of_typed.compile typed_prg in
let%bind (exp,_) = Mini_c.get_entry mini_c entry_point 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 compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in let%bind runres = Run.run_expression ~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 Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point runres
ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output in
in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "evaluate-value" in let cmdname = "evaluate-value" in
@ -447,13 +413,12 @@ let evaluate_value =
let compile_expression = let compile_expression =
let f expression syntax display_format michelson_format = let f expression syntax display_format michelson_format =
toplevel ~display_format @@ return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
let env = Environment.default in let env = Environment.default in
let state = Typer.Solver.initial_state in let state = Typer.Solver.initial_state in
let%bind compiled_exp = Compile.Utils.compile_expression None syntax expression env 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 Run.evaluate_expression compiled_exp.expr compiled_exp.expr_ty
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in
in
let term = let term =
Term.(const f $ expression "" 1 $ req_syntax 0 $ display_format $ michelson_code_format) in Term.(const f $ expression "" 1 $ req_syntax 0 $ display_format $ michelson_code_format) in
let cmdname = "compile-expression" in let cmdname = "compile-expression" in
@ -461,7 +426,10 @@ let compile_expression =
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
let dump_changelog = 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 = let term =
Term.(const f $ display_format) in Term.(const f $ display_format) in
let cmdname = "changelog" in let cmdname = "changelog" in
@ -469,14 +437,14 @@ let dump_changelog =
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
let list_declarations = let list_declarations =
let f source_file syntax = let f source_file syntax display_format =
toplevel ~display_format:(`Human_readable) @@ return_result ~display_format Formatter.declarations_format @@
let%bind core_prg = Compile.Utils.to_core source_file syntax in let%bind core_prg = Compile.Utils.to_core source_file syntax in
let json_decl = List.map (fun decl -> `String decl) @@ Compile.Of_core.list_declarations core_prg in let declarations = Compile.Of_core.list_declarations core_prg in
ok @@ J.to_string @@ `Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ] ok (source_file, declarations)
in in
let term = 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 cmdname = "list-declarations" in
let doc = "Subcommand: List all the top-level declarations." in let doc = "Subcommand: List all the top-level declarations." in
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)

36
src/bin/cli_helpers.ml
View File

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

6
src/bin/cli_helpers.mli
View File

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

2
src/bin/dune
View File

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

34
src/bin/expect_tests/code_insertion.ml
View File

@ -8,19 +8,21 @@ let bad_contract basename =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_1.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_1.ligo" ; "main" ] ;
[%expect{| [%expect{|
ligo: generated Michelson contract failed to typecheck: bad contract type ligo: error
{ parameter nat ; generated Michelson contract failed to typecheck : bad contract type
storage nat ; code:
code { DUP ; { parameter nat ;
LAMBDA (pair nat nat) nat ADD ; storage nat ;
SWAP ; code { DUP ;
EXEC ; LAMBDA (pair nat nat) nat ADD ;
NIL operation ; SWAP ;
PAIR ; EXEC ;
DIP { DROP } } } NIL operation ;
PAIR ;
DIP { DROP } } }
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -30,11 +32,13 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_2.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_2.ligo" ; "main" ] ;
[%expect{| [%expect{|
ligo: in file "bad_michelson_insertion_2.ligo", line 5, characters 32-40. different kinds: {"a":"nat","b":"( nat * nat )"} ligo: error
in file "bad_michelson_insertion_2.ligo", line 3, character 0 to line 5, character 41
Constant declaration 'main'
Bad types: expected nat got ( nat * nat )
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

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

@ -29,11 +29,17 @@ let%expect_test _ =
run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
[%expect {| [%expect {|
ligo: different kinds: {"a":"record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]"} ligo: error
Provided storage type does not match contract storage type
Bad types: expected record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,
cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,
next_id -> nat] got sum[Buy_single -> record[card_to_buy -> nat] ,
Sell_single -> record[card_to_sell -> nat] ,
Transfer_single -> record[card_to_transfer -> nat ,
destination -> address]]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -42,11 +48,17 @@ let%expect_test _ =
run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
[%expect {| [%expect {|
ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]","b":"record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]"} ligo: error
Provided parameter type does not match contract parameter type
Bad types: expected sum[Buy_single -> record[card_to_buy -> nat] ,
Sell_single -> record[card_to_sell -> nat] ,
Transfer_single -> record[card_to_transfer -> nat ,
destination -> address]] got record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,
cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,
next_id -> nat]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1321,10 +1333,12 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; contract "bad_type_operator.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; contract "bad_type_operator.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: bad type operator (type_operator: Map (binding)): ligo: error
in file "bad_type_operator.ligo", line 4, characters 16-29
unrecognized type operator (type_operator: Map (binding))
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1334,11 +1348,12 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; contract "bad_address_format.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; contract "bad_address_format.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "bad_address_format.religo", line 2, characters 26-48. Badly formatted literal: @"KT1badaddr" {"location":"in file \"bad_address_format.religo\", line 2, characters 26-48"} ligo: error
in file "bad_address_format.religo", line 2, characters 26-48
Badly formatted literal: @"KT1badaddr"
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1348,11 +1363,12 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; contract "bad_timestamp.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; contract "bad_timestamp.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "bad_timestamp.ligo", line 7, characters 30-44. Badly formatted timestamp "badtimestamp": {"location":"in file \"bad_timestamp.ligo\", line 7, characters 30-44"} ligo: error
in file "bad_timestamp.ligo", line 7, characters 30-44
Badly formatted timestamp 'badtimestamp'
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1385,10 +1401,11 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "self_in_lambda.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "self_in_lambda.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: Wrong SELF_ADDRESS location: SELF_ADDRESS is only allowed at top-level ligo: error
SELF_ADDRESS is only allowed at top-level
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1410,10 +1427,13 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "long_sum_type_names.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "long_sum_type_names.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: Too long constructor 'Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt': names length is limited to 32 (tezos limitation) ligo: error
in file "long_sum_type_names.ligo", line 2, character 2 to line 4, character 18
Too long constructor 'Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt'
names length are limited to 32 (tezos limitation)
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1428,11 +1448,15 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: redundant constructor: {"constructor":"Add","environment":"- E[]\tT[union_a -> sum[Add -> int , Remove -> int]\nbool -> sum[false -> unit , true -> unit]]"} ligo: error
in file "redundant_constructors.mligo", line 7, character 2 to line 9, character 15
Redundant constructor:
Add
- Env:[] Type env:[union_a -> sum[Add -> int , Remove -> int]
bool -> sum[false -> unit , true -> unit]]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1442,11 +1466,14 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#2 = #P in\n let p = rhs#2.0 in\n let s = rhs#2.1 in\n ( LIST_EMPTY() : (type_operator: list(operation)) , store ) ,\n NONE() : (type_operator: option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} ligo: error
in file "create_contract_toplevel.mligo", line 3, characters 0-3
Constant declaration 'main'
in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8
Free variable 'store' is not allowed in CREATE_CONTRACT lambda
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1455,11 +1482,14 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#2 = #P in\n let p = rhs#2.0 in\n let s = rhs#2.1 in\n ( LIST_EMPTY() : (type_operator: list(operation)) , a ) ,\n NONE() : (type_operator: option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} ligo: error
in file "create_contract_var.mligo", line 5, characters 0-3
Constant declaration 'main'
in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5
Free variable 'a' is not allowed in CREATE_CONTRACT lambda
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1468,11 +1498,13 @@ ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, char
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_no_inline.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_no_inline.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_no_inline.mligo", line 3, characters 40-46. unbound type variable: {"variable":"return","location":"in file \"create_contract_no_inline.mligo\", line 3, characters 40-46","in":"- E[foo -> int]\tT[bool -> sum[false -> unit , true -> unit]]","did_you_mean":"no suggestion"} ligo: error
in file "create_contract_no_inline.mligo", line 3, characters 40-46
Unbound type variable 'return'
- Env:[foo -> int] Type env:[bool -> sum[false -> unit , true -> unit]]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1522,11 +1554,14 @@ ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, char
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "self_type_annotation.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "self_type_annotation.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "self_type_annotation.ligo", line 8, characters 41-64. bad self type: expected (type_operator: Contract (int)) but got (type_operator: Contract (nat)) {"location":"in file \"self_type_annotation.ligo\", line 8, characters 41-64"} ligo: error
in file "self_type_annotation.ligo", line 8, characters 41-64
Bad self type
expected (type_operator: Contract (int))
got (type_operator: Contract (nat))
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1549,11 +1584,13 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "bad_contract.mligo", line 4, characters 0-3. badly typed contract: unexpected entrypoint type {"location":"in file \"bad_contract.mligo\", line 4, characters 0-3","entrypoint":"main","entrypoint_type":"( nat * int ) -> int"} ligo: error
in file "bad_contract.mligo", line 4, characters 0-3
Badly typed contract:
unexpected entrypoint type ( nat * int ) -> int
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1562,11 +1599,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract2.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract2.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "bad_contract2.mligo", line 5, characters 0-3. bad return type: expected (type_operator: list(operation)), got string {"location":"in file \"bad_contract2.mligo\", line 5, characters 0-3","entrypoint":"main"} ligo: error
in file "bad_contract2.mligo", line 5, characters 0-3
Badly typed contract:
expected (type_operator: list(operation)) but got string
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1575,11 +1614,15 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract3.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract3.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "bad_contract3.mligo", line 5, characters 0-3. badly typed contract: expected {int} and {string} to be the same in the entrypoint type {"location":"in file \"bad_contract3.mligo\", line 5, characters 0-3","entrypoint":"main","entrypoint_type":"( nat * int ) -> ( (type_operator: list(operation)) * string )"} ligo: error
in file "bad_contract3.mligo", line 5, characters 0-3
Badly typed contract main:
expected storage type as right member of a pair in the input and output, but got:
- int in the input
- string in the output
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1631,11 +1674,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "self_bad_entrypoint_format.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "self_bad_entrypoint_format.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "self_bad_entrypoint_format.ligo", line 8, characters 52-58. bad entrypoint format: entrypoint "Toto" is badly formatted. We expect "%bar" for entrypoint Bar and "%default" when no entrypoint used {"location":"in file \"self_bad_entrypoint_format.ligo\", line 8, characters 52-58"} ligo: error
in file "self_bad_entrypoint_format.ligo", line 8, characters 52-58
Bad entrypoint format 'Toto'
We expect '%bar' for entrypoint Bar and '%default' when no entrypoint used
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1644,11 +1689,12 @@ let%expect_test _ =
run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_1.religo"; "main"]; run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_1.religo"; "main"];
[%expect {| [%expect {|
ligo: It looks like you have nested a big map inside another big map. This is not supported. : {} ligo: error
in file "nested_bigmap_1.religo", line 1, characters 11-29
It looks like you have nested a big map inside another big map, this is not supported
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1657,11 +1703,12 @@ let%expect_test _ =
run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_2.religo"; "main"]; run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_2.religo"; "main"];
[%expect {| [%expect {|
ligo: It looks like you have nested a big map inside another big map. This is not supported. : {} ligo: error
in file "nested_bigmap_2.religo", line 2, characters 29-50
It looks like you have nested a big map inside another big map, this is not supported
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1670,11 +1717,12 @@ let%expect_test _ =
run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_3.religo"; "main"]; run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_3.religo"; "main"];
[%expect {| [%expect {|
ligo: It looks like you have nested a big map inside another big map. This is not supported. : {} ligo: error
in file "nested_bigmap_3.religo", line 1, characters 11-29
It looks like you have nested a big map inside another big map, this is not supported
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -1683,11 +1731,12 @@ let%expect_test _ =
run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_4.religo"; "main"]; run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_4.religo"; "main"];
[%expect {| [%expect {|
ligo: It looks like you have nested a big map inside another big map. This is not supported. : {} ligo: error
in file "nested_bigmap_4.religo", line 2, characters 39-60
It looks like you have nested a big map inside another big map, this is not supported
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

30
src/bin/expect_tests/error_messages_tests.ml
View File

@ -3,18 +3,18 @@ open Cli_expect
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/gitlab_111.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/gitlab_111.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Parse error in file "gitlab_111.religo", line 2, characters 0-3 at "let", after "=": ligo: error
This is an incorrect let binding. Parse error in file "gitlab_111.religo", line 2, characters 0-3 at "let", after "=":
- This is an incorrect let binding.
Examples of correct let bindings: -
let a: int = 4; Examples of correct let bindings:
let (a: int, b: int) = (1, 2); let a: int = 4;
let func = (a: int, b: int) => a + b; let (a: int, b: int) = (1, 2);
{} let func = (a: int, b: int) => a + b;
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -23,13 +23,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/missing_rpar.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/missing_rpar.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Parse error in file "missing_rpar.religo", line 5, characters 0-3 at "let", after "m": ligo: error
Missing `)`. Parse error in file "missing_rpar.religo", line 5, characters 0-3 at "let", after "m":
{} Missing `)`.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

2
src/bin/expect_tests/failwith_tests.ml
View File

@ -12,7 +12,7 @@ let%expect_test _ =
run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ; "--format=json" ] ; run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ; "--format=json" ] ;
[%expect {| [%expect {|
{"status":"ok","content":"failwith(42)"} |}]; {"value":null,"failure":"failwith(42)"} |}];
run_ligo_good [ "dry-run" ; contract "subtle_nontail_fail.mligo" ; "main" ; "()" ; "()" ] ; run_ligo_good [ "dry-run" ; contract "subtle_nontail_fail.mligo" ; "main" ; "()" ; "()" ] ;

244
src/bin/expect_tests/lexer_tests.ml
View File

@ -3,14 +3,14 @@ open Cli_expect
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "broken_string.ligo", line 1, characters 18-19: ligo: error
The string starting here is interrupted by a line break. Lexical error in file "broken_string.ligo", line 1, characters 18-19:
Hint: Remove the break, close the string before or insert a backslash. The string starting here is interrupted by a line break.
{} Hint: Remove the break, close the string before or insert a backslash.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -20,14 +20,14 @@ ligo: : Lexical error in file "broken_string.ligo", line 1, characters 18-19:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "broken_string.mligo", line 1, characters 8-9: ligo: error
The string starting here is interrupted by a line break. Lexical error in file "broken_string.mligo", line 1, characters 8-9:
Hint: Remove the break, close the string before or insert a backslash. The string starting here is interrupted by a line break.
{} Hint: Remove the break, close the string before or insert a backslash.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -37,14 +37,14 @@ ligo: : Lexical error in file "broken_string.mligo", line 1, characters 8-9:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "broken_string.religo", line 1, characters 8-9: ligo: error
The string starting here is interrupted by a line break. Lexical error in file "broken_string.religo", line 1, characters 8-9:
Hint: Remove the break, close the string before or insert a backslash. The string starting here is interrupted by a line break.
{} Hint: Remove the break, close the string before or insert a backslash.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -54,14 +54,14 @@ ligo: : Lexical error in file "broken_string.religo", line 1, characters 8-9:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "negative_byte_sequence.ligo", line 1, characters 18-31: ligo: error
Negative byte sequence. Lexical error in file "negative_byte_sequence.ligo", line 1, characters 18-31:
Hint: Remove the leading minus sign. Negative byte sequence.
{} Hint: Remove the leading minus sign.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -71,14 +71,14 @@ ligo: : Lexical error in file "negative_byte_sequence.ligo", line 1, characters
run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "negative_byte_sequence.mligo", line 1, characters 8-21: ligo: error
Negative byte sequence. Lexical error in file "negative_byte_sequence.mligo", line 1, characters 8-21:
Hint: Remove the leading minus sign. Negative byte sequence.
{} Hint: Remove the leading minus sign.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -88,14 +88,14 @@ ligo: : Lexical error in file "negative_byte_sequence.mligo", line 1, characters
run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "negative_byte_sequence.religo", line 1, characters 8-21: ligo: error
Negative byte sequence. Lexical error in file "negative_byte_sequence.religo", line 1, characters 8-21:
Hint: Remove the leading minus sign. Negative byte sequence.
{} Hint: Remove the leading minus sign.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -124,14 +124,14 @@ ligo: : Lexical error in file "reserved_name.ligo", line 1, characters 4-13:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "reserved_name.religo", line 1, characters 4-7: ligo: error
Reserved name: "end". Lexical error in file "reserved_name.religo", line 1, characters 4-7:
Hint: Change the name. Reserved name: "end".
{} Hint: Change the name.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -141,14 +141,14 @@ ligo: : Lexical error in file "reserved_name.religo", line 1, characters 4-7:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "reserved_name.mligo", line 1, characters 4-10: ligo: error
Reserved name: "object". Lexical error in file "reserved_name.mligo", line 1, characters 4-10:
Hint: Change the name. Reserved name: "object".
{} Hint: Change the name.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -158,13 +158,13 @@ ligo: : Lexical error in file "reserved_name.mligo", line 1, characters 4-10:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "unexpected_character.ligo", line 1, characters 18-19: ligo: error
Unexpected character '\239'. Lexical error in file "unexpected_character.ligo", line 1, characters 18-19:
{} Unexpected character '\239'.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -174,13 +174,13 @@ ligo: : Lexical error in file "unexpected_character.ligo", line 1, characters 18
run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "unexpected_character.mligo", line 1, characters 8-9: ligo: error
Unexpected character '\239'. Lexical error in file "unexpected_character.mligo", line 1, characters 8-9:
{} Unexpected character '\239'.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -190,13 +190,13 @@ ligo: : Lexical error in file "unexpected_character.mligo", line 1, characters 8
run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "unexpected_character.religo", line 1, characters 8-9: ligo: error
Unexpected character '\239'. Lexical error in file "unexpected_character.religo", line 1, characters 8-9:
{} Unexpected character '\239'.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -206,13 +206,13 @@ ligo: : Lexical error in file "unexpected_character.religo", line 1, characters
run_ligo_bad [ "compile-contract" ; "../../test/lexer/unterminated_comment.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/unterminated_comment.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Preprocessing error in file "../../test/lexer/unterminated_comment.mligo", line 1, characters 0-2: ligo: error
Unterminated comment. Preprocessing error in file "../../test/lexer/unterminated_comment.mligo", line 1, characters 0-2:
Hint: Close with "*)". {} Unterminated comment.
Hint: Close with "*)".
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -222,14 +222,14 @@ ligo: : Preprocessing error in file "../../test/lexer/unterminated_comment.mligo
run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20: ligo: error
Invalid symbol. Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20:
Hint: Check the LIGO syntax you use. Invalid symbol.
{} Hint: Check the LIGO syntax you use.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -239,14 +239,14 @@ ligo: : Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13: ligo: error
Invalid symbol. Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13:
Hint: Check the LIGO syntax you use. Invalid symbol.
{} Hint: Check the LIGO syntax you use.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -256,14 +256,14 @@ ligo: : Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "invalid_symbol.religo", line 1, characters 10-11: ligo: error
Invalid symbol. Lexical error in file "invalid_symbol.religo", line 1, characters 10-11:
Hint: Check the LIGO syntax you use. Invalid symbol.
{} Hint: Check the LIGO syntax you use.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -273,14 +273,14 @@ ligo: : Lexical error in file "invalid_symbol.religo", line 1, characters 10-11:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "missing_break.ligo", line 1, characters 18-18: ligo: error
Missing break. Lexical error in file "missing_break.ligo", line 1, characters 18-18:
Hint: Insert some space. Missing break.
{} Hint: Insert some space.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -290,14 +290,14 @@ ligo: : Lexical error in file "missing_break.ligo", line 1, characters 18-18:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "missing_break.mligo", line 1, characters 11-11: ligo: error
Missing break. Lexical error in file "missing_break.mligo", line 1, characters 11-11:
Hint: Insert some space. Missing break.
{} Hint: Insert some space.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -307,14 +307,14 @@ ligo: : Lexical error in file "missing_break.mligo", line 1, characters 11-11:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "missing_break.religo", line 1, characters 11-11: ligo: error
Missing break. Lexical error in file "missing_break.religo", line 1, characters 11-11:
Hint: Insert some space. Missing break.
{} Hint: Insert some space.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -324,14 +324,14 @@ ligo: : Lexical error in file "missing_break.religo", line 1, characters 11-11:
run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "invalid_character_in_string.ligo", line 1, characters 19-20: ligo: error
Invalid character in string. Lexical error in file "invalid_character_in_string.ligo", line 1, characters 19-20:
Hint: Remove or replace the character. Invalid character in string.
{} Hint: Remove or replace the character.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -341,14 +341,14 @@ ligo: : Lexical error in file "invalid_character_in_string.ligo", line 1, charac
run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "invalid_character_in_string.mligo", line 1, characters 9-10: ligo: error
Invalid character in string. Lexical error in file "invalid_character_in_string.mligo", line 1, characters 9-10:
Hint: Remove or replace the character. Invalid character in string.
{} Hint: Remove or replace the character.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -358,14 +358,14 @@ ligo: : Lexical error in file "invalid_character_in_string.mligo", line 1, chara
run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Lexical error in file "invalid_character_in_string.religo", line 1, characters 9-10: ligo: error
Invalid character in string. Lexical error in file "invalid_character_in_string.religo", line 1, characters 9-10:
Hint: Remove or replace the character. Invalid character in string.
{} Hint: Remove or replace the character.
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

14
src/bin/expect_tests/literals.ml
View File

@ -7,11 +7,12 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ; run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
[%expect {| [%expect {|
ligo: in file "", line 0, characters 0-33. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 0-33"} ligo: error
in file "", line 0, characters 0-33
Badly formatted literal: Signature thisisnotasignature
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -25,11 +26,12 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ; run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
[%expect {| [%expect {|
ligo: in file "", line 0, characters 0-27. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 0-27"} ligo: error
in file "", line 0, characters 0-27
Badly formatted literal: key thisisnotapublickey
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

19
src/bin/expect_tests/michelson_converter.ml
View File

@ -8,10 +8,13 @@ let bad_contract basename =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_no_annotation.mligo") ; "l4"] ; run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_no_annotation.mligo") ; "l4"] ;
[%expect {| [%expect {|
ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve type declaration order in the converted record, you need to annotate it ligo: error
in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39
Constant declaration 'l4'
Can't retrieve type declaration order in the converted record, you need to annotate it
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -20,10 +23,14 @@ let%expect_test _ =
run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_short_record.mligo") ; "l1"] ; run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_short_record.mligo") ; "l1"] ;
[%expect {| [%expect {|
ligo: in file "michelson_converter_short_record.mligo", line 4, characters 9-44. converted record must have at least two elements ligo: error
in file "michelson_converter_short_record.mligo", line 4, characters 9-44
Constant declaration 'l1'
in file "michelson_converter_short_record.mligo", line 1, characters 10-23
Converted record must have at least two elements
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

9
src/bin/expect_tests/michelson_or_tests.ml
View File

@ -29,11 +29,14 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_or.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_or.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "bad_michelson_or.mligo", line 6, characters 12-27. michelson_or types must be annotated: {"constructor":"M_right","location":"in file \"bad_michelson_or.mligo\", line 6, characters 12-27"} ligo: error
in file "bad_michelson_or.mligo", line 5, characters 0-3
Constant declaration 'main'
in file "bad_michelson_or.mligo", line 6, characters 12-27
michelson_or contructor M_right must be annotated with a sum type
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

42
src/bin/expect_tests/misc_cli_commands.ml
View File

@ -13,10 +13,46 @@ let%expect_test _ =
(* list-declarations *) (* list-declarations *)
let%expect_test _ = let%expect_test _ =
run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.ligo" ] ; run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.ligo" ] ;
[%expect {| {"source_file":"../../test/contracts/loop.ligo","declarations":["inner_capture_in_conditional_block","dummy","nested_for_collection_local_var","nested_for_collection","for_collection_map_k","for_collection_map_kv","for_collection_empty","for_collection_with_patches","for_collection_comp_with_acc","for_collection_proc_call","for_collection_rhs_capture","for_collection_if_and_local_var","for_collection_set","for_collection_list","for_sum_step","for_sum","while_sum","counter"]} |} ]; [%expect {|
../../test/contracts/loop.ligo declarations:
inner_capture_in_conditional_block
dummy
nested_for_collection_local_var
nested_for_collection
for_collection_map_k
for_collection_map_kv
for_collection_empty
for_collection_with_patches
for_collection_comp_with_acc
for_collection_proc_call
for_collection_rhs_capture
for_collection_if_and_local_var
for_collection_set
for_collection_list
for_sum_step
for_sum
while_sum
counter |} ];
run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.mligo" ; "--format=json" ] ;
[%expect {|
{"source_file":"../../test/contracts/loop.mligo","declarations":["counter_nest","aux_nest","counter","counter_simple","aux_simple"]} |} ];
run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.mligo" ] ; run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.mligo" ] ;
[%expect {| {"source_file":"../../test/contracts/loop.mligo","declarations":["counter_nest","aux_nest","counter","counter_simple","aux_simple"]} |} ]; [%expect {|
../../test/contracts/loop.mligo declarations:
counter_nest
aux_nest
counter
counter_simple
aux_simple |} ];
run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.religo" ] ; run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.religo" ] ;
[%expect {| {"source_file":"../../test/contracts/loop.religo","declarations":["counter_nest","aux_nest","counter","counter_simple","aux_simple"]} |} ]; [%expect {|
../../test/contracts/loop.religo declarations:
counter_nest
aux_nest
counter
counter_simple
aux_simple |} ];

29
src/bin/expect_tests/syntax_error_tests.ml
View File

@ -3,12 +3,12 @@ open Cli_expect
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_syntax.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_syntax.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: : Parse error in file "error_syntax.ligo", line 1, characters 16-17 at "-", after "bar": ligo: error
16: <syntax error> {} Parse error in file "error_syntax.ligo", line 1, characters 16-17 at "-", after "bar":
16: <syntax error>
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -17,17 +17,18 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_arguments.religo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_arguments.religo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_function_arguments.religo", line 1, characters 14-27. : It looks like you are defining a function, however we do not ligo: error
understand the parameters declaration. in file "error_function_arguments.religo", line 1, characters 14-27
Examples of valid functions: It looks like you are defining a function, however we do not
let x = (a: string, b: int) : int => 3; understand the parameters declaration.
let tuple = ((a, b): (int, int)) => a + b; Examples of valid functions:
let x = (a: string) : string => "Hello, " ++ a; let x = (a: string, b: int) : int => 3;
{"location":"in file \"error_function_arguments.religo\", line 1, characters 14-27"} let tuple = ((a, b): (int, int)) => a + b;
let x = (a: string) : string => "Hello, " ++ a;
If you're not sure how to fix this error, you can
do one of the following:
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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

144
src/bin/expect_tests/typer_error_tests.ml
View File

@ -3,11 +3,13 @@ open Cli_expect
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_1.mligo"; "main"]; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_1.mligo"; "main"];
[%expect {| [%expect {|
ligo: in file "error_function_annotation_1.mligo", line 1, characters 0-3. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"unit","b":"int"} ligo: error
in file "error_function_annotation_1.mligo", line 1, characters 0-3
Constant declaration 'main'
Bad types: expected int -> unit got int -> int
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -16,11 +18,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_2.mligo"; "f"]; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_2.mligo"; "f"];
[%expect {| [%expect {|
ligo: in file "error_function_annotation_2.mligo", line 1, characters 14-43. different kinds: {"a":"int","b":"( int * int ) -> int"} ligo: error
in file "error_function_annotation_2.mligo", line 1, characters 14-43
Constant declaration 'f'
Bad types: expected int got ( int * int ) -> int
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -29,11 +33,18 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_3.mligo"; "f"]; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_3.mligo"; "f"];
[%expect {| [%expect {|
ligo: in file "error_function_annotation_3.mligo", line 6, characters 0-3. different kinds: {"a":"( (type_operator: list(operation)) * sum[Add -> int , Sub -> int] )","b":"sum[Add -> int , Sub -> int]"} ligo: error
in file "error_function_annotation_3.mligo", line 6, characters 0-3
Constant declaration 'main'
Bad types: expected ( int * sum[Add -> int , Sub -> int] ) -> ( (type_operator: list(operation)) *
sum[Add -> int ,
Sub -> int] ) got ( int *
sum[Add -> int ,
Sub -> int] ) -> sum[Add -> int ,
Sub -> int]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -42,11 +53,12 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_no_tail_recursive_function.mligo"; "f"]; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_no_tail_recursive_function.mligo"; "f"];
[%expect {| [%expect {|
ligo: in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21. Recursion must be achieved through tail-calls only: {"function":"unvalid","location":"in file \"error_no_tail_recursive_function.mligo\", line 2, characters 14-21"} ligo: error
in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21
Recursion must be achieved through tail-calls only
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -55,10 +67,15 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_type.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_type.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_type.ligo", line 3, characters 18-28. Adding modulo with wrong types: Expected arguments with one of the following combinations of types: add(nat , nat) or add(int , int) or add(mutez , mutez) or add(nat , int) or add(int , nat) or add(timestamp , int) or add(int , timestamp) but got this combination instead: add(int , string) ligo: error
in file "error_type.ligo", line 3, characters 18-28
Constant declaration 'foo'
Expected arguments with one of the following combinations of type:
(nat , nat) or (int , int) or (mutez , mutez) or (nat , int) or (int , nat) or (timestamp , int) or (int , timestamp)
but got int , string
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -67,11 +84,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_1.mligo", line 3, characters 19-27. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"int"} ligo: error
in file "error_typer_1.mligo", line 3, characters 19-27
Constant declaration 'foo'
Bad types: expected string got int
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -80,11 +99,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_2.mligo", line 3, characters 24-39. different type constructors: Expected these two n-ary type constructors to be the same, but they're different {"a":"(type_operator: list(string))","b":"(type_operator: option(int))"} ligo: error
in file "error_typer_2.mligo", line 3, characters 24-39
Constant declaration 'foo'
Bad types: expected (type_operator: list(string)) got (type_operator: option(int))
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -93,11 +114,14 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"( int * string * sum[false -> unit , true -> unit] )","b":"( int * string )"} ligo: error
in file "error_typer_3.mligo", line 3, characters 34-53
Constant declaration 'foo'
Bad types: expected ( int * string * sum[false -> unit , true -> unit] ) got ( int *
string )
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -106,11 +130,18 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in records: {"key_a":"c","key_b":"b","a":"record[a -> int , c -> sum[false -> unit , true -> unit] , d -> string]","b":"record[a -> int , b -> string , c -> sum[false -> unit , true -> unit]]"} ligo: error
in file "error_typer_4.mligo", line 4, characters 17-56
Constant declaration 'foo'
Bad types: expected record[a -> int ,
c -> sum[false -> unit , true -> unit] ,
d -> string] got record[a -> int ,
b -> string ,
c -> sum[false -> unit ,
true -> unit]]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -119,11 +150,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_5.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_5.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_5.mligo", line 1, characters 10-17. unbound type variable: {"variable":"boolean","location":"in file \"error_typer_5.mligo\", line 1, characters 10-17","in":"- E[]\tT[bool -> sum[false -> unit , true -> unit]]","did_you_mean":"bool"} ligo: error
in file "error_typer_5.mligo", line 1, characters 10-17
Unbound type variable 'boolean'
- Env:[] Type env:[bool -> sum[false -> unit , true -> unit]]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -132,11 +165,13 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_6.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_6.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_6.mligo", line 1, characters 30-64. different kinds: {"a":"string","b":"sum[false -> unit , true -> unit]"} ligo: error
in file "error_typer_6.mligo", line 1, characters 30-64
Constant declaration 'foo'
Bad types: expected (type_operator: Map (int,string)) got (type_operator: Map (int,sum[false -> unit , true -> unit]))
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -145,11 +180,16 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "error_typer_7.mligo", line 4, characters 18-48. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[a -> int , b -> string]","b":"record[a -> int , b -> string , c -> sum[false -> unit , true -> unit]]"} ligo: error
in file "error_typer_7.mligo", line 4, characters 17-56
Constant declaration 'foo'
Bad types: expected record[a -> int , b -> string] got record[a -> int ,
b -> string ,
c -> sum[false -> unit ,
true -> unit]]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can do one of the following:
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/introduction * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -158,12 +198,16 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , ligo: error
owner -> address , in file "id.mligo", line 28, characters 0-3
profile -> bytes] Constant declaration 'buy'
in file "id.mligo", line 3, character 18 to line 7, character 1
Expected an option but got record[controller -> address ,
owner -> address ,
profile -> bytes]
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -181,10 +225,11 @@ let%expect_test _ =
run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ; run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ;
[%expect {| [%expect {|
ligo: not a comparable type: pair (use (a,(b,c)) instead of (a,b,c)) ligo: error
pair does not have a comparable structure. (hint: use (a,(b,c)) instead of (a,b,c))
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt
@ -194,10 +239,15 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/failwith_wrong_type.ligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/failwith_wrong_type.ligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "failwith_wrong_type.ligo", line 2, characters 19-46. Failwith with disallowed type: Expected arguments with one of the following combinations of types: failwith(string) or failwith(nat) or failwith(int) but got this combination instead: failwith((type_operator: list(int))) ligo: error
in file "failwith_wrong_type.ligo", line 2, characters 19-46
Constant declaration 'bad'
Expected arguments with one of the following combinations of type:
(string) or (nat) or (int)
but got (type_operator: list(int))
If you're not sure how to fix this error, you can
do one of the following: 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 * Visit our documentation: https://ligolang.org/docs/intro/introduction
* Ask a question on our Discord: https://discord.gg/9rhYaEt * Ask a question on our Discord: https://discord.gg/9rhYaEt

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

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

1
src/main/compile/dune
View File

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

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

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

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

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

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

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

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

@ -1,71 +1,43 @@
open Main_errors
open Tezos_utils open Tezos_utils
open Proto_alpha_utils open Proto_alpha_utils
open Trace open Trace
module Errors = struct let build_contract : ?disable_typecheck:bool -> Compiler.compiled_expression -> (Michelson.michelson , _) result =
(*
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 =
fun ?(disable_typecheck= false) compiled -> 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 = 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 Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in
let%bind storage_michelson = 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 Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in
let contract = Michelson.contract param_michelson storage_michelson compiled.expr in let contract = Michelson.contract param_michelson storage_michelson compiled.expr in
if disable_typecheck then if disable_typecheck then
ok contract ok contract
else else
let%bind res = 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 Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
match res with match res with
| Type_checked -> ok contract | Type_checked -> ok contract
| Err_parameter -> fail @@ Errors.bad_parameter contract () | Err_parameter -> fail @@ bad_parameter contract
| Err_storage -> fail @@ Errors.bad_storage contract () | Err_storage -> fail @@ bad_storage contract
| Err_contract -> fail @@ Errors.bad_contract contract () | Err_contract -> fail @@ bad_contract contract
| Err_gas -> fail @@ Errors.ran_out_of_gas () | Err_gas -> fail @@ gas_exhaustion
| Err_unknown -> fail @@ Errors.unknown () | Err_unknown -> fail @@ unknown
type check_type = Check_parameter | Check_storage let assert_equal_contract_type : Simple_utils.Runned_result.check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> (unit , _) result =
let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result =
fun c compiled_prg compiled_param -> fun c compiled_prg compiled_param ->
let%bind (Ex_ty expected_ty) = 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 match c with
| Check_parameter -> ok c_param_ty | Check_parameter -> ok c_param_ty
| Check_storage -> ok c_storage_ty in | Check_storage -> ok c_storage_ty in
let (Ex_ty actual_ty) = compiled_param.expr_ty in let (Ex_ty actual_ty) = compiled_param.expr_ty in
let%bind _ = 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 Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in
ok () ok ()

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

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

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

@ -1,20 +1,20 @@
open Trace open Trace
open Helpers 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 syntax = syntax_to_variant syntax (Some source_filename) in
let%bind abstract = parsify syntax source_filename in let%bind abstract = parsify syntax source_filename in
ok abstract 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 let%bind abstract = parsify_string syntax source in
ok abstract 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 -> fun syntax exp ->
parsify_expression 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 -> fun storage parameter syntax ->
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
ok @@ Ast_imperative.e_pair storage parameter ok @@ Ast_imperative.e_pair storage parameter
@ -26,4 +26,4 @@ let preprocess source_filename syntax =
Helpers.preprocess syntax source_filename Helpers.preprocess syntax source_filename
let pretty_print source_filename syntax = let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename Helpers.pretty_print syntax source_filename

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

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

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

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

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

@ -14,7 +14,7 @@ let to_core f stx =
let%bind core = Of_sugar.compile sugar in let%bind core = Of_sugar.compile sugar in
ok @@ core 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 core = to_core f stx in
let%bind typed,state = Of_core.compile env core in let%bind typed,state = Of_core.compile env core in
ok @@ (typed,state) ok @@ (typed,state)
@ -24,7 +24,7 @@ let to_mini_c f stx env =
let%bind mini_c = Of_typed.compile typed in let%bind mini_c = Of_typed.compile typed in
ok @@ mini_c 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 typed, _ = type_file f stx @@ Contract ep in
let%bind mini_c = Of_typed.compile typed in let%bind mini_c = Of_typed.compile typed in
let%bind michelson = Of_mini_c.aggregate_and_compile_contract mini_c ep in let%bind michelson = Of_mini_c.aggregate_and_compile_contract mini_c ep in

105
src/main/display.ml
View File

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

32
src/main/display.mli
View File

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

1
src/main/dune
View File

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

1
src/main/main.ml
View File

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

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

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

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

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

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

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

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

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

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

@ -2,33 +2,12 @@ open Proto_alpha_utils
open Trace open Trace
open Memory_proto_alpha.Protocol.Script_ir_translator open Memory_proto_alpha.Protocol.Script_ir_translator
open Memory_proto_alpha.X open Memory_proto_alpha.X
open Simple_utils.Runned_result
module Errors = struct module Errors = Main_errors
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
type options = Memory_proto_alpha.options 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 = type dry_run_options =
{ amount : string ; { amount : string ;
balance : string ; balance : string ;
@ -36,23 +15,15 @@ type dry_run_options =
sender : string option ; sender : string option ;
source : string option } source : string option }
let failwith_to_string (f:run_failwith_res) : string result = let make_dry_run_options (opts : dry_run_options) : (options , _) 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 open Proto_alpha_utils.Trace in let open Proto_alpha_utils.Trace in
let open Proto_alpha_utils.Memory_proto_alpha in let open Proto_alpha_utils.Memory_proto_alpha in
let open Protocol.Alpha_context in let open Protocol.Alpha_context in
let%bind balance = match Tez.of_string opts.balance with 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 | Some balance -> ok balance in
let%bind amount = match Tez.of_string opts.amount with 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 | Some amount -> ok amount in
let%bind sender = let%bind sender =
match opts.sender with match opts.sender with
@ -60,7 +31,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
| Some sender -> | Some sender ->
let%bind sender = let%bind sender =
trace_alpha_tzresult trace_alpha_tzresult
(simple_error "invalid address") (fun _ -> Errors.invalid_address sender)
(Contract.of_b58check sender) in (Contract.of_b58check sender) in
ok (Some sender) in ok (Some sender) in
let%bind source = let%bind source =
@ -69,7 +40,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
| Some source -> | Some source ->
let%bind source = let%bind source =
trace_alpha_tzresult trace_alpha_tzresult
(simple_error "invalid source address") (fun _ -> Errors.invalid_address source)
(Contract.of_b58check source) in (Contract.of_b58check source) in
ok (Some source) in ok (Some source) in
let%bind predecessor_timestamp = let%bind predecessor_timestamp =
@ -78,33 +49,33 @@ let make_dry_run_options (opts : dry_run_options) : options result =
| Some st -> | Some st ->
match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with
| Some t -> ok (Some t) | 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 () 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 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 Memory_proto_alpha.unparse_michelson_data value ty
let pack_payload (payload:Michelson.t) ty = let pack_payload (payload:Michelson.t) ty =
let%bind payload = 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 Memory_proto_alpha.parse_michelson_data payload ty in
let%bind data = 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 Memory_proto_alpha.pack ty payload in
ok @@ data ok @@ data
let fetch_lambda_types (contract_ty:ex_ty) = let fetch_lambda_types (contract_ty:ex_ty) =
match contract_ty with match contract_ty with
| Ex_ty (Lambda_t (in_ty, out_ty, _)) -> ok (Ex_ty in_ty, Ex_ty out_ty) | 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 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 (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in
let%bind input = 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 Memory_proto_alpha.parse_michelson_data input_michelson input_ty
in in
let top_level = Script_ir_translator.Toplevel 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 ty_stack_after = Script_typed_ir.Item_t (output_ty, Empty_t, None) in
let exp = Michelson.strip_annots exp in let exp = Michelson.strip_annots exp in
let%bind descr = 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 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 open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind res = 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 Memory_proto_alpha.failure_interpret ?options descr (Item(input, Empty)) in
match res with match res with
| Memory_proto_alpha.Succeed stack -> | 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)) | Int (_ , i) -> ok @@ Fail (Failwith_int (Z.to_int i))
| String (_ , s) -> ok @@ Fail (Failwith_string s) | String (_ , s) -> ok @@ Fail (Failwith_string s)
| Bytes (_, s) -> ok @@ Fail (Failwith_bytes 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 open! Tezos_raw_protocol_006_PsCARTHA in
let (Ex_ty exp_type') = exp_type in let (Ex_ty exp_type') = exp_type in
let exp = Michelson.strip_annots exp 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_before = Script_typed_ir.Empty_t
and ty_stack_after = Script_typed_ir.Item_t (exp_type', Empty_t, None) in and ty_stack_after = Script_typed_ir.Item_t (exp_type', Empty_t, None) in
let%bind descr = 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 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 open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind res = 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 Memory_proto_alpha.failure_interpret ?options descr Empty in
match res with match res with
| Memory_proto_alpha.Succeed stack -> | 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)) | Int (_ , i) -> ok @@ Fail (Failwith_int (Z.to_int i))
| String (_ , s) -> ok @@ Fail (Failwith_string s) | String (_ , s) -> ok @@ Fail (Failwith_string s)
| Bytes (_, s) -> ok @@ Fail (Failwith_bytes 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 let%bind expr = run_expression ?options exp exp_type in
match expr with 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 | 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 let%bind expr = run_expression ?options exp exp_type in
match expr with match expr with
| Success tval -> ok tval | 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 evaluate_expression ?options exp exp_type =
let%bind etv = run_expression ?options exp exp_type in let%bind etv = run_expression ?options exp exp_type in
match etv with match etv with
| Success etv' -> ex_value_ty_to_michelson etv' | Success etv' -> ex_value_ty_to_michelson etv'
| Fail res -> | Fail res -> fail @@ Errors.failwith res
let%bind str = failwith_to_string res in
fail @@ Errors.failwith str ()

1
src/main/uncompile/dune
View File

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

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

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

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

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

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

@ -69,14 +69,6 @@ module ParserLog =
module Unit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) 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 apply parser =
let local_fail error = let local_fail error =
Trace.fail Trace.fail

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

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

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

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

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

@ -612,6 +612,8 @@ let pattern_to_string ~offsets ~mode =
to_string ~offsets ~mode print_pattern to_string ~offsets ~mode print_pattern
let expr_to_string ~offsets ~mode = let expr_to_string ~offsets ~mode =
to_string ~offsets ~mode print_expr 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} *) (** {1 Pretty-printing the AST} *)

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

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

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

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

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

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

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

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

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

@ -68,14 +68,6 @@ module ParserLog =
module Unit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) 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 apply parser =
let local_fail error = let local_fail error =
Trace.fail Trace.fail

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

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

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

@ -806,6 +806,12 @@ let pattern_to_region = function
| PList PCons {region; _} | PList PCons {region; _}
| PTuple {region; _} -> 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 let lhs_to_region : lhs -> Region.t = function
Path path -> path_to_region path Path path -> path_to_region path
| MapPath {region; _} -> region | MapPath {region; _} -> region

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

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

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

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

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

@ -1,5 +1,3 @@
open Trace
module AST = Parser_cameligo.AST module AST = Parser_cameligo.AST
module LexToken = Parser_reasonligo.LexToken module LexToken = Parser_reasonligo.LexToken
module Lexer = Lexer.Make (LexToken) module Lexer = Lexer.Make (LexToken)
@ -72,42 +70,6 @@ module ParserLog =
module Unit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) 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 apply parser =
let local_fail error = let local_fail error =
Trace.fail Trace.fail

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

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

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

@ -1,5 +1,6 @@
[@@@warning "-45"] [@@@warning "-45"]
open Errors_cameligo
open Trace open Trace
open Ast_imperative open Ast_imperative
@ -18,152 +19,6 @@ let pseq_to_list = function
| Some lst -> npseq_to_list lst | Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value 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 open Operators.Concrete_to_imperative.Cameligo
let r_split = Location.r_split 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 | PPar p -> unpar_pattern p.value.inside
| _ as p -> p | _ as p -> p
and compile_type_expression : Raw.type_expr -> type_expression result = fun te -> and compile_type_expression : Raw.type_expr -> (type_expression, abs_error) result = fun te ->
trace (simple_info "abstracting this type expression...") @@ trace (abstracting_type_expr_tracer te) @@
match te with match te with
TPar x -> compile_type_expression x.value.inside TPar x -> compile_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
@ -255,38 +110,39 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
(match lst with (match lst with
| [a ; b ; c ; d ] -> ( | [a ; b ; c ; d ] -> (
let%bind b' = 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 get_t_string_singleton_opt b in
let%bind d' = 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 get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d' 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" -> | "michelson_pair" ->
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
(match lst with (match lst with
| [a ; b ; c ; d ] -> ( | [a ; b ; c ; d ] -> (
let%bind b' = 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 get_t_string_singleton_opt b in
let%bind d' = 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 get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d' 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 lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_map_list compile_type_expression lst in let%bind lst' = bind_map_list compile_type_expression lst in
let%bind cst = let%bind cst =
trace_option (unknown_predefined_type name) @@ trace_option (unknown_predefined_type name) @@
type_operators name.value in type_operators name.value in
ok @@ t_operator ~loc cst lst' ) ok @@ t_operator ~loc cst lst'
)
) )
| TProd p -> ( | TProd p -> (
let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in 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 @@ 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 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 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 match lst with
| [] -> ok @@ t_unit () | [] -> ok @@ t_unit ()
| [hd] -> compile_type_expression hd | [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 ok @@ t_tuple lst
let rec compile_expression : 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 return x = ok x in
let compile_projection = fun (p:Raw.projection Region.reg) -> let compile_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in let (p , loc) = r_split p in
@ -377,7 +233,7 @@ let compile_update (u: Raw.update Region.reg) =
let aux ur ((var, path), expr) = let aux ur ((var, path), expr) =
ok @@ e_update ~loc ur (Access_record var :: path) expr ok @@ e_update ~loc ur (Access_record var :: path) expr
in bind_fold_list aux record updates' in bind_fold_list aux record updates'
in trace (abstracting_expr t) @@ in trace (abstracting_expr_tracer t) @@
match t with match t with
Raw.ELetIn e -> Raw.ELetIn e ->
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
@ -464,7 +320,7 @@ in trace (abstracting_expr t) @@
| Some t -> ok @@ t | Some t -> ok @@ t
| None -> match rhs'.expression_content with | None -> match rhs'.expression_content with
| E_ascription a -> ok a.type_annotation | E_ascription a -> ok a.type_annotation
| _ -> fail @@ untyped_recursive_function e | _ -> fail @@ untyped_recursive_fun e.Region.region
in in
let expression_content = E_recursive {fun_name;fun_type;lambda} 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 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 *) (* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) -> | (f, p1 :: ps) ->
fail @@ unsupported_let_in_function e.region (f :: p1 :: ps) fail @@ unsupported_let_in_function (f :: p1 :: ps)
end end
| Raw.EAnnot a -> | Raw.EAnnot a ->
let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in
@ -645,7 +501,7 @@ in trace (abstracting_expr t) @@
return @@ e_raw_code ~loc language code 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 return x = ok x in
let (lamb , loc) = r_split lamb' in let (lamb , loc) = r_split lamb' in
let%bind params' = let%bind params' =
@ -756,7 +612,7 @@ and compile_fun lamb' : expr result =
return @@ ret_lamb 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 let return x = ok @@ make_option_typed x te_annot in
match t with match t with
| BoolExpr (False reg) -> ( | BoolExpr (False reg) -> (
@ -786,7 +642,7 @@ and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
compile_binop "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 let return x = ok @@ x in
match t with match t with
ECons c -> compile_binop "CONS" c 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' 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 return x = ok @@ x in
let (args , loc) = r_split t in let (args , loc) = r_split t in
let%bind a = compile_expression args.arg1 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 let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ; b ] 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 return x = ok @@ x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = compile_expression t.arg in let%bind a = compile_expression t.arg in
let%bind name = trace_option (unknown_built_in name) @@ constants name in let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ] 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 let return x = ok @@ x in
match lst with match lst with
| [] -> return @@ e_literal ?loc Literal_unit | [] -> 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 let%bind lst = bind_list @@ List.map compile_expression lst in
return @@ e_tuple ?loc lst 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 -> fun t ->
let open! Raw in let open! Raw in
let loc : 'a . 'a Raw.reg -> _ -> _ = 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 gen_access_tuple name ~i: (i + 1) ~accesses
in ok (gen_access_tuple name) in ok (gen_access_tuple name)
(* TODO: Improve this error message *) (* TODO: Improve this error message *)
| other -> fail @@ abstracting_expr other | other -> fail @@ bad_deconstruction other
in let%bind decls = in let%bind decls =
(* TODO: Rewrite the gen_access_tuple so there's no List.rev *) (* TODO: Rewrite the gen_access_tuple so there's no List.rev *)
bind_map_list process_variable (List.combine variables (List.rev expr_bind_lst)) bind_map_list process_variable (List.combine variables (List.rev expr_bind_lst))
@ -939,7 +795,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
| Some _ -> match rhs'.expression_content with | Some _ -> match rhs'.expression_content with
E_lambda lambda -> E_lambda lambda ->
(match lhs_type with (match lhs_type with
None -> fail @@ untyped_recursive_function var None -> fail @@ untyped_recursive_fun var.Region.region
| Some (lhs_type) -> | Some (lhs_type) ->
let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in
ok @@ {rhs' with expression_content}) 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'))] 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 -> fun t ->
let open Raw in let open Raw in
let rec get_var (t:Raw.pattern) = 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 get_single (t:Raw.pattern) =
let t' = get_tuple t in let t' = get_tuple t in
let%bind () = let%bind () =
trace_strong (unsupported_tuple_pattern t) @@ Assert.assert_list_size (unsupported_tuple_pattern t) t' 1 in
Assert.assert_list_size t' 1 in
ok (List.hd t') in ok (List.hd t') in
let rec get_constr (t:Raw.pattern) = let rec get_constr (t:Raw.pattern) =
match t with match t with
@ -1011,8 +866,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
let%bind patterns = let%bind patterns =
let aux (x , y) = let aux (x , y) =
let xs = get_tuple x in let xs = get_tuple x in
trace_strong (unsupported_tuple_pattern x) @@ let%bind () = Assert.assert_list_size (unsupported_tuple_pattern x) xs 1 in
Assert.assert_list_size xs 1 >>? fun () ->
ok (List.hd xs , y) ok (List.hd xs , y)
in in
bind_map_list aux t 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 (PCons c), cons); (PList (PListComp sugar_nil), nil)]
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] -> | [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
let%bind () = let%bind () =
trace_strong (unsupported_sugared_lists sugar_nil.region) Assert.assert_list_empty (unsupported_sugared_lists sugar_nil.region)
@@ Assert.assert_list_empty
@@ pseq_to_list @@ pseq_to_list
@@ sugar_nil.value.elements in @@ sugar_nil.value.elements in
let%bind (a, b) = let%bind (a, b) =
@ -1034,27 +887,18 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
ok (a, b) in ok (a, b) in
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil} ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil}
| lst -> | 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 () = let as_variant () =
trace (simple_info "currently, only booleans, lists, options, and constructors \ trace_strong (unsupported_pattern_type (List.map fst lst)) @@
are supported in patterns") @@
let%bind constrs = let%bind constrs =
let aux (x, y) = let aux (x, y) =
let%bind x' = trace (error x) @@ get_constr x let%bind x' = get_constr x
in ok (x', y) in ok (x', y)
in bind_map_list aux lst in bind_map_list aux lst
in ok @@ ez_match_variant constrs in in ok @@ ez_match_variant constrs in
let as_option () = let as_option () =
trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let aux (x, y) = 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 in ok (x', y) in
let%bind constrs = bind_map_list aux lst in let%bind constrs = bind_map_list aux lst in
match constrs with match constrs with
@ -1065,9 +909,12 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
ok @@ Match_option { ok @@ Match_option {
match_some = (Var.of_name some_var, some_expr); match_some = (Var.of_name some_var, some_expr);
match_none = none_expr } match_none = none_expr }
| _ -> simple_fail "bad option pattern" | _ -> fail @@ corner_case "bad option pattern"
in bind_or (as_option () , as_variant ()) in bind_or (as_option () , as_variant ())
let compile_program : Raw.ast -> program result = fun t -> let compile_program : Raw.ast -> (program , abs_error) result = fun t ->
let%bind decls = bind_map_list compile_declaration @@ nseq_to_list t.decl in 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 ok @@ List.concat @@ decls

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

@ -7,56 +7,8 @@ module Raw = Parser.Cameligo.AST
module SMap = Map.String module SMap = Map.String
module Option = Simple_utils.Option 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 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 compile_expression : Raw.expr -> (expr, Errors_cameligo.abs_error) result
(*
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_program : Raw.ast -> (program, 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

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

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

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

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

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

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

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

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

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

@ -1,9 +1,10 @@
open Errors_pascaligo
open Trace open Trace
open Ast_imperative open Ast_imperative
module Raw = Parser.Pascaligo.AST module Raw = Parser.Pascaligo.AST
module SMap = Map.String module SMap = Map.String
module ParserLog = Parser_pascaligo.ParserLog (* module ParserLog = Parser_pascaligo.ParserLog *)
open Combinators open Combinators
@ -14,114 +15,6 @@ let pseq_to_list = function
| Some lst -> npseq_to_list lst | Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value 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 open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split let r_split = Location.r_split
@ -156,7 +49,7 @@ let get_t_string_singleton_opt = function
| _ -> None | _ -> 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 match t with
TPar x -> compile_type_expression x.value.inside TPar x -> compile_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
@ -181,31 +74,31 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
(match lst with (match lst with
| [a ; b ; c ; d ] -> ( | [a ; b ; c ; d ] -> (
let%bind b' = 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 get_t_string_singleton_opt b in
let%bind d' = 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 get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d' 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" -> | "michelson_pair" ->
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
(match lst with (match lst with
| [a ; b ; c ; d ] -> ( | [a ; b ; c ; d ] -> (
let%bind b' = 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 get_t_string_singleton_opt b in
let%bind d' = 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 get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d' 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 lst = npseq_to_list tuple.value.inside in
let%bind lst = let%bind lst =
@ -213,7 +106,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let%bind cst = let%bind cst =
trace_option (unknown_predefined_type name) @@ trace_option (unknown_predefined_type name) @@
type_operators name.value in type_operators name.value in
ok @@ t_operator ~loc cst lst) ok @@ t_operator ~loc cst lst )
| TProd p -> | TProd p ->
let%bind tpl = compile_list_type_expression let%bind tpl = compile_list_type_expression
@@ npseq_to_list p.value in @@ 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 @@ 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 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 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 match lst with
| [] -> ok @@ t_unit () | [] -> ok @@ t_unit ()
| [hd] -> compile_type_expression hd | [hd] -> compile_type_expression hd
@ -278,7 +171,7 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
ok @@ e_accessor ~loc var path' 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 let return x = ok x in
match t with match t with
| EAnnot a -> ( | EAnnot a -> (
@ -423,7 +316,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
let (mi , loc) = r_split mi in let (mi , loc) = r_split mi in
let%bind lst = let%bind lst =
let lst = List.map get_value @@ pseq_to_list mi.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = let aux : Raw.binding -> (expression * expression, (abs_error)) result =
fun b -> fun b ->
let%bind src = compile_expression b.source in let%bind src = compile_expression b.source in
let%bind dst = compile_expression b.image 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 (mi , loc) = r_split mi in
let%bind lst = let%bind lst =
let lst = List.map get_value @@ pseq_to_list mi.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = let aux : Raw.binding -> (expression * expression, (abs_error)) result =
fun b -> fun b ->
let%bind src = compile_expression b.source in let%bind src = compile_expression b.source in
let%bind dst = compile_expression b.image 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 ok @@ e_update ~loc ur (Access_record var :: path) expr
in bind_fold_list aux record updates' 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 match t with
| BoolExpr (False reg) -> | BoolExpr (False reg) ->
ok @@ e_bool ~loc:(Location.lift reg) false 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) -> | CompExpr (Neq c) ->
compile_binop "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 let return x = ok x in
match t with match t with
ECons c -> ECons c ->
@ -521,7 +414,7 @@ and compile_list_expression (t:Raw.list_expr) : expression result =
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_list ~loc [] 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 match t with
| SetMem x -> ( | SetMem x -> (
let (x' , loc) = r_split x in 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' 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 return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = compile_expression t.arg1 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 let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ; b ] 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 return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = compile_expression t.arg in let%bind a = compile_expression t.arg in
let%bind name = trace_option (unknown_built_in name) @@ constants name in let%bind name = trace_option (unknown_built_in name) @@ constants name in
return @@ e_constant ~loc name [ a ] 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 let return x = ok x in
match lst with match lst with
| [] -> return @@ e_literal Literal_unit | [] -> 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 in return_let_in ~loc binder inline expr
and compile_param : and compile_param :
Raw.param_decl -> (string * type_expression) result = Raw.param_decl -> (string * type_expression, (abs_error)) result =
fun t -> fun t ->
match t with match t with
| ParamConst c -> | ParamConst c ->
@ -609,7 +502,7 @@ and compile_param :
and compile_fun_decl : and compile_fun_decl :
loc:_ -> Raw.fun_decl -> loc:_ -> Raw.fun_decl ->
((expression_variable * type_expression option) * expression) result = ((expression_variable * type_expression option) * expression , (abs_error)) result =
fun ~loc x -> fun ~loc x ->
let open! Raw in let open! Raw in
let {kwd_recursive;fun_name; param; ret_type; block_with; let {kwd_recursive;fun_name; param; ret_type; block_with;
@ -686,7 +579,7 @@ and compile_fun_decl :
) )
and compile_fun_expression : 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 -> fun ~loc x ->
let open! Raw in let open! Raw in
let {param; ret_type; return; _} : fun_expr = x 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 hook (compile_data_declaration d :: acc) statements
in bind_list @@ hook [] (List.rev 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 -> fun t ->
match t with match t with
| ProcCall x -> ( | ProcCall x -> (
@ -996,7 +889,7 @@ and compile_selection : Raw.selection -> access = function
FieldName property -> Access_record property.value FieldName property -> Access_record property.value
| Component index -> Access_tuple (snd index.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 open Raw in
let get_var (t:Raw.pattern) = let get_var (t:Raw.pattern) =
match t with 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 get_single (t: Raw.pattern) =
let t' = get_tuple t in let t' = get_tuple t in
let%bind () = let%bind () =
trace_strong (unsupported_tuple_pattern t) @@ Assert.assert_list_size (unsupported_tuple_pattern t) t' 1 in
Assert.assert_list_size t' 1 in
ok (List.hd t') in ok (List.hd t') in
let get_toplevel (t : Raw.pattern) = let get_toplevel (t : Raw.pattern) =
match t with match t with
@ -1052,7 +944,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
let (_, v) = v.value in let (_, v) = v.value in
let%bind v = match v.value.inside with let%bind v = match v.value.inside with
| PVar v -> ok v.value | 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) } ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some) }
) )
| [(PList PCons c, cons) ; (PList (PNil _), nil)] | [(PList PCons c, cons) ; (PList (PNil _), nil)]
@ -1068,33 +960,23 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
in in
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil} ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil}
| lst -> | lst ->
trace (simple_info "currently, only booleans, options, lists and \
user-defined constructors are supported in patterns") @@
let%bind constrs = let%bind constrs =
trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let aux (x , y) = 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' = let%bind x' =
trace error @@
get_constr x in get_constr x in
ok (x' , y) in ok (x' , y) in
bind_map_list aux lst in bind_map_list aux lst in
ok @@ ez_match_variant constrs ok @@ ez_match_variant constrs
and compile_instruction : Raw.instruction -> (_ -> expression result) result = and compile_instruction : Raw.instruction -> ((_ -> (expression, (abs_error)) result) , (abs_error)) result =
fun t -> trace (abstracting_instruction t) @@ compile_single_instruction t 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 -> fun statements ->
let lst = npseq_to_list statements in let lst = npseq_to_list statements in
let%bind fs = compile_statement_list lst 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 -> fun prec cur ->
let%bind res = cur prec let%bind res = cur prec
in ok @@ Some res in 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 let%bind ret = bind_fold_right_list aux expr' fs in
ok @@ Option.unopt_exn ret 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 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 open Raw in
let rec hook acc = function let rec hook acc = function
[] -> acc [] -> acc
@ -1169,5 +1051,8 @@ and compile_declaration_list declarations : declaration Location.wrap list resul
hook (bind_list_cons res acc) declarations hook (bind_list_cons res acc) declarations
in hook (ok @@ []) (List.rev declarations) in hook (ok @@ []) (List.rev declarations)
let compile_program : Raw.ast -> program result = let compile_program : Raw.ast -> (program , (abs_error)) result =
fun t -> compile_declaration_list @@ nseq_to_list t.decl fun t ->
let declarations = nseq_to_list t.decl in
trace (program_tracer declarations) @@
compile_declaration_list declarations

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

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

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

@ -1,23 +1,16 @@
open Errors
open Ast_imperative open Ast_imperative
open Trace open Trace
open Stage_common.Helpers open Stage_common.Helpers
module Errors = struct let peephole_type_expression : type_expression -> (type_expression , self_ast_imperative_error) result = fun e ->
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 return type_content = ok {type_content; location=e.location } in let return type_content = ok {type_content; location=e.location } in
match e.type_content with match e.type_content with
| T_sum cmap -> | T_sum cmap ->
let%bind _uu = bind_map_cmapi let%bind _uu = bind_map_cmapi
(fun k _ -> (fun k _ ->
let (Constructor name) = k in 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 () else ok ()
) )
cmap in cmap in

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

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

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

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

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

@ -1,57 +1,9 @@
open Errors
open Ast_imperative open Ast_imperative
open Trace open Trace
open Proto_alpha_utils open Proto_alpha_utils
module Errors = struct let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
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 return expression_content = ok { e with expression_content } in let return expression_content = ok { e with expression_content } in
match e.expression_content with match e.expression_content with
| E_literal (Literal_key_hash s) as l -> ( | 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} -> ( | E_constant {cons_name=C_BIG_MAP_LITERAL as cst; arguments=lst} -> (
let%bind elt = let%bind elt =
trace_option (bad_single_arity cst e.location) @@ trace_option (bad_single_arity cst e) @@
List.to_singleton lst List.to_singleton lst
in in
let%bind lst = 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 get_e_list elt.expression_content
in in
let aux = fun (e : expression) -> let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@ trace_option (bad_map_param_type cst e) @@
let%bind tpl = get_e_tuple e.expression_content in Option.(get_e_tuple e.expression_content >>= fun t ->
let%bind (a , b) = List.to_pair t)
trace_option (simple_error "of pairs") @@
List.to_pair tpl
in
ok (a , b)
in in
let%bind pairs = bind_map_list aux lst in let%bind pairs = bind_map_list aux lst in
return @@ E_big_map pairs return @@ E_big_map pairs
) )
| E_constant {cons_name=C_MAP_LITERAL as cst; arguments=lst} -> ( | E_constant {cons_name=C_MAP_LITERAL as cst; arguments=lst} -> (
let%bind elt = let%bind elt =
trace_option (bad_single_arity cst e.location) @@ trace_option (bad_single_arity cst e) @@
List.to_singleton lst List.to_singleton lst
in in
let%bind lst = 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 get_e_list elt.expression_content
in in
let aux = fun (e : expression) -> let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@ trace_option (bad_map_param_type cst e) @@
let%bind tpl = get_e_tuple e.expression_content in Option.(get_e_tuple e.expression_content >>= fun t ->
let%bind (a , b) = List.to_pair t)
trace_option (simple_error "of pairs") @@
List.to_pair tpl
in
ok (a , b)
in in
let%bind pairs = bind_map_list aux lst in let%bind pairs = bind_map_list aux lst in
return @@ E_map pairs return @@ E_map pairs
) )
| E_constant {cons_name=C_BIG_MAP_EMPTY as cst; arguments=lst} -> ( | E_constant {cons_name=C_BIG_MAP_EMPTY as cst; arguments=lst} -> (
let%bind () = let%bind () =
trace_strong (bad_empty_arity cst e.location) @@ Assert.assert_list_empty (bad_empty_arity cst e) lst
Assert.assert_list_empty lst
in in
return @@ E_big_map [] return @@ E_big_map []
) )
| E_constant {cons_name=C_MAP_EMPTY as cst; arguments=lst} -> ( | E_constant {cons_name=C_MAP_EMPTY as cst; arguments=lst} -> (
let%bind () = let%bind () =
trace_strong (bad_empty_arity cst e.location) @@ Assert.assert_list_empty (bad_empty_arity cst e) lst
Assert.assert_list_empty lst
in in
return @@ E_map [] return @@ E_map []
) )
| E_constant {cons_name=C_SET_LITERAL as cst; arguments=lst} -> ( | E_constant {cons_name=C_SET_LITERAL as cst; arguments=lst} -> (
let%bind elt = let%bind elt =
trace_option (bad_single_arity cst e.location) @@ trace_option (bad_single_arity cst e) @@
List.to_singleton lst List.to_singleton lst
in in
let%bind lst = 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 get_e_list elt.expression_content
in in
return @@ E_set lst return @@ E_set lst
) )
| E_constant {cons_name=C_SET_EMPTY as cst; arguments=lst} -> ( | E_constant {cons_name=C_SET_EMPTY as cst; arguments=lst} -> (
let%bind () = let%bind () =
trace_strong (bad_empty_arity cst e.location) @@ Assert.assert_list_empty (bad_empty_arity cst e) lst
Assert.assert_list_empty lst
in in
return @@ E_set [] return @@ E_set []
) )

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

@ -1,7 +1,8 @@
open Errors
open Ast_imperative open Ast_imperative
open Trace 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 let return expression_content = ok { e with expression_content } in
match e.expression_content with match e.expression_content with
| E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]} | E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]}

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

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

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

@ -1,21 +1,11 @@
open Errors
open Ast_imperative open Ast_imperative
open Trace open Trace
module Errors = struct let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
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 return expression_content = ok { e with expression_content } in let return expression_content = ok { e with expression_content } in
match e.expression_content with 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 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_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)) | (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)) -> | (E_literal (Literal_string str) , T_constant (TC_timestamp)) ->
let str = Ligo_string.extract str in let str = Ligo_string.extract str in
let%bind time = 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 @@ Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation str in
let itime = Z.of_int64 @@ Tezos_utils.Time.Protocol.to_seconds time in let itime = Z.of_int64 @@ Tezos_utils.Time.Protocol.to_seconds time in
return @@ E_literal (Literal_timestamp itime) 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_address)) -> return @@ E_literal (Literal_address (Ligo_string.extract str))
| (E_literal (Literal_string str) , T_constant (TC_bytes)) -> ( | (E_literal (Literal_string str) , T_constant (TC_bytes)) -> (
let str = Ligo_string.extract str in let str = Ligo_string.extract str in
let%bind e' = e'_bytes str in let%bind e' = trace_option (bad_conversion_bytes e) @@ e'_bytes str in
return e' return e'
) )
| _ -> return e | _ -> return ec
) )
| e -> return e | e -> return e

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

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

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

@ -1,27 +1,8 @@
module Errors = Errors
module I = Ast_imperative module I = Ast_imperative
module O = Ast_sugar module O = Ast_sugar
open Trace 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 = let rec add_to_end (expression: O.expression) to_add =
match expression.expression_content with match expression.expression_content with
| O.E_let_in lt -> | 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) | 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 -> fun te ->
let return tc = ok @@ O.make_t ~loc:te.location tc in let return tc = ok @@ O.make_t ~loc:te.location tc in
match te.type_content with 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_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant | I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator (TC_michelson_or, [l;r]) -> | I.T_operator (TC_michelson_or, [l;r]) ->
let%bind (l, l_ann) = I.get_t_annoted l 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) = I.get_t_annoted r 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%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.constructor' * O.ctor_content) list = [ let sum : (O.constructor' * O.ctor_content) list = [
(O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann ; ctor_decl_pos = 0}); (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 in
return @@ O.T_sum (O.CMap.of_list sum) return @@ O.T_sum (O.CMap.of_list sum)
| I.T_operator (TC_michelson_pair, [l;r]) -> | I.T_operator (TC_michelson_pair, [l;r]) ->
let%bind (l, l_ann) = I.get_t_annoted l 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) = I.get_t_annoted r 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%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.label * O.field_content) list = [ let sum : (O.label * O.field_content) list = [
(O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann ; field_decl_pos = 0}); (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) return @@ T_operator (type_operator, lst)
| I.T_annoted (ty, _) -> compile_type_expression ty | 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 -> fun e ->
let%bind e = compile_expression' e in let%bind e = compile_expression' e in
ok @@ e None 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 -> fun e ->
let return expr = ok @@ function let return expr = ok @@ function
| None -> expr | None -> expr
@ -317,7 +298,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
let%bind w = compile_while w in let%bind w = compile_while w in
ok @@ w 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 -> fun path ->
let aux a = match a with let aux a = match a with
| I.Access_record s -> ok @@ O.Access_record s | I.Access_record s -> ok @@ O.Access_record s
@ -328,14 +309,14 @@ and compile_path : I.access list -> O.access list result =
in in
bind_map_list aux path 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}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option compile_type_expression input_type in 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 output_type = bind_map_option compile_type_expression output_type in
let%bind result = compile_expression result in let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result} 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 -> fun {matchee;cases} loc ->
let return expr = ok @@ function let return expr = ok @@ function
| None -> expr | None -> expr
@ -547,12 +528,12 @@ let compile_declaration : I.declaration Location.wrap -> _ =
let%bind te = compile_type_expression te in let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te) 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 -> fun p ->
bind_map_list compile_declaration p bind_map_list compile_declaration p
(* uncompiling *) (* 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 -> fun te ->
let return te = ok @@ I.make_t te in let return te = ok @@ I.make_t te in
match te.type_content with 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 let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst) 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 -> fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with match e.expression_content with
@ -680,7 +661,7 @@ let rec uncompile_expression : O.expression -> I.expression result =
return @@ I.E_sequence {expr1; expr2} return @@ I.E_sequence {expr1; expr2}
| O.E_skip -> return @@ I.E_skip | 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 fun path -> let aux a = match a with
| O.Access_record s -> ok @@ I.Access_record s | O.Access_record s -> ok @@ I.Access_record s
| O.Access_tuple i -> ok @@ I.Access_tuple i | O.Access_tuple i -> ok @@ I.Access_tuple i
@ -690,13 +671,13 @@ and uncompile_path : O.access list -> I.access list result =
in in
bind_map_list aux path 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}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option uncompile_type_expression input_type in 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 output_type = bind_map_option uncompile_type_expression output_type in
let%bind result = uncompile_expression result in let%bind result = uncompile_expression result in
ok @@ I.{binder;input_type;output_type;result} 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 -> fun m ->
match m with match m with
| O.Match_list {match_nil;match_cons} -> | O.Match_list {match_nil;match_cons} ->

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

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

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

@ -2,7 +2,12 @@ module I = Ast_sugar
module O = Ast_core module O = Ast_core
open Trace 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 -> fun te ->
let return tc = ok @@ O.make_t ~loc:te.location tc in let return tc = ok @@ O.make_t ~loc:te.location tc in
match te.type_content with 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 let%bind lst = bind_map_list compile_type_expression lst in
return @@ T_operator (type_operator, lst) 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 -> fun e ->
let return expr = ok @@ O.make_e ~loc:e.location expr in let return expr = ok @@ O.make_e ~loc:e.location expr in
match e.expression_content with 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 let m = O.LMap.of_list lst in
return @@ O.E_record m 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}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option compile_type_expression input_type in 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 output_type = bind_map_option compile_type_expression output_type in
let%bind result = compile_expression result in let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result} 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 -> fun loc e m ->
match m with match m with
| I.Match_list {match_nil;match_cons} -> | 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 let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te) 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 -> fun p ->
bind_map_list compile_declaration p bind_map_list compile_declaration p
(* uncompiling *) (* 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 -> fun te ->
let return te = ok @@ I.make_t te in let return te = ok @@ I.make_t te in
match te.type_content with 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 let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst) 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 -> fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with 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 let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation} 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}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option uncompile_type_expression input_type in 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 output_type = bind_map_option uncompile_type_expression output_type in
let%bind result = uncompile_expression result in let%bind result = uncompile_expression result in
ok @@ I.{binder;input_type;output_type;result} 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 -> fun m ->
match m with match m with
| O.Match_list {match_nil;match_cons} -> | O.Match_list {match_nil;match_cons} ->

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

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

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

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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -7,16 +7,20 @@ module DEnv = Environment
module Environment = O.Environment module Environment = O.Environment
module Solver = Solver module Solver = Solver
type environment = Environment.t type environment = Environment.t
module Errors = Errors module Errors = Typer_common.Errors
open Errors open Errors
module Map = RedBlackTrees.PolyMap module Map = RedBlackTrees.PolyMap
open Todo_use_fold_generator 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 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) -> | Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env 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 tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind (expr , state') = 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 type_expression env state expression in
let post_env = Environment.add_ez_declaration binder expr env in let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} )) ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
) )
and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state) result = 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 fun e state t i _ae loc -> match i with
| Match_option {match_none ; match_some} -> | Match_option {match_none ; match_some} ->
let%bind tv = 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 @@ get_t_option t in
let%bind (match_none , state') = type_expression e state match_none in let%bind (match_none , state') = type_expression e state match_none in
let (opt, b) = match_some 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'') ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
| Match_list {match_nil ; match_cons} -> | Match_list {match_nil ; match_cons} ->
let%bind t_elt = 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 @@ get_t_list t in
let%bind (match_nil , state') = type_expression e state match_nil in let%bind (match_nil , state') = type_expression e state match_nil in
let (hd, tl, b) = match_cons 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 Environment.get_constructor constructor_name e in
let%bind acc = match acc with let%bind acc = match acc with
| None -> ok (Some variant) | None -> ok (Some variant)
| Some variant' -> ( | Some variant' ->
trace (type_error let%bind () = trace_option (not_matching variant variant') @@
~msg:"in match variant" Ast_typed.assert_type_expression_eq (variant , variant') in
~expected:variant
~actual:variant'
~expression:ae
loc
) @@
Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
ok (Some variant) ok (Some variant)
) in in
ok acc in ok acc in
trace (simple_info "in match variant") @@ trace (in_match_variant_tracer i) @@
bind_fold_list aux None lst in bind_fold_list aux None lst in
let%bind variant = let%bind variant =
trace_option (match_empty_variant i loc) @@ trace_option (match_empty_variant i loc) @@
variant_opt in variant_opt in
let%bind () = let%bind () =
let%bind variant_cases' = 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 @@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' 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 match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c -> 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 in
let%bind () = let%bind () =
trace_strong (match_missing_case i loc) @@ trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in bind_iter_list test_case variant_cases in
let%bind () = let%bind () = Assert.assert_true (match_redundant_case i loc) @@
trace_strong (match_redundant_case i loc) @@ List.(length variant_cases = length match_cases) in
Assert.assert_true List.(length variant_cases = length match_cases) in
ok () ok ()
in in
let%bind (state'' , cases) = 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 Recursively search the type_expression and return a result containing the
type_value at the leaves 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 let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
match t.type_content with match t.type_content with
| T_arrow {type1;type2} -> | T_arrow {type1;type2} ->
@ -146,40 +143,63 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| T_constant cst -> | T_constant cst ->
return (T_constant (convert_type_constant cst)) return (T_constant (convert_type_constant cst))
| T_operator (op, lst) -> | T_operator (op, lst) ->
let%bind opt = match op,lst with ( match op,lst with
| TC_set, [s] -> | TC_set, [s] ->
let%bind s = evaluate_type e s in let%bind s = evaluate_type e s in
ok @@ O.TC_set (s) return @@ T_operator (O.TC_set s)
| TC_option, [o] -> | TC_option, [o] ->
let%bind o = evaluate_type e o in let%bind o = evaluate_type e o in
ok @@ O.TC_option (o) return @@ T_operator (O.TC_option o)
| TC_list, [l] -> | TC_list, [l] ->
let%bind l = evaluate_type e l in let%bind l = evaluate_type e l in
ok @@ O.TC_list (l) return @@ T_operator (O.TC_list l)
| TC_map, [k;v] -> | TC_map, [k;v] ->
let%bind k = evaluate_type e k in let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v 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] -> | TC_big_map, [k;v] ->
let%bind k = evaluate_type e k in let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v 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] -> | TC_map_or_big_map, [k;v] ->
let%bind k = evaluate_type e k in let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v 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] -> | TC_contract, [c] ->
let%bind c = evaluate_type e c in let%bind c = evaluate_type e c in
ok @@ O.TC_contract c return @@ T_operator (O.TC_contract c)
| TC_michelson_pair_right_comb, _c | TC_michelson_pair_left_comb, _c | TC_michelson_pair_right_comb, [c] ->
| TC_michelson_or_right_comb, _c | TC_michelson_or_left_comb, _c -> let%bind c' = evaluate_type e c in
(* not really sure what to do in the new typer, should be converted to a pair using functions defined in Helpers.Typer.Converter *) let%bind lmap = match c'.type_content with
simple_fail "to be implemented" | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail @@ bad_type_operator t | _ -> fail (michelson_comb_no_record t.location) in
in let record = Typer_common.Michelson_type_converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
return (T_operator (opt)) 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 () = 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 open Solver in
let module L = Logger.Stateful() 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 let expr' = make_e ~location expr tv in
ok @@ (expr' , new_state) in ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error = trace (expression_tracer ae) @@
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 @@
match ae.expression_content with match ae.expression_content with
(* TODO: this file should take care only of the order in which program fragments (* 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 *) (* Sum *)
| E_constructor {constructor;element} -> | E_constructor {constructor;element} ->
let%bind (c_tv, sum_tv) = let%bind (c_tv, sum_tv) = trace_option (unbound_constructor e constructor ae.location) @@
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 @@
Environment.get_constructor constructor e in Environment.get_constructor constructor e in
let%bind (expr' , state') = type_expression e state element 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 wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
let constructor = convert_constructor' constructor in let constructor = convert_constructor' constructor in
return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped 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" | _ -> failwith "Update an expression which is not a record"
in 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) return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *) (* Data-structure *)
| E_application {lamb;args} -> | 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} -> | E_constant {cons_name=name; arguments=lst} ->
let name = convert_constant' name in 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 aux acc expr =
let (lst , state) = acc in let (lst , state) = acc in
let%bind (expr, state') = type_expression e state expr 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 let wrapped = Wrap.lambda fresh input_type' output_type' result.type_expression in
ok (({binder;result}:O.lambda),state',wrapped) 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 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 let%bind tv = typer lst tv_opt in
ok(name, tv) ok(name, tv)
(* Apply type_declaration on every node of the AST_core from the root p *) (* 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 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%bind (e' , s' , d'_opt) = type_declaration e s (Location.unwrap d) in
let ds' = match d'_opt with 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') ok (e' , s' , ds')
in in
let%bind (env' , state' , declarations) = let%bind (env' , state' , declarations) =
trace (fun () -> program_error p ()) @@ trace (program_error_tracer p) @@
bind_fold_list aux (env , state , []) p in 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 *) let declarations = List.rev declarations in (* Common hack to have O(1) append: prepend and then reverse *)
ok (env', state', declarations) 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%bind (env, state, node) = type_xyz_returns_state env_state_node in
let subst_all = let subst_all =
let aliases = state.structured_dbs.aliases in 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 -> let substs : variable: I.type_variable -> _ = fun ~variable ->
to_option @@ to_option @@
let%bind root = 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. *) (* TODO: after upgrading UnionFind, this will be an option, not an exception. *)
try Some (Solver.UF.repr variable aliases) with Not_found -> None in try Some (Solver.UF.repr variable aliases) with Not_found -> None in
let%bind assignment = 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 (Map.find_opt root assignments) in
let O.{ tv ; c_tag ; tv_list } = assignment 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 () = 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 ok @@ expr
in in
let p = apply_substs ~substs node 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? *) let () = ignore env in (* TODO: shouldn't we use the `env` somewhere? *)
ok (node, state) 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_env = DEnv.default in
let empty_state = Solver.initial_state 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 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) -> fun (env, state, e) ->
let%bind (e , state) = type_expression env state e in let%bind (e , state) = type_expression env state e in
ok (env, state, e) 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. *) 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 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 let untype_expression = Untyper.untype_expression
(* These aliases are just here for quick navigation during debug, and can safely be removed later *) (* 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 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) result = type_match 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 result = evaluate_type e t 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) result = type_expression 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_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 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) result = type_program_returns_state (env, state, p) 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 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_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) result = type_program p 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) Trace.result = type_expression_returns_state 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) result = type_expression_subst env state ?tv_opt e let [@warning "-32"] type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state, typer_error) result = type_expression_subst env state ?tv_opt e

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

@ -1,5 +1,7 @@
open Trace open Trace
open Typer_common.Errors
module Errors = Typer_common.Errors
module I = Ast_core module I = Ast_core
module O = Ast_typed module O = Ast_typed
module O' = Typesystem.Solver_types module O' = Typesystem.Solver_types
@ -10,41 +12,12 @@ module Solver = Solver
type environment = Environment.t type environment = Environment.t
module Errors : sig 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 unbound_type_variable : environment -> string -> unit -> error val evaluate_type : environment -> I.type_expression -> (O.type_expression, typer_error) result
val unbound_variable : environment -> string -> Location.t -> unit -> error val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
val match_empty_variant : 'a I.matching -> Location.t -> unit -> error val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
val match_missing_case : 'a I.matching -> Location.t -> unit -> error val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression, typer_error) result
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 untype_type_expression : O.type_expression -> (I.type_expression, typer_error) result
val program_error : I.program -> unit -> error val untype_expression : O.expression -> (I.expression, typer_error) result
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

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

@ -1,4 +1,5 @@
open Trace open Trace
open Typer_common.Errors
module I = Ast_core module I = Ast_core
module O = Ast_typed 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_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
| C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_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 match t.type_meta with
| Some s -> ok s | 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 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? *) (* TODO: or should we use t.core if present? *)
let%bind t = match t.type_content with let%bind t = match t.type_content with
| O.T_sum x -> | O.T_sum x ->
@ -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 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 let open I in
match l with match l with
| Literal_unit -> ok Literal_unit | 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 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 open I in
let return e = ok e in let return e = ok e in
match e.expression_content with 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 let%bind fun_type = untype_type_expression fun_type in
return @@ e_recursive fun_name fun_type lambda return @@ e_recursive fun_name fun_type lambda
and untype_lambda ty {binder; result} : I.lambda result = and untype_lambda ty {binder; result} : (I.lambda, typer_error) result =
let%bind io = get_t_function ty in 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 (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression result in let%bind result = untype_expression result in
ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda) ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda)
@ -299,7 +300,7 @@ and untype_lambda ty {binder; result} : I.lambda result =
(* (*
Tranform a Ast_typed matching into an ast_core matching Tranform a Ast_typed matching into an ast_core matching
*) *)
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m -> and untype_matching : (O.expression -> (I.expression, typer_error) result) -> O.matching_expr -> (I.matching_expr, typer_error) result = fun f m ->
let open I in let open I in
match m with match m with
| Match_option {match_none ; match_some = {opt; body;tv=_}} -> | Match_option {match_none ; match_some = {opt; body;tv=_}} ->

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

@ -1,4 +1,3 @@
open Trace
open Ast_typed.Misc open Ast_typed.Misc
module Core = Typesystem.Core module Core = Typesystem.Core
@ -6,21 +5,6 @@ module I = Ast_core
module T = Ast_typed module T = Ast_typed
module O = Core 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 type constraints = O.type_constraint list
(* let add_type state t = *) (* let add_type state t = *)

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

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

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

@ -1,4 +1,5 @@
open Trace open Trace
open Typer_common.Errors
module I = Ast_core module I = Ast_core
module O = Ast_typed module O = Ast_typed
@ -12,220 +13,7 @@ module Solver = Typer_new.Solver
type environment = Environment.t type environment = Environment.t
module Errors = struct let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq
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 convert_constructor' (I.Constructor c) = O.Constructor c let convert_constructor' (I.Constructor c) = O.Constructor c
let unconvert_constructor' (O.Constructor c) = I.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_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
| C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_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 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%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 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) ok (e', loc ed' d' :: acc)
in in
let%bind (_, lst) = let%bind (_, lst) =
trace (fun () -> program_error p ()) @@ trace (program_error_tracer p) @@
bind_fold_list aux (DEnv.default, []) p in bind_fold_list aux (DEnv.default, []) p in
ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ())) 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) -> | Declaration_type (type_binder , type_expr) ->
let%bind tv = evaluate_type env type_expr in let%bind tv = evaluate_type env type_expr in
let env' = Environment.add_type (type_binder) tv env 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) -> ( | Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr = 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 type_expression' ?tv_opt:tv'_opt env expression in
let post_env = Environment.add_ez_declaration binder expr env in let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline})) ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
) )
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 fun f e t i _ae loc -> match i with
| Match_option {match_none ; match_some} -> | Match_option {match_none ; match_some} ->
let%bind tv = 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 @@ get_t_option t in
let%bind match_none = f e match_none in let%bind match_none = f e match_none in
let (opt, b) = match_some 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}}) ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
| Match_list {match_nil ; match_cons} -> | Match_list {match_nil ; match_cons} ->
let%bind t_elt = 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 @@ get_t_list t in
let%bind match_nil = f e match_nil in let%bind match_nil = f e match_nil in
let (hd, tl, b) = match_cons 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}}) ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
| Match_variant lst -> | Match_variant lst ->
let%bind variant_cases' = 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 @@ Ast_typed.Combinators.get_t_sum t in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' 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 match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c -> 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 in
let%bind () = let%bind () =
trace_strong (match_missing_case i loc) @@ trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in bind_iter_list test_case variant_cases in
let%bind () = let%bind () =
trace_strong (match_redundant_case i loc) @@ Assert.assert_true (match_redundant_case i loc) List.(length variant_cases = length match_cases) in
Assert.assert_true List.(length variant_cases = length match_cases) in
let%bind cases = let%bind cases =
let aux ((constructor_name , pattern) , b) = let aux ((constructor_name , pattern) , b) =
let%bind {ctor_type=constructor;_} = 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 bind_map_list aux lst in
ok (O.Match_variant { cases ; tv=t }) 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 let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
match t.type_content with match t.type_content with
| T_arrow {type1;type2} -> | T_arrow {type1;type2} ->
@ -574,7 +362,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| Some _ -> | Some _ ->
if I.CMap.mem (Constructor "M_left") m || I.CMap.mem (Constructor "M_right") m then if I.CMap.mem (Constructor "M_left") m || I.CMap.mem (Constructor "M_right") m then
ok () ok ()
else fail (redundant_constructor e k) else fail (redundant_constructor e k t.location)
| None -> ok () in | None -> ok () in
let v' : O.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in let v' : O.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
ok @@ O.CMap.add (convert_constructor' k) v' prev' 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 let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in | _ -> 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 return @@ record
| TC_michelson_pair_left_comb, [c] -> | TC_michelson_pair_left_comb, [c] ->
let%bind c' = evaluate_type e c in let%bind c' = evaluate_type e c in
let%bind lmap = match c'.type_content with let%bind lmap = match c'.type_content with
| T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
| _ -> fail (michelson_comb_no_record t.location) in | _ -> 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 return @@ record
| TC_michelson_or_right_comb, [c] -> | TC_michelson_or_right_comb, [c] ->
let%bind c' = evaluate_type e c in let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap | T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in | _ -> 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 return @@ pair
| TC_michelson_or_left_comb, [c] -> | TC_michelson_or_left_comb, [c] ->
let%bind c' = evaluate_type e c in let%bind c' = evaluate_type e c in
let%bind cmap = match c'.type_content with let%bind cmap = match c'.type_content with
| T_sum cmap -> ok cmap | T_sum cmap -> ok cmap
| _ -> fail (michelson_comb_no_variant t.location) in | _ -> 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 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 -> = fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ())) 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 module L = Logger.Stateful() in
let return expr tv = let return expr tv =
let%bind () = let%bind () =
match tv_opt with match tv_opt with
| None -> ok () | 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 let location = ae.location in
ok @@ make_e ~location expr tv in ok @@ make_e ~location expr tv in
let main_error = trace (expression_tracer ae) @@
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 @@
match ae.expression_content with match ae.expression_content with
(* Basic *) (* Basic *)
| E_variable name -> | E_variable name ->
let%bind tv' = let%bind tv' =
trace_option (unbound_variable e name) trace_option (unbound_variable e name ae.location)
@@ Environment.get_opt name e in @@ Environment.get_opt name e in
return (E_variable name) tv'.type_value return (E_variable name) tv'.type_value
| E_literal Literal_unit -> | 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 ()) return (e_operation op) (t_operation ())
| E_record_accessor {record;path} -> | E_record_accessor {record;path} ->
let%bind e' = type_expression' e record in 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 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 = let%bind tv =
generic_try (bad_record_access property ae prev.type_expression ae.location) trace_option (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 O.LMap.find_opt (convert_label property) r_tv in
let location = ae.location 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 in
let%bind ae = 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 *) (* check type annotation of the final accessed element *)
let%bind () = let%bind () =
match tv_opt with match tv_opt with
| None -> ok () | 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) ok(ae)
| E_constructor {constructor = Constructor s ; element} when String.equal s "M_left" || String.equal s "M_right" -> ( | 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 let%bind expr' = type_expression' e element in
( match t.type_content with ( match t.type_content with
| T_sum c -> | T_sum c ->
let {ctor_type ; _} : O.ctor_content = O.CMap.find (O.Constructor s) c in 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 return (E_constructor {constructor = Constructor s; element=expr'}) t
| _ -> simple_fail "ll" | _ -> fail (michelson_or (Constructor s) ae.location)
) )
) )
(* Sum *) (* Sum *)
| E_constructor {constructor; element} -> | E_constructor {constructor; element} ->
let%bind (c_tv, sum_tv) = let%bind (c_tv, sum_tv) = trace_option (unbound_constructor e constructor ae.location) @@
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 @@
Environment.get_constructor constructor e in Environment.get_constructor constructor e in
let%bind expr' = type_expression' e element 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 let constructor = convert_constructor' constructor in
return (E_constructor {constructor; element=expr'}) sum_tv return (E_constructor {constructor; element=expr'}) sum_tv
(* Record *) (* 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) ok (O.LMap.add (convert_label k) expr' prev)
in in
let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok O.LMap.empty) m 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 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 ()) return (E_record m') (t_record lmap ())
| E_record_update {record; path; update} -> | 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" | _ -> failwith "Update an expression which is not a record"
in 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 return (E_record_update {record; path; update}) wrapped
(* Data-structure *) (* Data-structure *)
| E_lambda lambda -> | E_lambda lambda ->
@ -801,7 +569,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
collect ; collect ;
init_record ; 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 *) generated by pascaligo's for_collect loop *)
let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in 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 *) 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 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_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)])]) | 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)])])
| _ -> | _ -> fail @@ bad_collect_loop tv_col ae.location in
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
let e' = Environment.add_ez_binder lname input_type e 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%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_expression 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 args' = type_expression' e args in
let%bind tv = match lamb'.type_expression.type_content with let%bind tv = match lamb'.type_expression.type_content with
| T_arrow {type1;type2} -> | T_arrow {type1;type2} ->
let%bind _ = O.assert_type_expression_eq (type1, args'.type_expression) in let%bind _ = assert_type_expression_eq (type1, args'.type_expression) in
ok type2 ok type2
| _ -> | _ ->
fail @@ type_error_approximate fail @@ type_error_approximate
~expected:"should be a function type"
~expression:lamb ~expression:lamb
~actual:lamb'.type_expression ~actual:lamb'.type_expression
lamb'.location
in in
return (E_application {lamb=lamb'; args=args'}) tv return (E_application {lamb=lamb'; args=args'}) tv
(* Advanced *) (* Advanced *)
@ -921,7 +684,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind () = let%bind () =
match prec with match prec with
| None -> ok () | 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 ok (Some cur) in
let%bind tv_opt = bind_fold_list aux None tvs in let%bind tv_opt = bind_fold_list aux None tvs in
let%bind tv = 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 let%bind let_result = type_expression' e' let_result in
return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
| E_raw_code {language;code} -> | 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 code = type_expression' e code in
let%bind type_expression = evaluate_type e type_expression in let%bind type_expression = evaluate_type e type_expression in
let code = {code with 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 tv = evaluate_type e type_annotation in
let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in
let%bind type_annotation = let%bind type_annotation =
trace_option (corner_case "merge_annotations (Some ...) (Some ...) failed") @@
O.merge_annotation O.merge_annotation
(Some tv) (Some tv)
(Some expr'.type_expression) (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') ) *) (* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
let%bind () = let%bind () =
match tv_opt with match tv_opt with
| None -> ok () | 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} ok {expr' with type_expression=type_annotation}
and type_lambda e { 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 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 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 match t.type_meta with
| Some s -> ok s | 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 let open I in
match l with match l with
| Literal_unit -> ok Literal_unit | 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_address s -> ok (Literal_address s)
| Literal_operation s -> ok (Literal_operation 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 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 open I in
let return e = ok e in let return e = ok e in
match ec with match ec with
@ -1048,7 +813,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind arg' = untype_expression args in let%bind arg' = untype_expression args in
return (e_application f' arg') return (e_application f' arg')
| E_lambda {binder ; result} -> ( | E_lambda {binder ; result} -> (
let%bind io = get_t_function ty in let io = get_t_function_exn ty in
let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in
let%bind result = untype_expression result in let%bind result = untype_expression result in
return (e_lambda (binder) (Some input_type) (Some output_type) result) 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 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 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 let open I in
match m with match m with
| Match_option {match_none ; match_some = {opt; body ; tv=_}} -> | Match_option {match_none ; match_some = {opt; body ; tv=_}} ->

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

@ -1,3 +1,4 @@
open Typer_common.Errors
open Trace open Trace
module I = Ast_core module I = Ast_core
@ -10,46 +11,16 @@ module Solver : module type of Typer_new.Solver
type environment = Environment.t type environment = Environment.t
module Errors : sig 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 unbound_type_variable : environment -> string -> unit -> error val evaluate_type : environment -> I.type_expression -> (O.type_expression , typer_error) result
val unbound_variable : environment -> string -> Location.t -> unit -> error val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state , typer_error) result
val match_empty_variant : 'a I.matching -> Location.t -> unit -> error val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression , typer_error) result
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 untype_type_value : O.type_value -> (I.type_expression) result val untype_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal 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 val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
*) *)

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

@ -3,6 +3,7 @@ let use_new_typer = false
module I = Ast_core module I = Ast_core
module O = Ast_typed module O = Ast_typed
module O' = Typesystem.Solver_types module O' = Typesystem.Solver_types
module Errors = Typer_common.Errors
module Environment = O.Environment 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 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 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 untype_expression = if use_new_typer then Typer_new.untype_expression else Typer_old.untype_expression
let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq

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

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

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

@ -1,3 +1,4 @@
open Errors
open Ast_typed.Types open Ast_typed.Types
open Trace open Trace
@ -6,41 +7,6 @@ type contract_pass_data = {
main_name : string ; 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) = let check_entrypoint_annotation_format ep (exp: expression) =
match String.split_on_char '%' ep with match String.split_on_char '%' ep with
| [ "" ; ep'] -> | [ "" ; ep'] ->
@ -50,7 +16,7 @@ let check_entrypoint_annotation_format ep (exp: expression) =
| _ -> fail @@ Errors.bad_format_entrypoint_ann ep exp.location | _ -> 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 let bad_self_err () = Errors.bad_self_type
e.type_expression e.type_expression
{e.type_expression with type_content = T_operator (TC_contract dat.contract_type.parameter)} {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 ok ctor_type
| t -> ok {dat.contract_type.parameter with type_content = t} in | t -> ok {dat.contract_type.parameter with type_content = t} in
let%bind () = let%bind () =
trace_strong (bad_self_err ()) @@ trace_option (bad_self_err ()) @@
Ast_typed.assert_type_expression_eq (entrypoint_t , t) in Ast_typed.assert_type_expression_eq (entrypoint_t , t) in
ok (true, dat, e) ok (true, dat, e)
| _ -> ok (true,dat,e) | _ -> ok (true,dat,e)

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

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

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

@ -1,9 +1,10 @@
open Errors
open Ast_typed open Ast_typed
open Trace open Trace
open Ast_typed.Helpers open Ast_typed.Helpers
type 'a folder = 'a -> expression -> 'a result type ('a ,'err) folder = 'a -> expression -> ('a , 'err) result
let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun f init e -> 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 self = fold_expression f in
let%bind init' = f init e in let%bind init' = f init e in
match e.expression_content with match e.expression_content with
@ -51,7 +52,7 @@ let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun
ok res 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 m with
| Match_list { match_nil ; match_cons = {hd=_; tl=_ ; body; tv=_} } -> ( | Match_list { match_nil ; match_cons = {hd=_; tl=_ ; body; tv=_} } -> (
let%bind res = fold_expression f init match_nil in 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 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 : self_ast_typed_error mapper -> expression -> (expression , self_ast_typed_error) result = fun f e ->
let self = map_expression f in let self = map_expression f in
let%bind e' = f e in let%bind e' = f e in
let return expression_content = ok { e' with expression_content } 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' | 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 m with
| Match_list { match_nil ; match_cons = {hd ; tl ; body ; tv} } -> ( | Match_list { match_nil ; match_cons = {hd ; tl ; body ; tv} } -> (
let%bind match_nil = map_expression f match_nil in 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} 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) -> let aux = fun (x : declaration) ->
match x with match x with
| Declaration_constant {binder; expr ; inline} -> ( | Declaration_constant {binder; expr ; inline} -> (
@ -156,8 +157,8 @@ and map_program : mapper -> program -> program result = fun m p ->
in in
bind_map_list (bind_map_location aux) p bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result type ('a , 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression , 'err) result
let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e -> 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 self = fold_map_expression f in
let%bind (continue, init',e') = f a e in let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e') 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') | 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 m with
| Match_list { match_nil ; match_cons = { hd ; tl ; body ; tv } } -> ( | Match_list { match_nil ; match_cons = { hd ; tl ; body ; tv } } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in 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}) 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) -> let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with match Location.unwrap x with
| Declaration_constant {binder ; expr ; inline} -> ( | Declaration_constant {binder ; expr ; inline} -> (
@ -247,50 +248,12 @@ and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) re
in in
bind_fold_list aux (init,[]) p 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 = { type contract_type = {
parameter : Ast_typed.type_expression ; parameter : Ast_typed.type_expression ;
storage : 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 let aux declt = match Location.unwrap declt with
| Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) -> | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
if String.equal (Var.to_name binder) main_fname 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 in
let main_decl_opt = List.find_map aux @@ List.rev program in let main_decl_opt = List.find_map aux @@ List.rev program in
let%bind main_decl = 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 main_decl_opt
in in
let { binder=_ ; expr ; inline=_ } = main_decl 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} -> ( | T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) -> | 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 (parameter,storage) = trace_option (expected_pair_in expr.location) @@ Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in let%bind (listop,storage') = trace_option (expected_pair_out expr.location) @@ Ast_typed.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@ let%bind () = trace_option (expected_list_operation main_fname listop expr) @@
Ast_typed.assert_t_list_operation listop in 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 Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *) (* TODO: on storage/parameter : assert_storable, assert_passable ? *)
ok { parameter ; storage } ok { parameter ; storage }
| _ -> fail @@ Errors.bad_contract_io main_fname expr | _ -> fail @@ bad_contract_io main_fname expr
) )
| _ -> fail @@ Errors.bad_contract_io main_fname expr | _ -> fail @@ bad_contract_io main_fname expr

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

@ -1,3 +1,4 @@
open Errors
open Ast_typed open Ast_typed
open Trace open Trace
@ -145,7 +146,7 @@ let rec from_left_comb_record
let from_left_comb prev src_lmap dst_kvl conv_map = let from_left_comb prev src_lmap dst_kvl conv_map =
from_left_comb_record prev src_lmap (List.rev 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 match matchee_t , bodies with
| [m] , bl::br::[] -> | [m] , bl::br::[] ->
let cases = [ 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"; pattern = Var.of_name "x";
body } ] in body } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) 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 match matchee_t , bodies with
| [m] , bl::br::[] -> | [m] , bl::br::[] ->
let cases = [ 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"; pattern = Var.of_name "x";
body } ] in body } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) 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 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 = (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 - 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 let return expression_content = ok { e with expression_content } in
match e.expression_content with match e.expression_content with
| E_constant {cons_name= (C_CONVERT_TO_LEFT_COMB);arguments= [ to_convert ] } -> ( | 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 let src_kvl = to_sorted_kv_list_l src_lmap in
return @@ E_record (to_left_comb_record to_convert src_kvl LMap.empty) return @@ E_record (to_left_comb_record to_convert src_kvl LMap.empty)
| T_sum src_cmap -> | 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 src_kvl = to_sorted_kv_list_c src_cmap in
let bodies = left_comb_variant_combination e dst_cmap src_kvl in let bodies = left_comb_variant_combination e dst_cmap src_kvl in
let to_cases ((constructor,{ctor_type=_;_}),body) = 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 let src_kvl = to_sorted_kv_list_l src_lmap in
return @@ E_record (to_right_comb_record to_convert src_kvl LMap.empty) return @@ E_record (to_right_comb_record to_convert src_kvl LMap.empty)
| T_sum src_cmap -> | 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 src_kvl = to_sorted_kv_list_c src_cmap in
let bodies = right_comb_variant_combination e dst_cmap src_kvl in let bodies = right_comb_variant_combination e dst_cmap src_kvl in
let to_cases ((constructor,{ctor_type=_;_}),body) = 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 ] } -> ( | E_constant {cons_name= (C_CONVERT_FROM_RIGHT_COMB); arguments= [ to_convert ] } -> (
match to_convert.type_expression.type_content with match to_convert.type_expression.type_content with
| T_record src_lmap -> | 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 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) return @@ E_record (from_right_comb_record to_convert src_lmap dst_kvl LMap.empty)
| T_sum src_cmap -> | 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 dst_kvl = to_sorted_kv_list_c dst_lmap in
let intermediary_types i = descend_types "M_right" src_cmap i 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 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 ] } -> ( | E_constant {cons_name= (C_CONVERT_FROM_LEFT_COMB); arguments= [ to_convert ] } -> (
match to_convert.type_expression.type_content with match to_convert.type_expression.type_content with
| T_record src_lmap -> | 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 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) return @@ E_record (from_left_comb to_convert src_lmap dst_kvl LMap.empty)
| T_sum src_cmap -> | 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 dst_kvl = to_sorted_kv_list_c dst_lmap in
let intermediary_types i = descend_types "M_left" src_cmap i 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 let matchee = to_convert :: (List.map (fun t -> match_var t) @@ intermediary_types ((List.length dst_kvl)-2)) in

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

@ -1,22 +1,13 @@
open Errors
open Ast_typed open Ast_typed
open Trace open Trace
type contract_pass_data = Contract_passes.contract_pass_data 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 = let rec check_no_nested_bigmap is_in_bigmap e =
match e.type_content with match e.type_content with
| T_operator (TC_big_map _) when is_in_bigmap -> | 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}) -> | T_operator (TC_big_map {k ; v}) ->
let%bind _ = check_no_nested_bigmap false k in let%bind _ = check_no_nested_bigmap false k in
let%bind _ = check_no_nested_bigmap true v 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 _ -> | T_constant _ ->
ok () 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 let%bind _ = check_no_nested_bigmap false el.type_expression in
ok (true, dat, el) ok (true, dat, el)

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

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

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

@ -1,27 +1,16 @@
open Errors
open Ast_typed open Ast_typed
open Trace open Trace
module Errors = struct let rec check_recursive_call : expression_variable -> bool -> expression -> (unit, self_ast_typed_error) result = fun n final_path e ->
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 ->
match e.expression_content with match e.expression_content with
| E_literal _ -> ok () | E_literal _ -> ok ()
| E_constant c -> | E_constant c ->
let%bind _ = bind_map_list (check_recursive_call n false) c.arguments in let%bind _ = bind_map_list (check_recursive_call n false) c.arguments in
ok () ok ()
| E_variable v -> ( | E_variable v -> (
let%bind _ = trace_strong (recursive_call_is_only_allowed_as_the_last_operation n e.location) @@ let%bind _ = Assert.assert_true (recursive_call_is_only_allowed_as_the_last_operation n e.location)
Assert.assert_true (final_path || n <> v) in (final_path || n <> v) in
ok () ok ()
) )
| E_application {lamb;args} -> | E_application {lamb;args} ->
@ -78,7 +67,7 @@ and check_recursive_call_in_matching = fun n final_path c ->
ok () 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 let return expression_content = ok { e with expression_content } in
match e.expression_content with match e.expression_content with
| E_recursive {fun_name; lambda} as e-> ( | E_recursive {fun_name; lambda} as e-> (

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

@ -5,8 +5,11 @@ include Ast_typed.Types
module Env = Ligo_interpreter.Environment 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 fun c operands -> match (c,operands) with
| ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) | ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] )
| ( comp , [ V_Ct (C_nat a' ) ; V_Ct (C_nat 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') ok @@ v_bool (f_op a' b')
| _ -> | _ ->
let () = List.iter (fun el -> Format.printf "%s" (Ligo_interpreter.PP.pp_value el)) operands in 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 *) (* 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 -> fun c operands ->
let return_ct v = ok @@ V_Ct v in let return_ct v = ok @@ V_Ct v in
let return_none () = ok @@ v_none () 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) aux @@ v_pair (v_bool true,init)
(* tertiary *) (* tertiary *)
| ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) -> | ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) ->
generic_try (simple_error "bad slice") @@ (fun () -> ok @@ V_Ct (C_string (String.sub s (Z.to_int st) (Z.to_int ed)))
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 ] ) -> | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List elts ; init ] ) ->
bind_fold_list bind_fold_list
(fun prev elt -> (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 | ( 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)) | "Some" -> ok @@ V_Map ((k,v)::(List.remove_assoc k kvs))
| "None" -> ok @@ V_Map (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_EMPTY, []) -> ok @@ V_Set ([])
| ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l)) | ( 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 () = 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 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 (* TODO
@ -253,7 +254,7 @@ C_STEPS_TO_QUOTA
*) *)
(*interpreter*) (*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_unit -> ok @@ V_Ct (C_unit)
| Literal_int i -> ok @@ V_Ct (C_int i) | Literal_int i -> ok @@ V_Ct (C_int i)
| Literal_nat n -> ok @@ V_Ct (C_nat n) | 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_key_hash s -> ok @@ V_Ct (C_key_hash s)
| Literal_chain_id 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_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 -> = fun term env ->
match term.expression_content with match term.expression_content with
| E_application ({lamb = f; args}) -> ( | 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 (arg_names, args') in
let f_env'' = Env.extend f_env' (fun_name, f') in let f_env'' = Env.extend f_env' (fun_name, f') in
eval body f_env'' 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;} -> | E_lambda {binder; result;} ->
ok @@ V_Func_val (binder,result,env) 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 let%bind record' = eval record env in
match record' with match record' with
| V_Record recmap -> | V_Record recmap ->
let%bind a = trace_option (simple_error "unknown record field") @@ let a = LMap.find path recmap in
LMap.find_opt path recmap in
ok a ok a
| _ -> simple_fail "trying to access a non-record" | _ -> failwith "trying to access a non-record"
) )
| E_record_update {record ; path ; update} -> ( | E_record_update {record ; path ; update} -> (
let%bind record' = eval record env in 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 let%bind field' = eval update env in
ok @@ V_Record (LMap.add path field' recmap) ok @@ V_Record (LMap.add path field' recmap)
else else
simple_fail "field l does not exist in record" failwith "field l does not exist in record"
| _ -> simple_fail "this expression isn't a record" | _ -> failwith "this expression isn't a record"
) )
| E_constant {cons_name ; arguments} -> ( | E_constant {cons_name ; arguments} -> (
let%bind operands' = bind_map_list let%bind operands' = bind_map_list
@ -360,14 +360,14 @@ and eval : Ast_typed.expression -> env -> value result
eval body env' eval body env'
| Match_option cases, V_Construct ("None" , V_Ct C_unit) -> | Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
eval cases.match_none env eval cases.match_none env
| _ -> simple_fail "not yet supported case" | _ -> failwith "not yet supported case"
(* ((ctor,name),body) *) (* ((ctor,name),body) *)
) )
| E_recursive {fun_name; fun_type=_; lambda} -> | E_recursive {fun_name; fun_type=_; lambda} ->
ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env) 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 -> fun prg ->
let aux (pp,top_env) el = let aux (pp,top_env) el =
match Location.unwrap el with match Location.unwrap el with

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