Merge remote-tracking branch 'origin/dev' into rinderknecht-dev

This commit is contained in:
Christian Rinderknecht 2019-12-20 16:46:33 +01:00
commit 705b425589
52 changed files with 399 additions and 182 deletions

4
.gitignore vendored
View File

@ -1,5 +1,4 @@
/_build/ /_build/
dune-project
*~ *~
*.merlin *.merlin
cache/* cache/*
@ -7,4 +6,5 @@ Version.ml
/_opam/ /_opam/
/*.pp.ligo /*.pp.ligo
**/.DS_Store **/.DS_Store
.vscode/ .vscode/
/ligo.install

3
dune-project Normal file
View File

@ -0,0 +1,3 @@
(lang dune 1.11)
(name ligo)
(using menhir 2.0)

View File

@ -66,7 +66,7 @@ let amount =
let open Arg in let open Arg in
let info = let info =
let docv = "AMOUNT" in let docv = "AMOUNT" in
let doc = "$(docv) is the amount the dry-run transaction will use." in let doc = "$(docv) is the amount the michelson interpreter will use." in
info ~docv ~doc ["amount"] in info ~docv ~doc ["amount"] in
value @@ opt string "0" info value @@ opt string "0" info
@ -74,7 +74,7 @@ let sender =
let open Arg in let open Arg in
let info = let info =
let docv = "SENDER" in let docv = "SENDER" in
let doc = "$(docv) is the sender the dry-run transaction will use." in let doc = "$(docv) is the sender the michelson interpreter transaction will use." in
info ~docv ~doc ["sender"] in info ~docv ~doc ["sender"] in
value @@ opt (some string) None info value @@ opt (some string) None info
@ -82,10 +82,18 @@ let source =
let open Arg in let open Arg in
let info = let info =
let docv = "SOURCE" in let docv = "SOURCE" in
let doc = "$(docv) is the source the dry-run transaction will use." in let doc = "$(docv) is the source the michelson interpreter transaction will use." in
info ~docv ~doc ["source"] in info ~docv ~doc ["source"] in
value @@ opt (some string) None info value @@ opt (some string) None info
let predecessor_timestamp =
let open Arg in
let info =
let docv = "PREDECESSOR_TIMESTAMP" in
let doc = "$(docv) is the pedecessor_timestamp the michelson interpreter transaction will use (e.g. '2000-01-01T10:10:10Z')" in
info ~docv ~doc ["predecessor-timestamp"] in
value @@ opt (some string) None info
let display_format = let display_format =
let open Arg in let open Arg in
let info = let info =
@ -176,7 +184,7 @@ let compile_parameter =
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
let interpret = let interpret =
let f expression init_file syntax amount sender source display_format = let f expression init_file syntax amount sender source predecessor_timestamp display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind (decl_list,state,env) = match init_file with let%bind (decl_list,state,env) = match init_file with
| Some init_file -> | Some init_file ->
@ -192,13 +200,13 @@ let interpret =
let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in
let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in
let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in
let%bind options = Run.make_dry_run_options {amount ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
let%bind value = Run.run ~options compiled_exp.expr compiled_exp.expr_ty in let%bind value = Run.run ~options compiled_exp.expr compiled_exp.expr_ty in
let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value in let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
in in
let term = let term =
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ display_format ) in Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format ) in
let cmdname = "interpret" in let cmdname = "interpret" in
let doc = "Subcommand: interpret the expression in the context initialized by the provided source file." in let doc = "Subcommand: interpret the expression in the context initialized by the provided source file." in
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
@ -233,7 +241,7 @@ let compile_storage =
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
let dry_run = let dry_run =
let f source_file entry_point storage input amount sender source syntax display_format = let f source_file entry_point storage input amount sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
let%bind typed_prg,state = Compile.Of_simplified.compile simplified in let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
@ -251,20 +259,20 @@ let dry_run =
let%bind compiled_params = Compile.Of_mini_c.compile_expression mini_c in let%bind compiled_params = Compile.Of_mini_c.compile_expression mini_c in
let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in
let%bind options = Run.make_dry_run_options {amount ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
let%bind michelson_output = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in let%bind michelson_output = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "dry-run" in let cmdname = "dry-run" in
let doc = "Subcommand: run a smart-contract with the given storage and input." in let doc = "Subcommand: run a smart-contract with the given storage and input." in
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
let run_function = let run_function =
let f source_file entry_point parameter amount sender source syntax display_format = let f source_file entry_point parameter amount sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in
@ -278,32 +286,32 @@ let run_function =
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 {amount ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
let%bind michelson_output = Run.run ~options michelson.expr michelson.expr_ty in let%bind michelson_output = Run.run ~options michelson.expr michelson.expr_ty in
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "run-function" in let cmdname = "run-function" in
let doc = "Subcommand: run a function with the given parameter." in let doc = "Subcommand: run a function with the given parameter." in
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)
let evaluate_value = let evaluate_value =
let f source_file entry_point amount sender source syntax display_format = let f source_file entry_point amount sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
let%bind typed_prg,_ = Compile.Of_simplified.compile simplified in let%bind typed_prg,_ = Compile.Of_simplified.compile simplified in
let%bind mini_c = Compile.Of_typed.compile typed_prg in let%bind mini_c = Compile.Of_typed.compile typed_prg in
let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in
let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind options = Run.make_dry_run_options {amount ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
let%bind michelson_output = Run.run ~options compiled.expr compiled.expr_ty in let%bind michelson_output = Run.run ~options compiled.expr compiled.expr_ty in
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
let cmdname = "evaluate-value" in let cmdname = "evaluate-value" in
let doc = "Subcommand: evaluate a given definition." in let doc = "Subcommand: evaluate a given definition." in
(Term.ret term , Term.info ~doc cmdname) (Term.ret term , Term.info ~doc cmdname)

View File

@ -278,7 +278,7 @@ let%expect_test _ =
OPTIONS OPTIONS
--amount=AMOUNT (absent=0) --amount=AMOUNT (absent=0)
AMOUNT is the amount the dry-run transaction will use. AMOUNT is the amount the michelson interpreter will use.
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
(absent=human-readable) (absent=human-readable)
@ -293,16 +293,22 @@ let%expect_test _ =
`pager', `groff' or `plain'. With `auto', the format is `pager` or `pager', `groff' or `plain'. With `auto', the format is `pager` or
`plain' whenever the TERM env var is `dumb' or undefined. `plain' whenever the TERM env var is `dumb' or undefined.
--predecessor-timestamp=PREDECESSOR_TIMESTAMP
PREDECESSOR_TIMESTAMP is the pedecessor_timestamp the michelson
interpreter transaction will use (e.g. '2000-01-01T10:10:10Z')
-s SYNTAX, --syntax=SYNTAX (absent=auto) -s SYNTAX, --syntax=SYNTAX (absent=auto)
SYNTAX is the syntax that will be used. Currently supported SYNTAX is the syntax that will be used. Currently supported
syntaxes are "pascaligo" and "cameligo". By default, the syntax is syntaxes are "pascaligo" and "cameligo". By default, the syntax is
guessed from the extension (.ligo and .mligo, respectively). guessed from the extension (.ligo and .mligo, respectively).
--sender=SENDER --sender=SENDER
SENDER is the sender the dry-run transaction will use. SENDER is the sender the michelson interpreter transaction will
use.
--source=SOURCE --source=SOURCE
SOURCE is the source the dry-run transaction will use. SOURCE is the source the michelson interpreter transaction will
use.
--version --version
Show version information. |} ] ; Show version information. |} ] ;
@ -330,7 +336,7 @@ let%expect_test _ =
OPTIONS OPTIONS
--amount=AMOUNT (absent=0) --amount=AMOUNT (absent=0)
AMOUNT is the amount the dry-run transaction will use. AMOUNT is the amount the michelson interpreter will use.
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
(absent=human-readable) (absent=human-readable)
@ -345,16 +351,22 @@ let%expect_test _ =
`pager', `groff' or `plain'. With `auto', the format is `pager` or `pager', `groff' or `plain'. With `auto', the format is `pager` or
`plain' whenever the TERM env var is `dumb' or undefined. `plain' whenever the TERM env var is `dumb' or undefined.
--predecessor-timestamp=PREDECESSOR_TIMESTAMP
PREDECESSOR_TIMESTAMP is the pedecessor_timestamp the michelson
interpreter transaction will use (e.g. '2000-01-01T10:10:10Z')
-s SYNTAX, --syntax=SYNTAX (absent=auto) -s SYNTAX, --syntax=SYNTAX (absent=auto)
SYNTAX is the syntax that will be used. Currently supported SYNTAX is the syntax that will be used. Currently supported
syntaxes are "pascaligo" and "cameligo". By default, the syntax is syntaxes are "pascaligo" and "cameligo". By default, the syntax is
guessed from the extension (.ligo and .mligo, respectively). guessed from the extension (.ligo and .mligo, respectively).
--sender=SENDER --sender=SENDER
SENDER is the sender the dry-run transaction will use. SENDER is the sender the michelson interpreter transaction will
use.
--source=SOURCE --source=SOURCE
SOURCE is the source the dry-run transaction will use. SOURCE is the source the michelson interpreter transaction will
use.
--version --version
Show version information. |} ] ; Show version information. |} ] ;
@ -377,7 +389,7 @@ let%expect_test _ =
OPTIONS OPTIONS
--amount=AMOUNT (absent=0) --amount=AMOUNT (absent=0)
AMOUNT is the amount the dry-run transaction will use. AMOUNT is the amount the michelson interpreter will use.
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
(absent=human-readable) (absent=human-readable)
@ -392,16 +404,22 @@ let%expect_test _ =
`pager', `groff' or `plain'. With `auto', the format is `pager` or `pager', `groff' or `plain'. With `auto', the format is `pager` or
`plain' whenever the TERM env var is `dumb' or undefined. `plain' whenever the TERM env var is `dumb' or undefined.
--predecessor-timestamp=PREDECESSOR_TIMESTAMP
PREDECESSOR_TIMESTAMP is the pedecessor_timestamp the michelson
interpreter transaction will use (e.g. '2000-01-01T10:10:10Z')
-s SYNTAX, --syntax=SYNTAX (absent=auto) -s SYNTAX, --syntax=SYNTAX (absent=auto)
SYNTAX is the syntax that will be used. Currently supported SYNTAX is the syntax that will be used. Currently supported
syntaxes are "pascaligo" and "cameligo". By default, the syntax is syntaxes are "pascaligo" and "cameligo". By default, the syntax is
guessed from the extension (.ligo and .mligo, respectively). guessed from the extension (.ligo and .mligo, respectively).
--sender=SENDER --sender=SENDER
SENDER is the sender the dry-run transaction will use. SENDER is the sender the michelson interpreter transaction will
use.
--source=SOURCE --source=SOURCE
SOURCE is the source the dry-run transaction will use. SOURCE is the source the michelson interpreter transaction will
use.
--version --version
Show version information. |} ] ; Show version information. |} ] ;

View File

@ -1,11 +1,25 @@
open Cli_expect open Cli_expect
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_1.mligo" ; "foo" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "main" ] ;
[%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"} |} ] ; [%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"} |} ] ;
run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_2.mligo" ; "foo" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "main" ] ;
[%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":"(TO_list(string))","b":"(TO_option(int))"} |} ] ; [%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":"(TO_list(string))","b":"(TO_option(int))"} |} ] ;
(* run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_3.mligo" ; "foo" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ;
* [%expect some type error ] ; *) [%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":"tuple[int , string , bool]","b":"tuple[int , string]"} |} ] ;
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ;
[%expect {| ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in record: {"key_a":"d","key_b":"c"} |} ] ;
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_5.mligo" ; "main" ] ;
[%expect {| ligo: unbound type variable: {"variable":"boolean","in":"- E[]\tT[] ]","did_you_mean":"bool"} |} ] ;
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_6.mligo" ; "main" ] ;
[%expect {| ligo: in file "error_typer_6.mligo", line 1, characters 30-64. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"bool"} |} ] ;
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ;
[%expect {| ligo: in file "error_typer_7.mligo", line 4, characters 17-56. 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[b -> string , a -> int]","b":"record[c -> bool , b -> string , a -> int]"} |} ] ;

View File

@ -1,4 +1,4 @@
open! Trace open Trace
let rec error_pp ?(dev = false) out (e : error) = let rec error_pp ?(dev = false) out (e : error) =
let open JSON_string_utils in let open JSON_string_utils in

View File

@ -16,6 +16,7 @@ type run_failwith_res =
type dry_run_options = type dry_run_options =
{ amount : string ; { amount : string ;
predecessor_timestamp : string option ;
sender : string option ; sender : string option ;
source : string option } source : string option }
@ -44,7 +45,14 @@ let make_dry_run_options (opts : dry_run_options) : options result =
(simple_error "invalid source address") (simple_error "invalid source address")
(Contract.of_b58check source) in (Contract.of_b58check source) in
ok (Some source) in ok (Some source) in
ok @@ make_options ~amount ?source:sender ?payer:source () let%bind predecessor_timestamp =
match opts.predecessor_timestamp with
| None -> ok None
| Some st ->
match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with
| Some t -> ok (Some t)
| None -> simple_fail ("\""^st^"\" is a bad timestamp notation") in
ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ?source:sender ?payer: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

View File

@ -5,6 +5,73 @@ module AST = Parser_cameligo.AST
module ParserLog = Parser_cameligo.ParserLog module ParserLog = Parser_cameligo.ParserLog
module LexToken = Parser_reasonligo.LexToken module LexToken = Parser_reasonligo.LexToken
module Lexer = Lexer.Make(LexToken) module Lexer = Lexer.Make(LexToken)
module SyntaxError = Parser_reasonligo.SyntaxError
module Errors = struct
let wrong_function_arguments expr =
let title () = "wrong function arguments" in
let message () = "" in
let expression_loc = AST.expr_to_region expr in
let data = [
("expression_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)
] in
error ~data title message
let parser_error start end_ =
let title () = "parser error" in
let message () = "" in
let loc = Region.make
~start:(Pos.from_byte start)
~stop:(Pos.from_byte end_)
in
let data = [
("parser_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc
)
] in
error ~data title message
let unrecognized_error start end_ =
let title () = "unrecognized error" in
let message () = "" in
let loc = Region.make
~start:(Pos.from_byte start)
~stop:(Pos.from_byte end_)
in
let data = [
("unrecognized_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc
)
] in
error ~data title message
end
open Errors
type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a
let parse (parser: 'a parser) lexbuf =
let Lexer.{read ; close ; _} = Lexer.open_token_stream None in
let result =
try
ok (parser read lexbuf)
with
| SyntaxError.Error (WrongFunctionArguments e) ->
fail @@ (wrong_function_arguments e)
| Parser.Error ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
fail @@ (parser_error start end_)
| _ ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
fail @@ (unrecognized_error start end_)
in
close ();
result
let parse_file (source: string) : AST.t result = let parse_file (source: string) : AST.t result =
let pp_input = let pp_input =
@ -20,104 +87,12 @@ let parse_file (source: string) : AST.t result =
generic_try (simple_error "error opening file") @@ generic_try (simple_error "error opening file") @@
(fun () -> open_in pp_input) in (fun () -> open_in pp_input) in
let lexbuf = Lexing.from_channel channel in let lexbuf = Lexing.from_channel channel in
let Lexer.{read ; close ; _} = parse (Parser.contract) lexbuf
Lexer.open_token_stream None in
specific_try (function
| SyntaxError.Error WrongFunctionArguments ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Incorrect function arguments at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname source
in
simple_error str
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname source
in
simple_error str
)
| exn ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
(Printexc.to_string exn)
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname source
in
simple_error str
) @@ (fun () ->
let raw = Parser.contract read lexbuf in
close () ;
raw
) >>? fun raw ->
ok raw
let parse_string (s:string) : AST.t result = let parse_string (s:string) : AST.t result =
let lexbuf = Lexing.from_string s in let lexbuf = Lexing.from_string s in
let Lexer.{read ; close ; _} = parse (Parser.contract) lexbuf
Lexer.open_token_stream None in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
simple_error str
)
| _ -> simple_error "unrecognized parse_ error"
) @@ (fun () ->
let raw = Parser.contract read lexbuf in
close () ;
raw
) >>? fun raw ->
ok raw
let parse_expression (s:string) : AST.expr result = let parse_expression (s:string) : AST.expr result =
let lexbuf = Lexing.from_string s in let lexbuf = Lexing.from_string s in
let Lexer.{read ; close; _} = parse (Parser.interactive_expr) lexbuf
Lexer.open_token_stream None in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
simple_error str
)
| exn ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n"
(Printexc.to_string exn)
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname s
in
simple_error str
) @@ (fun () ->
let raw = Parser.interactive_expr read lexbuf in
close () ;
raw
) >>? fun raw ->
ok raw

View File

@ -424,7 +424,7 @@ fun_expr:
{p.value with inside = arg_to_pattern p.value.inside} {p.value with inside = arg_to_pattern p.value.inside}
in PPar {p with value} in PPar {p with value}
| EUnit u -> PUnit u | EUnit u -> PUnit u
| _ -> raise (SyntaxError.Error WrongFunctionArguments) | e -> raise (SyntaxError.Error (WrongFunctionArguments e))
in in
let fun_args_to_pattern = function let fun_args_to_pattern = function
EAnnot { EAnnot {
@ -453,7 +453,7 @@ fun_expr:
in arg_to_pattern (fst fun_args), bindings in arg_to_pattern (fst fun_args), bindings
| EUnit e -> | EUnit e ->
arg_to_pattern (EUnit e), [] arg_to_pattern (EUnit e), []
| _ -> raise (SyntaxError.Error WrongFunctionArguments) | e -> raise (SyntaxError.Error (WrongFunctionArguments e))
in in
let binders = fun_args_to_pattern $1 in let binders = fun_args_to_pattern $1 in
let f = {kwd_fun; let f = {kwd_fun;

View File

@ -1,4 +1,4 @@
type error = type error =
| WrongFunctionArguments | WrongFunctionArguments of AST.expr
exception Error of error exception Error of error

View File

@ -1,4 +1,4 @@
type error = type error =
| WrongFunctionArguments | WrongFunctionArguments of AST.expr
exception Error of error exception Error of error

View File

@ -8,7 +8,7 @@
(library (library
(name parser_reasonligo) (name parser_reasonligo)
(public_name ligo.parser.reasonligo) (public_name ligo.parser.reasonligo)
(modules reasonligo LexToken Parser) (modules SyntaxError reasonligo LexToken Parser)
(libraries (libraries
menhirLib menhirLib
parser_shared parser_shared

View File

@ -3,3 +3,4 @@ module AST = Parser_cameligo.AST
module Lexer = Lexer module Lexer = Lexer
module LexToken = LexToken module LexToken = LexToken
module ParserLog = Parser_cameligo.ParserLog module ParserLog = Parser_cameligo.ParserLog
module SyntaxError = SyntaxError

View File

@ -15,8 +15,8 @@
Markup Markup
FQueue FQueue
EvalOpt EvalOpt
Version Version
SyntaxError)) ))
(rule (rule

View File

@ -1,4 +1,4 @@
open! Trace open Trace
open Ast_simplified open Ast_simplified
module Raw = Parser.Pascaligo.AST module Raw = Parser.Pascaligo.AST

View File

@ -54,7 +54,7 @@ module Errors = struct
let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ = let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "redundant case in match") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;

View File

@ -12,13 +12,20 @@ type environment = Environment.t
module Errors = struct module Errors = struct
let unbound_type_variable (e:environment) (tv:I.type_variable) () = let unbound_type_variable (e:environment) (tv:I.type_variable) () =
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 title = (thunk "unbound type variable") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ; ("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
(* TODO: types don't have srclocs for now. *) (* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("did_you_mean" , fun () -> suggestion)
] in ] in
error ~data title message () error ~data title message ()
@ -54,7 +61,7 @@ module Errors = struct
let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ = let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
fun matching loc () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "redundant case in match") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
@ -464,8 +471,6 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
| None -> ok () | None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , ae.type_annotation) in | Some tv' -> O.assert_type_value_eq (tv' , ae.type_annotation) in
ok(ae) ok(ae)
(* Sum *) (* Sum *)
| E_constructor (c, expr) -> | E_constructor (c, expr) ->
let%bind (c_tv, sum_tv) = let%bind (c_tv, sum_tv) =
@ -793,7 +798,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
(Some tv) (Some tv)
(Some expr'.type_annotation) (Some expr'.type_annotation)
(internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in
ok {expr' with type_annotation} (* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , type_annotation) in
ok @@ {expr' with type_annotation}
and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result = and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =

View File

@ -2,7 +2,7 @@
For more info, see back-end.md: https://gitlab.com/ligolang/ligo/blob/dev/gitlab-pages/docs/contributors/big-picture/back-end.md *) For more info, see back-end.md: https://gitlab.com/ligolang/ligo/blob/dev/gitlab-pages/docs/contributors/big-picture/back-end.md *)
open! Trace open Trace
open Helpers open Helpers
module AST = Ast_typed module AST = Ast_typed

View File

@ -1,4 +1,4 @@
open! Trace open Trace
module AST = Ast_typed module AST = Ast_typed
module Append_tree = Tree.Append module Append_tree = Tree.Append

View File

@ -1,5 +1,5 @@
open Mini_c open Mini_c
open! Trace open Trace
(* TODO hack to specialize map_expression to identity monad *) (* TODO hack to specialize map_expression to identity monad *)
let map_expression : let map_expression :

View File

@ -29,8 +29,8 @@ open Errors
(* This does not makes sense to me *) (* This does not makes sense to me *)
let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst -> let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst ->
match Operators.Compiler.get_operators s with match Operators.Compiler.get_operators s with
| Trace.Ok (x,_) -> ok x | Ok (x,_) -> ok x
| Trace.Error _ -> ( | Error _ -> (
match s with match s with
| C_NONE -> ( | C_NONE -> (
let%bind ty' = Mini_c.get_t_option ty in let%bind ty' = Mini_c.get_t_option ty in
@ -452,4 +452,4 @@ and translate_function anon env input_ty output_ty : michelson result =
type compiled_expression = { type compiled_expression = {
expr_ty : ex_ty ; expr_ty : ex_ty ;
expr : michelson ; expr : michelson ;
} }

View File

@ -56,7 +56,7 @@ module Errors = struct
let different_types name a b () = let different_types name a b () =
let title () = name ^ " are different" in let title () = name ^ " are different" in
let message () = "" in let message () = "Expected these two types to be the same, but they're different" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ; ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b ) ("b" , fun () -> Format.asprintf "%a" PP.type_value b )
@ -321,7 +321,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
| TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb]) | TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb])
| _,_ -> fail @@ different_operators opa opb | _,_ -> fail @@ different_operators opa opb
in in
trace (different_types "constant sub-expression" a b) trace (different_types "arguments to type operators" a b)
@@ bind_list_iter (fun (a,b) -> assert_type_value_eq (a,b) )(List.combine lsta lstb) @@ bind_list_iter (fun (a,b) -> assert_type_value_eq (a,b) )(List.combine lsta lstb)
) )
| T_operator _, _ -> fail @@ different_kinds a b | T_operator _, _ -> fail @@ different_kinds a b

View File

@ -188,10 +188,14 @@ let literal ppf (l:literal) = match l with
| Literal_timestamp n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n | Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%S" s | Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
| Literal_address s -> fprintf ppf "@%S" s | Literal_address s -> fprintf ppf "@%S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)" | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
| Literal_key s -> fprintf ppf "key %s" s | Literal_key s -> fprintf ppf "key %s" s
| Literal_key_hash s -> fprintf ppf "key_hash %s" s | Literal_key_hash s -> fprintf ppf "key_hash %s" s
| Literal_signature s -> fprintf ppf "Signature %s" s | Literal_signature s -> fprintf ppf "Signature %s" s
| Literal_chain_id s -> fprintf ppf "Chain_id %s" s | Literal_chain_id s -> fprintf ppf "Chain_id %s" s
let%expect_test _ =
Format.printf "%a" literal (Literal_bytes (Bytes.of_string "foo")) ;
[%expect{| 0x666f6f |}]

View File

@ -5,8 +5,9 @@
simple-utils simple-utils
tezos-utils tezos-utils
) )
(inline_tests)
(preprocess (preprocess
(pps ppx_let) (pps ppx_let ppx_expect)
) )
(flags (:standard -open Simple_utils)) (flags (:standard -open Simple_utils))
) )

View File

@ -58,8 +58,7 @@ let rec value ppf : value -> unit = function
| D_unit -> fprintf ppf "unit" | D_unit -> fprintf ppf "unit"
| D_string s -> fprintf ppf "\"%s\"" s | D_string s -> fprintf ppf "\"%s\"" s
| D_bytes x -> | D_bytes x ->
let (`Hex hex) = Hex.of_bytes x in fprintf ppf "0x%a" Hex.pp @@ Hex.of_bytes x
fprintf ppf "0x%s" hex
| D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b
| D_left a -> fprintf ppf "L(%a)" value a | D_left a -> fprintf ppf "L(%a)" value a
| D_right b -> fprintf ppf "R(%a)" value b | D_right b -> fprintf ppf "R(%a)" value b
@ -124,6 +123,10 @@ let tl_statement ppf (ass, _) = assignment ppf ass
let program ppf (p:program) = let program ppf (p:program) =
fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p
let%expect_test _ =
Format.printf "%a" value (D_bytes (Bytes.of_string "foo")) ;
[%expect{| 0x666f6f |}]
let%expect_test _ = let%expect_test _ =
let pp = expression' Format.std_formatter in let pp = expression' Format.std_formatter in
let dummy_type = T_base Base_unit in let dummy_type = T_base Base_unit in

View File

@ -1,3 +0,0 @@
type toto = int
let foo : string = 42 + 127

View File

@ -1,3 +0,0 @@
type toto = int option
let foo : string list = Some (42 + 127)

View File

@ -0,0 +1 @@
This folder contains contracts for negative tests: contracts that are expected to fail (parse error, type error and so on).

View File

@ -0,0 +1,6 @@
type toto = int
let foo : string = 42 + 127
let main (p:int) (storage : int) =
(([] : operation list) , p + foo)

View File

@ -0,0 +1,6 @@
type toto = int option
let foo : string list = Some (42 + 127)
let main (p:int) (storage : int) =
(([] : operation list) , p)

View File

@ -0,0 +1,7 @@
type toto = { a : int ; b : string ; c : bool }
type tata = { a : int ; d : string ; c : bool }
let foo : tata = ({a = 1 ; b = "foo" ; c = true} : toto)
let main (p:int) (storage : int) =
(([] : operation list) , p + foo.a)

View File

@ -0,0 +1,4 @@
let foo : boolean = 3
let main (p:int) (storage : int) =
(([] : operation list) , p + foo)

View File

@ -0,0 +1,3 @@
let foo : (int, string) map = (Map.literal [] : (int, bool) map)
let main (p:int) (storage : int) =
(([] : operation list) , p)

View File

@ -0,0 +1,7 @@
type toto = { a : int ; b : string }
type tata = { a : int ; }
let foo : tata = ({a = 1 ; b = "foo" ; c = true} : toto)
let main (p:int) (storage : int) =
(([] : operation list) , p + foo.a)

View File

@ -0,0 +1,25 @@
type storage_t is timestamp
type message_t is (unit -> list(operation))
type default_pt is unit
type call_pt is message_t
type contract_return_t is (list(operation) * storage_t)
type entry_point_t is
| Call of call_pt
| Default of default_pt
function call (const p : call_pt; const s : storage_t) : contract_return_t is block {
if s >= now then failwith("Contract is still time locked") else skip ;
const message : message_t = p ;
const ret_ops : list(operation) = message(unit) ;
} with (ret_ops,s)
function default (const p : default_pt; const s : storage_t) : contract_return_t is
((nil: list(operation)) , s)
function main(const param : entry_point_t; const s : storage_t) : contract_return_t is
case param of
| Call (p) -> call(p,s)
| Default (p) -> default(p,s)
end

View File

@ -15,7 +15,8 @@
(alias (alias
(name ligo-test) (name ligo-test)
(action (run ./test.exe)) (action (run ./test.exe))
(deps (glob_files contracts/*)) (deps (glob_files contracts/*)
(glob_files contracts/negative/*))
) )
(alias (alias

View File

@ -13,5 +13,6 @@ let () =
Multisig_tests.main ; Multisig_tests.main ;
Multisig_v2_tests.main ; Multisig_v2_tests.main ;
Replaceable_id_tests.main ; Replaceable_id_tests.main ;
Time_lock_tests.main ;
] ; ] ;
() ()

View File

@ -1,4 +1,4 @@
open! Trace open Trace
type test_case = unit Alcotest.test_case type test_case = unit Alcotest.test_case
type test = type test =
@ -17,7 +17,7 @@ let wrap_test name f =
let wrap_test_raw f = let wrap_test_raw f =
match f () with match f () with
| Trace.Ok ((), annotations) -> ignore annotations; () | Ok ((), annotations) -> ignore annotations; ()
| Error err -> | Error err ->
Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ()) Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ())

View File

@ -0,0 +1,69 @@
open Trace
open Test_helpers
let type_file f =
let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in
let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in
ok @@ (typed,state)
let get_program =
let s = ref None in
fun () -> match !s with
| Some s -> ok s
| None -> (
let%bind program = type_file "./contracts/time-lock.ligo" in
s := Some program ;
ok program
)
let compile_main () =
let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/time-lock.ligo" (Syntax_name "pascaligo") in
let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in
let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Ligo.Compile.Of_michelson.build_contract michelson_prg in
ok ()
open Ast_simplified
let empty_op_list =
(e_typed_list [] t_operation)
let empty_message = e_lambda (Var.of_name "arguments")
(Some t_unit) (Some (t_list t_operation))
empty_op_list
let call msg = e_constructor "Call" msg
let mk_time st =
match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with
| Some s -> ok s
| None -> simple_fail "bad timestamp notation"
let to_sec t = Tezos_utils.Time.Protocol.to_seconds t
let storage st = e_timestamp (Int64.to_int @@ to_sec st)
let early_call () =
let%bind program,_ = get_program () in
let%bind predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in
let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in
let init_storage = storage lock_time in
let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in
let exp_failwith = "Contract is still time locked" in
expect_string_failwith ~options program "main"
(e_pair (call empty_message) init_storage) exp_failwith
let call_on_time () =
let%bind program,_ = get_program () in
let%bind predecessor_timestamp = mk_time "2000-01-01T10:10:10Z" in
let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in
let init_storage = storage lock_time in
let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in
expect_eq ~options program "main"
(e_pair (call empty_message) init_storage) (e_pair empty_op_list init_storage)
let main = test_suite "Time lock" [
test "compile" compile_main ;
test "early call" early_call ;
test "call on time" call_on_time ;
]

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name tezos-memory-proto-alpha)

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name proto-alpha-utils)

View File

@ -11,7 +11,7 @@ let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err)
let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result = let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result =
function function
| Result.Ok x -> ok x | Ok x -> ok x
| Error errs -> fail @@ thunk @@ patch_children (List.map of_alpha_tz_error errs) (err ()) | Error errs -> fail @@ thunk @@ patch_children (List.map of_alpha_tz_error errs) (err ())
let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result =
@ -19,17 +19,17 @@ let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ resul
let trace_tzresult err = let trace_tzresult err =
function function
| Result.Ok x -> ok x | Ok x -> ok x
| Error errs -> fail @@ thunk @@ patch_children (List.map of_tz_error errs) (err ()) | Error errs -> fail @@ thunk @@ patch_children (List.map of_tz_error errs) (err ())
(* TODO: should be a combination of trace_tzresult and trace_r *) (* TODO: should be a combination of trace_tzresult and trace_r *)
let trace_tzresult_r err_thunk_may_fail = let trace_tzresult_r err_thunk_may_fail =
function function
| Result.Ok x -> ok x | Ok x -> ok x
| Error errs -> | Error errs ->
let tz_errs = List.map of_tz_error errs in let tz_errs = List.map of_tz_error errs in
match err_thunk_may_fail () with match err_thunk_may_fail () with
| Simple_utils.Trace.Ok (err, annotations) -> | Ok (err, annotations) ->
ignore annotations ; ignore annotations ;
Error (fun () -> patch_children tz_errs (err ())) Error (fun () -> patch_children tz_errs (err ()))
| Error errors_while_generating_error -> | Error errors_while_generating_error ->

View File

@ -1066,13 +1066,16 @@ type options = {
let make_options let make_options
?(tezos_context = dummy_environment.tezos_context) ?(tezos_context = dummy_environment.tezos_context)
?(predecessor_timestamp = dummy_environment.tezos_context.predecessor_timestamp)
?(source = (List.nth dummy_environment.identities 0).implicit_contract) ?(source = (List.nth dummy_environment.identities 0).implicit_contract)
?(self = (List.nth dummy_environment.identities 0).implicit_contract) ?(self = (List.nth dummy_environment.identities 0).implicit_contract)
?(payer = (List.nth dummy_environment.identities 1).implicit_contract) ?(payer = (List.nth dummy_environment.identities 1).implicit_contract)
?(amount = Alpha_context.Tez.one) ?(amount = Alpha_context.Tez.one)
?(chain_id = Environment.Chain_id.zero) ?(chain_id = Environment.Chain_id.zero)
() ()
= { =
let tezos_context = { tezos_context with predecessor_timestamp } in
{
tezos_context ; tezos_context ;
source ; source ;
self ; self ;

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name simple-utils)

View File

@ -6,8 +6,8 @@
*) *)
module Trace_tutorial = struct module Trace_tutorial = struct
(** The trace monad is fairly similar to the predefined option (** The trace monad is fairly similar to the predefined [option]
type. *) type. It is an instance of the predefined [result] type. *)
type annotation = string type annotation = string
type error = string type error = string
@ -23,18 +23,20 @@ module Trace_tutorial = struct
list of annotations (information about past successful list of annotations (information about past successful
computations), or it is a list of errors accumulated so far. computations), or it is a list of errors accumulated so far.
The former case is denoted by the data constructor [Ok], and the The former case is denoted by the data constructor [Ok], and the
second by [Errors]. second by [Error].
*) *)
type 'a result = type nonrec 'a result = ('a * annotation list, error list) result
Ok of 'a * annotation list (*
| Errors of error list = Ok of 'a * annotation list
| Error of error list
*)
(** The function [divide_trace] shows the basic use of the trace (** The function [divide_trace] shows the basic use of the trace
monad. monad.
*) *)
let divide_trace a b = let divide_trace a b =
if b = 0 if b = 0
then Errors [Printf.sprintf "division by zero: %d/%d" a b] then Error [Printf.sprintf "division by zero: %d/%d" a b]
else Ok (a/b, []) else Ok (a/b, [])
(** The function [divide_three] shows that when composing two (** The function [divide_three] shows that when composing two
@ -81,7 +83,7 @@ module Trace_tutorial = struct
match f x with match f x with
Ok (x', annot') -> Ok (x', annot' @ annot) Ok (x', annot') -> Ok (x', annot' @ annot)
| errors -> ignore annot; errors) | errors -> ignore annot; errors)
| Errors _ as e -> e | Error _ as e -> e
(** The function [divide_three_bind] is equivalent to the verbose (** The function [divide_three_bind] is equivalent to the verbose
[divide_three] above, but makes use of [bind]. [divide_three] above, but makes use of [bind].
@ -169,7 +171,7 @@ module Trace_tutorial = struct
{li If the list only contains [Ok] values, it strips the [Ok] {li If the list only contains [Ok] values, it strips the [Ok]
of each element and returns that list wrapped with [Ok].} of each element and returns that list wrapped with [Ok].}
{li Otherwise, one or more of the elements of the input list {li Otherwise, one or more of the elements of the input list
is [Errors], then [bind_list] returns the first error in the is [Error], then [bind_list] returns the first error in the
list.}} list.}}
*) *)
let rec bind_list = function let rec bind_list = function
@ -199,7 +201,7 @@ module Trace_tutorial = struct
And this will pass along the error triggered by [get key map]. And this will pass along the error triggered by [get key map].
*) *)
let trace err = function let trace err = function
Errors e -> Errors (err::e) Error e -> Error (err::e)
| ok -> ok | ok -> ok
(** The real trace monad is very similar to the one that we have (** The real trace monad is very similar to the one that we have
@ -293,9 +295,11 @@ type annotation_thunk = annotation thunk
(** Types of traced elements. It might be good to rename it [trace] at (** Types of traced elements. It might be good to rename it [trace] at
some point. some point.
*) *)
type 'a result = type nonrec 'a result = ('a * annotation_thunk list, error_thunk) result
Ok of 'a * annotation_thunk list (*
= Ok of 'a * annotation_thunk list
| Error of error_thunk | Error of error_thunk
*)
(** {1 Constructors} *) (** {1 Constructors} *)

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name tezos-protocol-005-PsBabyM1-parameters)

View File

@ -30,7 +30,7 @@ module type BASIC_DATA = sig
val pp: Format.formatter -> t -> unit val pp: Format.formatter -> t -> unit
end end
type t type t = Raw_context.t
type context = t type context = t
type public_key = Signature.Public_key.t type public_key = Signature.Public_key.t

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name tezos-embedded-protocol-005-PsBabyM1)

View File

@ -45,7 +45,34 @@ val storage_error: storage_error -> 'a tzresult Lwt.t
(** Abstract view of the context. (** Abstract view of the context.
Includes a handle to the functional key-value database Includes a handle to the functional key-value database
({!Context.t}) along with some in-memory values (gas, etc.). *) ({!Context.t}) along with some in-memory values (gas, etc.). *)
type t module Int_set : sig
type t
end
type t = {
context: Context.t ;
constants: Constants_repr.parametric ;
first_level: Raw_level_repr.t ;
level: Level_repr.t ;
predecessor_timestamp: Time.t ;
timestamp: Time.t ;
fitness: Int64.t ;
deposits: Tez_repr.t Signature.Public_key_hash.Map.t ;
included_endorsements: int ;
allowed_endorsements:
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ;
fees: Tez_repr.t ;
rewards: Tez_repr.t ;
block_gas: Z.t ;
operation_gas: Gas_limit_repr.t ;
internal_gas: Gas_limit_repr.internal_gas ;
storage_space_to_pay: Z.t option ;
allocated_contracts: int option ;
origination_nonce: Contract_repr.origination_nonce option ;
temporary_big_map: Z.t ;
internal_nonce: int ;
internal_nonces_used: Int_set.t ;
}
type context = t type context = t
type root_context = t type root_context = t

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name tezos-utils)

View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name michelson-parser)