Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht@pprint_comments
This commit is contained in:
Christian Rinderknecht
commit
3ec21a8762
@ -33,7 +33,7 @@ let%expect_test _ =
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_2.ligo" ; "main" ] ;
|
||||
[%expect{|
|
||||
ligo: error
|
||||
in file "bad_michelson_insertion_2.ligo", line 3, character 0 to line 5, character 41
|
||||
in file "bad_michelson_insertion_2.ligo", line 3, characters 9-13
|
||||
Constant declaration 'main'
|
||||
Bad types: expected nat got ( nat * nat )
|
||||
|
||||
|
||||
@ -56,7 +56,6 @@ type c_Some = Region.t
|
||||
|
||||
type arrow = Region.t (* "->" *)
|
||||
type cons = Region.t (* "::" *)
|
||||
type percent = Region.t (* "%" *)
|
||||
type cat = Region.t (* "^" *)
|
||||
type append = Region.t (* "@" *)
|
||||
type dot = Region.t (* "." *)
|
||||
|
||||
@ -586,6 +586,12 @@ core_expr:
|
||||
| par(expr) { EPar $1 }
|
||||
| par(annot_expr) { EAnnot $1 }
|
||||
|
||||
code_inj:
|
||||
"<lang>" expr "]" {
|
||||
let region = cover $1.region $3
|
||||
and value = {language=$1; code=$2; rbracket=$3}
|
||||
in {region; value} }
|
||||
|
||||
annot_expr:
|
||||
expr ":" type_expr { $1,$2,$3 }
|
||||
|
||||
@ -652,49 +658,41 @@ field_path_assignment :
|
||||
field_assignment:
|
||||
field_name "=" expr {
|
||||
let region = cover $1.region (expr_to_region $3)
|
||||
and value = {field_name = $1;
|
||||
assignment = $2;
|
||||
field_expr = $3}
|
||||
and value = {field_name=$1; assignment=$2; field_expr=$3}
|
||||
in {region; value} }
|
||||
|
||||
path :
|
||||
"<ident>" { Name $1 }
|
||||
| projection { Path $1 }
|
||||
|
||||
(* Sequences *)
|
||||
|
||||
sequence:
|
||||
"begin" series? "end" {
|
||||
let region = cover $1 $3
|
||||
and compound = BeginEnd ($1,$3) in
|
||||
let elements, terminator =
|
||||
match $2 with
|
||||
None -> None, None
|
||||
| Some (ne_elements, terminator) ->
|
||||
Some ne_elements, terminator in
|
||||
let value = {compound; elements; terminator}
|
||||
let elements = $2 in
|
||||
let value = {compound; elements; terminator=None}
|
||||
in {region; value} }
|
||||
|
||||
series:
|
||||
last_expr {
|
||||
let expr, term = $1 in (expr, []), term
|
||||
}
|
||||
| seq_expr ";" series {
|
||||
let rest, term = $3 in
|
||||
let seq = Utils.nsepseq_cons $1 $2 rest
|
||||
in seq, term }
|
||||
seq_expr ";" series { Utils.nsepseq_cons $1 $2 $3 }
|
||||
| last_expr { $1,[] }
|
||||
|
||||
last_expr:
|
||||
seq_expr ";"?
|
||||
| fun_expr(seq_expr) ";"?
|
||||
| match_expr(seq_expr) ";"? {
|
||||
$1,$2
|
||||
}
|
||||
| "let" ioption("rec") let_binding seq(Attr) "in" series {
|
||||
let seq, term = $6 in
|
||||
seq_expr
|
||||
| fun_expr(last_expr)
|
||||
| match_expr(last_expr)
|
||||
| let_in_sequence { $1 }
|
||||
|
||||
let_in_sequence:
|
||||
"let" ioption("rec") let_binding seq(Attr) "in" series {
|
||||
let seq = $6 in
|
||||
let stop = nsepseq_to_region expr_to_region seq in
|
||||
let region = cover $1 stop in
|
||||
let compound = BeginEnd (Region.ghost, Region.ghost) in
|
||||
let elements = Some seq in
|
||||
let value = {compound; elements; terminator=term} in
|
||||
let value = {compound; elements; terminator=None} in
|
||||
let body = ESeq {region; value} in
|
||||
let value = {kwd_let = $1;
|
||||
kwd_rec = $2;
|
||||
@ -702,13 +700,7 @@ last_expr:
|
||||
attributes = $4;
|
||||
kwd_in = $5;
|
||||
body}
|
||||
in ELetIn {region; value}, term }
|
||||
in ELetIn {region; value} }
|
||||
|
||||
seq_expr:
|
||||
disj_expr_level | if_then_else (seq_expr) { $1 }
|
||||
|
||||
code_inj:
|
||||
"<lang>" expr "]" {
|
||||
let region = cover $1.region $3
|
||||
and value = {language=$1; code=$2; rbracket=$3}
|
||||
in {region; value} }
|
||||
|
||||
@ -53,7 +53,7 @@
|
||||
(executable
|
||||
(name ParserMain)
|
||||
(libraries parser_cameligo)
|
||||
(modules ParserMain)
|
||||
(modules ParserMain Parser_msg)
|
||||
(preprocess
|
||||
(pps bisect_ppx --conditional))
|
||||
(flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo)))
|
||||
@ -65,6 +65,19 @@
|
||||
(deps (:script_messages ../../../../vendors/ligo-utils/simple-utils/messages.sh) Parser.mly LexToken.mli ParToken.mly)
|
||||
(action (run %{script_messages} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly Parser.mly)))
|
||||
|
||||
(rule
|
||||
(targets Parser_msg.ml)
|
||||
(deps Parser.mly ParToken.mly Parser.msg)
|
||||
(action
|
||||
(with-stdout-to %{targets}
|
||||
(bash
|
||||
"menhir \
|
||||
--compile-errors Parser.msg \
|
||||
--external-tokens LexToken \
|
||||
--base Parser \
|
||||
ParToken.mly \
|
||||
Parser.mly"))))
|
||||
|
||||
;; Build of all the LIGO source file that cover all error states
|
||||
|
||||
(rule
|
||||
@ -74,27 +87,6 @@
|
||||
|
||||
;; Error messages
|
||||
|
||||
;; Generate error messages from scratch
|
||||
; (rule
|
||||
; (targets error.messages)
|
||||
; (deps Parser.mly ParToken.mly error.messages.checked-in)
|
||||
; (action
|
||||
; (with-stdout-to %{targets}
|
||||
; (bash
|
||||
; "menhir \
|
||||
; --unused-tokens \
|
||||
; --list-errors \
|
||||
; --table \
|
||||
; --strict \
|
||||
; --external-tokens LexToken.mli \
|
||||
; --base Parser.mly \
|
||||
; ParToken.mly \
|
||||
; Parser.mly
|
||||
; "
|
||||
; )
|
||||
; ))
|
||||
; )
|
||||
|
||||
(rule
|
||||
(targets error.messages)
|
||||
(mode (promote (until-clean) (only *)))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -160,8 +160,7 @@ and attr_decl = string reg ne_injection reg
|
||||
and const_decl = {
|
||||
kwd_const : kwd_const;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
const_type : type_expr;
|
||||
const_type : (colon * type_expr) option;
|
||||
equal : equal;
|
||||
init : expr;
|
||||
terminator : semi option;
|
||||
@ -208,8 +207,7 @@ and type_tuple = (type_expr, comma) nsepseq par reg
|
||||
and fun_expr = {
|
||||
kwd_function : kwd_function;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
ret_type : type_expr;
|
||||
ret_type : (colon * type_expr) option;
|
||||
kwd_is : kwd_is;
|
||||
return : expr
|
||||
}
|
||||
@ -219,8 +217,7 @@ and fun_decl = {
|
||||
kwd_function : kwd_function;
|
||||
fun_name : variable;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
ret_type : type_expr;
|
||||
ret_type : (colon * type_expr) option;
|
||||
kwd_is : kwd_is;
|
||||
block_with : (block reg * kwd_with) option;
|
||||
return : expr;
|
||||
@ -237,15 +234,13 @@ and param_decl =
|
||||
and param_const = {
|
||||
kwd_const : kwd_const;
|
||||
var : variable;
|
||||
colon : colon;
|
||||
param_type : type_expr
|
||||
param_type : (colon * type_expr) option
|
||||
}
|
||||
|
||||
and param_var = {
|
||||
kwd_var : kwd_var;
|
||||
var : variable;
|
||||
colon : colon;
|
||||
param_type : type_expr
|
||||
param_type : (colon * type_expr) option
|
||||
}
|
||||
|
||||
and block = {
|
||||
@ -273,8 +268,7 @@ and data_decl =
|
||||
and var_decl = {
|
||||
kwd_var : kwd_var;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
var_type : type_expr;
|
||||
var_type : (colon * type_expr) option;
|
||||
assign : assign;
|
||||
init : expr;
|
||||
terminator : semi option;
|
||||
@ -413,19 +407,15 @@ and for_loop =
|
||||
|
||||
and for_int = {
|
||||
kwd_for : kwd_for;
|
||||
assign : var_assign reg;
|
||||
binder : variable;
|
||||
assign : assign;
|
||||
init : expr;
|
||||
kwd_to : kwd_to;
|
||||
bound : expr;
|
||||
step : (kwd_step * expr) option;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
and var_assign = {
|
||||
name : variable;
|
||||
assign : assign;
|
||||
expr : expr
|
||||
}
|
||||
|
||||
and for_collect = {
|
||||
kwd_for : kwd_for;
|
||||
var : variable;
|
||||
@ -634,6 +624,7 @@ and pattern =
|
||||
| PTuple of tuple_pattern
|
||||
|
||||
and constr_pattern =
|
||||
(*What is a unit pattern what does it catch ? is it like PWild ? *)
|
||||
PUnit of c_Unit
|
||||
| PFalse of c_False
|
||||
| PTrue of c_True
|
||||
@ -646,6 +637,7 @@ and tuple_pattern = (pattern, comma) nsepseq par reg
|
||||
and list_pattern =
|
||||
PListComp of pattern injection reg
|
||||
| PNil of kwd_nil
|
||||
(* Currently hd # tl is PCons, i would expect this to have type pattern * cons * pattern just like PParCons*)
|
||||
| PParCons of (pattern * cons * pattern) par reg
|
||||
| PCons of (pattern, cons) nsepseq reg
|
||||
|
||||
|
||||
@ -142,6 +142,7 @@ type_decl:
|
||||
terminator = $5}
|
||||
in {region; value} }
|
||||
|
||||
type_expr_colon: ":" type_expr { $1,$2 }
|
||||
type_expr:
|
||||
fun_type | sum_type | record_type { $1 }
|
||||
|
||||
@ -239,52 +240,49 @@ field_decl:
|
||||
|
||||
|
||||
fun_expr:
|
||||
"function" parameters ":" type_expr "is" expr {
|
||||
let stop = expr_to_region $6 in
|
||||
"function" parameters type_expr_colon? "is" expr {
|
||||
let stop = expr_to_region $5 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_function = $1;
|
||||
param = $2;
|
||||
colon = $3;
|
||||
ret_type = $4;
|
||||
kwd_is = $5;
|
||||
return = $6}
|
||||
ret_type = $3;
|
||||
kwd_is = $4;
|
||||
return = $5}
|
||||
in {region; value} }
|
||||
|
||||
(* Function declarations *)
|
||||
|
||||
open_fun_decl:
|
||||
ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
|
||||
ioption ("recursive") "function" fun_name parameters type_expr_colon? "is"
|
||||
block "with" expr {
|
||||
Scoping.check_reserved_name $3;
|
||||
let stop = expr_to_region $10 in
|
||||
let stop = expr_to_region $9 in
|
||||
let region = cover $2 stop
|
||||
and value = {kwd_recursive= $1;
|
||||
kwd_function = $2;
|
||||
fun_name = $3;
|
||||
param = $4;
|
||||
colon = $5;
|
||||
ret_type = $6;
|
||||
kwd_is = $7;
|
||||
block_with = Some ($8, $9);
|
||||
return = $10;
|
||||
ret_type = $5;
|
||||
kwd_is = $6;
|
||||
block_with = Some ($7, $8);
|
||||
return = $9;
|
||||
terminator = None;
|
||||
attributes = None}
|
||||
in {region; value}
|
||||
}
|
||||
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
|
||||
| ioption ("recursive") "function" fun_name parameters type_expr_colon? "is"
|
||||
expr {
|
||||
Scoping.check_reserved_name $3;
|
||||
let stop = expr_to_region $8 in
|
||||
let stop = expr_to_region $7 in
|
||||
let region = cover $2 stop
|
||||
and value = {kwd_recursive= $1;
|
||||
kwd_function = $2;
|
||||
fun_name = $3;
|
||||
param = $4;
|
||||
colon = $5;
|
||||
ret_type = $6;
|
||||
kwd_is = $7;
|
||||
ret_type = $5;
|
||||
kwd_is = $6;
|
||||
block_with = None;
|
||||
return = $8;
|
||||
return = $7;
|
||||
terminator = None;
|
||||
attributes = None}
|
||||
in {region; value} }
|
||||
@ -300,28 +298,26 @@ parameters:
|
||||
in Scoping.check_parameters params; $1 }
|
||||
|
||||
param_decl:
|
||||
"var" var ":" param_type {
|
||||
"var" var param_type? {
|
||||
Scoping.check_reserved_name $2;
|
||||
let stop = type_expr_to_region $4 in
|
||||
let stop = match $3 with None -> $2.region | Some (_,t) -> type_expr_to_region t in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_var = $1;
|
||||
var = $2;
|
||||
colon = $3;
|
||||
param_type = $4}
|
||||
param_type = $3}
|
||||
in ParamVar {region; value}
|
||||
}
|
||||
| "const" var ":" param_type {
|
||||
| "const" var param_type? {
|
||||
Scoping.check_reserved_name $2;
|
||||
let stop = type_expr_to_region $4 in
|
||||
let stop = match $3 with None -> $2.region | Some (_,t) -> type_expr_to_region t in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_const = $1;
|
||||
var = $2;
|
||||
colon = $3;
|
||||
param_type = $4}
|
||||
param_type = $3}
|
||||
in ParamConst {region; value} }
|
||||
|
||||
param_type:
|
||||
fun_type { $1 }
|
||||
":" fun_type { $1,$2 }
|
||||
|
||||
block:
|
||||
"begin" sep_or_term_list(statement,";") "end" {
|
||||
@ -352,11 +348,10 @@ open_data_decl:
|
||||
|
||||
open_const_decl:
|
||||
"const" unqualified_decl("=") {
|
||||
let name, colon, const_type, equal, init, stop = $2 in
|
||||
let name, const_type, equal, init, stop = $2 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_const = $1;
|
||||
name;
|
||||
colon;
|
||||
const_type;
|
||||
equal;
|
||||
init;
|
||||
@ -366,11 +361,10 @@ open_const_decl:
|
||||
|
||||
open_var_decl:
|
||||
"var" unqualified_decl(":=") {
|
||||
let name, colon, var_type, assign, init, stop = $2 in
|
||||
let name, var_type, assign, init, stop = $2 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_var = $1;
|
||||
name;
|
||||
colon;
|
||||
var_type;
|
||||
assign;
|
||||
init;
|
||||
@ -378,10 +372,10 @@ open_var_decl:
|
||||
in {region; value} }
|
||||
|
||||
unqualified_decl(OP):
|
||||
var ":" type_expr OP expr {
|
||||
var type_expr_colon? OP expr {
|
||||
Scoping.check_reserved_name $1;
|
||||
let region = expr_to_region $5
|
||||
in $1, $2, $3, $4, $5, region }
|
||||
let region = expr_to_region $4
|
||||
in $1, $2, $3, $4, region }
|
||||
|
||||
const_decl:
|
||||
open_const_decl ";"? {
|
||||
@ -616,26 +610,30 @@ while_loop:
|
||||
in While {region; value} }
|
||||
|
||||
for_loop:
|
||||
"for" var_assign "to" expr block {
|
||||
let region = cover $1 $5.region in
|
||||
let value = {kwd_for = $1;
|
||||
assign = $2;
|
||||
kwd_to = $3;
|
||||
bound = $4;
|
||||
step = None;
|
||||
block = $5}
|
||||
in For (ForInt {region; value})
|
||||
}
|
||||
| "for" var_assign "to" expr "step" expr block {
|
||||
"for" var ":=" expr "to" expr block {
|
||||
let region = cover $1 $7.region in
|
||||
let value = {kwd_for = $1;
|
||||
assign = $2;
|
||||
kwd_to = $3;
|
||||
bound = $4;
|
||||
step = Some ($5, $6);
|
||||
binder = $2;
|
||||
assign = $3;
|
||||
init = $4;
|
||||
kwd_to = $5;
|
||||
bound = $6;
|
||||
step = None;
|
||||
block = $7}
|
||||
in For (ForInt {region; value})
|
||||
}
|
||||
| "for" var ":=" expr "to" expr "step" expr block {
|
||||
let region = cover $1 $9.region in
|
||||
let value = {kwd_for = $1;
|
||||
binder = $2;
|
||||
assign = $3;
|
||||
init = $4;
|
||||
kwd_to = $5;
|
||||
bound = $6;
|
||||
step = Some ($7, $8);
|
||||
block = $9}
|
||||
in For (ForInt {region; value})
|
||||
}
|
||||
| "for" var arrow_clause? "in" collection expr block {
|
||||
Scoping.check_reserved_name $2;
|
||||
let region = cover $1 $7.region in
|
||||
@ -653,13 +651,6 @@ collection:
|
||||
| "set" { Set $1 }
|
||||
| "list" { List $1 }
|
||||
|
||||
var_assign:
|
||||
var ":=" expr {
|
||||
Scoping.check_reserved_name $1;
|
||||
let region = cover $1.region (expr_to_region $3)
|
||||
and value = {name=$1; assign=$2; expr=$3}
|
||||
in {region; value} }
|
||||
|
||||
arrow_clause:
|
||||
"->" var { Scoping.check_reserved_name $2; ($1,$2) }
|
||||
|
||||
|
||||
@ -64,6 +64,11 @@ let print_sepseq :
|
||||
None -> ()
|
||||
| Some seq -> print_nsepseq state sep print seq
|
||||
|
||||
let print_option : state -> (state -> 'a -> unit ) -> 'a option -> unit =
|
||||
fun state print -> function
|
||||
None -> ()
|
||||
| Some opt -> print state opt
|
||||
|
||||
let print_token state region lexeme =
|
||||
let line =
|
||||
sprintf "%s: %s\n"(compact state region) lexeme
|
||||
@ -132,12 +137,11 @@ and print_decl state = function
|
||||
| AttrDecl decl -> print_attr_decl state decl
|
||||
|
||||
and print_const_decl state {value; _} =
|
||||
let {kwd_const; name; colon; const_type;
|
||||
let {kwd_const; name; const_type;
|
||||
equal; init; terminator; _} = value in
|
||||
print_token state kwd_const "const";
|
||||
print_var state name;
|
||||
print_token state colon ":";
|
||||
print_type_expr state const_type;
|
||||
print_option state print_colon_type_expr const_type;
|
||||
print_token state equal "=";
|
||||
print_expr state init;
|
||||
print_terminator state terminator
|
||||
@ -161,6 +165,10 @@ and print_type_expr state = function
|
||||
| TVar type_var -> print_var state type_var
|
||||
| TString str -> print_string state str
|
||||
|
||||
and print_colon_type_expr state (colon, type_expr) =
|
||||
print_token state colon ":";
|
||||
print_type_expr state type_expr;
|
||||
|
||||
and print_cartesian state {value; _} =
|
||||
print_nsepseq state "*" print_type_expr value
|
||||
|
||||
@ -209,14 +217,13 @@ and print_type_tuple state {value; _} =
|
||||
print_token state rpar ")"
|
||||
|
||||
and print_fun_decl state {value; _} =
|
||||
let {kwd_function; fun_name; param; colon;
|
||||
let {kwd_function; fun_name; param;
|
||||
ret_type; kwd_is; block_with;
|
||||
return; terminator; _} = value in
|
||||
print_token state kwd_function "function";
|
||||
print_var state fun_name;
|
||||
print_parameters state param;
|
||||
print_token state colon ":";
|
||||
print_type_expr state ret_type;
|
||||
print_option state print_colon_type_expr ret_type;
|
||||
print_token state kwd_is "is";
|
||||
(match block_with with
|
||||
None -> ()
|
||||
@ -227,12 +234,11 @@ and print_fun_decl state {value; _} =
|
||||
print_terminator state terminator;
|
||||
|
||||
and print_fun_expr state {value; _} =
|
||||
let {kwd_function; param; colon;
|
||||
let {kwd_function; param;
|
||||
ret_type; kwd_is; return} : fun_expr = value in
|
||||
print_token state kwd_function "function";
|
||||
print_parameters state param;
|
||||
print_token state colon ":";
|
||||
print_type_expr state ret_type;
|
||||
print_option state print_colon_type_expr ret_type;
|
||||
print_token state kwd_is "is";
|
||||
print_expr state return
|
||||
|
||||
@ -257,18 +263,16 @@ and print_param_decl state = function
|
||||
| ParamVar param_var -> print_param_var state param_var
|
||||
|
||||
and print_param_const state {value; _} =
|
||||
let {kwd_const; var; colon; param_type} = value in
|
||||
let {kwd_const; var; param_type} = value in
|
||||
print_token state kwd_const "const";
|
||||
print_var state var;
|
||||
print_token state colon ":";
|
||||
print_type_expr state param_type
|
||||
print_option state print_colon_type_expr param_type
|
||||
|
||||
and print_param_var state {value; _} =
|
||||
let {kwd_var; var; colon; param_type} = value in
|
||||
let {kwd_var; var; param_type} = value in
|
||||
print_token state kwd_var "var";
|
||||
print_var state var;
|
||||
print_token state colon ":";
|
||||
print_type_expr state param_type
|
||||
print_option state print_colon_type_expr param_type
|
||||
|
||||
and print_block state block =
|
||||
let {enclosing; statements; terminator} = block.value in
|
||||
@ -291,12 +295,11 @@ and print_data_decl state = function
|
||||
| LocalFun decl -> print_fun_decl state decl
|
||||
|
||||
and print_var_decl state {value; _} =
|
||||
let {kwd_var; name; colon; var_type;
|
||||
let {kwd_var; name; var_type;
|
||||
assign; init; terminator} = value in
|
||||
print_token state kwd_var "var";
|
||||
print_var state name;
|
||||
print_token state colon ":";
|
||||
print_type_expr state var_type;
|
||||
print_option state print_colon_type_expr var_type;
|
||||
print_token state assign ":=";
|
||||
print_expr state init;
|
||||
print_terminator state terminator
|
||||
@ -411,9 +414,11 @@ and print_for_loop state = function
|
||||
| ForCollect for_collect -> print_for_collect state for_collect
|
||||
|
||||
and print_for_int state ({value; _} : for_int reg) =
|
||||
let {kwd_for; assign; kwd_to; bound; step; block} = value in
|
||||
let {kwd_for; binder; assign; init; kwd_to; bound; step; block} = value in
|
||||
print_token state kwd_for "for";
|
||||
print_var_assign state assign;
|
||||
print_var state binder;
|
||||
print_token state assign ":=";
|
||||
print_expr state init;
|
||||
print_token state kwd_to "to";
|
||||
print_expr state bound;
|
||||
(match step with
|
||||
@ -423,12 +428,6 @@ and print_for_int state ({value; _} : for_int reg) =
|
||||
print_expr state expr);
|
||||
print_block state block
|
||||
|
||||
and print_var_assign state {value; _} =
|
||||
let {name; assign; expr} = value in
|
||||
print_var state name;
|
||||
print_token state assign ":=";
|
||||
print_expr state expr
|
||||
|
||||
and print_for_collect state ({value; _} : for_collect reg) =
|
||||
let {kwd_for; var; bind_to;
|
||||
kwd_in; collection; expr; block} = value in
|
||||
@ -935,7 +934,7 @@ and pp_fun_decl state decl =
|
||||
let () =
|
||||
let state = state#pad arity (start + 2) in
|
||||
pp_node state "<return type>";
|
||||
pp_type_expr (state#pad 1 0) decl.ret_type in
|
||||
print_option (state#pad 1 0) pp_type_expr @@ Option.map snd decl.ret_type in
|
||||
let () =
|
||||
let state = state#pad arity (start + 3) in
|
||||
pp_node state "<body>";
|
||||
@ -953,7 +952,7 @@ and pp_fun_decl state decl =
|
||||
and pp_const_decl state decl =
|
||||
let arity = 3 in
|
||||
pp_ident (state#pad arity 0) decl.name;
|
||||
pp_type_expr (state#pad arity 1) decl.const_type;
|
||||
print_option (state#pad arity 1) pp_type_expr @@ Option.map snd decl.const_type;
|
||||
pp_expr (state#pad arity 2) decl.init
|
||||
|
||||
and pp_type_expr state = function
|
||||
@ -1022,7 +1021,7 @@ and pp_fun_expr state (expr: fun_expr) =
|
||||
let () =
|
||||
let state = state#pad 3 1 in
|
||||
pp_node state "<return type>";
|
||||
pp_type_expr (state#pad 1 0) expr.ret_type in
|
||||
print_option (state#pad 1 0) pp_type_expr @@ Option.map snd expr.ret_type in
|
||||
let () =
|
||||
let state = state#pad 3 2 in
|
||||
pp_node state "<return>";
|
||||
@ -1050,11 +1049,11 @@ and pp_param_decl state = function
|
||||
ParamConst {value; region} ->
|
||||
pp_loc_node state "ParamConst" region;
|
||||
pp_ident (state#pad 2 0) value.var;
|
||||
pp_type_expr (state#pad 2 1) value.param_type
|
||||
print_option (state#pad 2 1) pp_type_expr @@ Option.map snd value.param_type
|
||||
| ParamVar {value; region} ->
|
||||
pp_loc_node state "ParamVar" region;
|
||||
pp_ident (state#pad 2 0) value.var;
|
||||
pp_type_expr (state#pad 2 1) value.param_type
|
||||
print_option (state#pad 2 1) pp_type_expr @@ Option.map snd value.param_type
|
||||
|
||||
and pp_statements state statements =
|
||||
let statements = Utils.nsepseq_to_list statements in
|
||||
@ -1342,13 +1341,15 @@ and pp_for_loop state = function
|
||||
pp_for_collect state value
|
||||
|
||||
and pp_for_int state for_int =
|
||||
let {assign; bound; step; block; _} = for_int in
|
||||
let {binder; init; bound; step; block; _} = for_int in
|
||||
let arity =
|
||||
match step with None -> 3 | Some _ -> 4 in
|
||||
let () =
|
||||
let state = state#pad arity 0 in
|
||||
pp_node state "<init>";
|
||||
pp_var_assign state assign.value in
|
||||
pp_ident (state#pad 2 0) binder;
|
||||
pp_expr (state#pad 2 1) init
|
||||
in
|
||||
let () =
|
||||
let state = state#pad arity 1 in
|
||||
pp_node state "<bound>";
|
||||
@ -1367,10 +1368,6 @@ and pp_for_int state for_int =
|
||||
pp_statements state statements
|
||||
in ()
|
||||
|
||||
and pp_var_assign state asgn =
|
||||
pp_ident (state#pad 2 0) asgn.name;
|
||||
pp_expr (state#pad 2 1) asgn.expr
|
||||
|
||||
and pp_for_collect state collect =
|
||||
let () =
|
||||
let state = state#pad 3 0 in
|
||||
@ -1458,7 +1455,7 @@ and pp_data_decl state = function
|
||||
|
||||
and pp_var_decl state decl =
|
||||
pp_ident (state#pad 3 0) decl.name;
|
||||
pp_type_expr (state#pad 3 1) decl.var_type;
|
||||
print_option (state#pad 3 1) pp_type_expr @@ Option.map snd decl.var_type;
|
||||
pp_expr (state#pad 3 2) decl.init
|
||||
|
||||
and pp_expr state = function
|
||||
|
||||
@ -19,6 +19,11 @@ let pp_braces : ('a -> document) -> 'a braces reg -> document =
|
||||
fun printer {value; _} ->
|
||||
string "{" ^^ nest 1 (printer value.inside ^^ string "}")
|
||||
|
||||
let pp_option : ('a -> document) -> 'a option -> document =
|
||||
fun printer -> function
|
||||
None -> empty
|
||||
| Some opt -> printer opt
|
||||
|
||||
let rec print ast =
|
||||
let app decl = group (pp_declaration decl) in
|
||||
let decl = Utils.nseq_to_list ast.decl in
|
||||
@ -35,11 +40,11 @@ and pp_attr_decl decl = pp_ne_injection pp_string decl
|
||||
and pp_const_decl {value; _} =
|
||||
let {name; const_type; init; attributes; _} = value in
|
||||
let start = string ("const " ^ name.value) in
|
||||
let t_expr = pp_type_expr const_type in
|
||||
let t_expr = const_type in
|
||||
let attr = match attributes with
|
||||
None -> empty
|
||||
| Some a -> hardline ^^ pp_attr_decl a in
|
||||
group (start ^/^ nest 2 (string ": " ^^ t_expr))
|
||||
group (start ^/^ pp_option (fun (_, d) -> nest 2 (string ": " ^^ pp_type_expr d)) t_expr)
|
||||
^^ group (break 1 ^^ nest 2 (string "= " ^^ pp_expr init))
|
||||
^^ attr
|
||||
|
||||
@ -123,10 +128,9 @@ and pp_fun_expr {value; _} =
|
||||
let {param; ret_type; return; _} : fun_expr = value in
|
||||
let start = string "function" in
|
||||
let parameters = pp_par pp_parameters param in
|
||||
let return_t = pp_type_expr ret_type in
|
||||
let expr = pp_expr return in
|
||||
group (start ^^ nest 2 (break 1 ^^ parameters))
|
||||
^^ group (break 1 ^^ nest 2 (string ": " ^^ return_t))
|
||||
^^ pp_option (fun (_,d) -> group (break 1 ^^ nest 2 (string ": " ^^ pp_type_expr d))) ret_type
|
||||
^^ string " is" ^^ group (nest 4 (break 1 ^^ expr))
|
||||
|
||||
and pp_fun_decl {value; _} =
|
||||
@ -138,7 +142,6 @@ and pp_fun_decl {value; _} =
|
||||
| Some _ -> string "recursive" ^/^ string "function" in
|
||||
let start = start ^^ group (break 1 ^^ nest 2 (pp_ident fun_name)) in
|
||||
let parameters = pp_par pp_parameters param in
|
||||
let return_t = pp_type_expr ret_type in
|
||||
let expr = pp_expr return in
|
||||
let body =
|
||||
match block_with with
|
||||
@ -150,7 +153,7 @@ and pp_fun_decl {value; _} =
|
||||
None -> empty
|
||||
| Some a -> hardline ^^ pp_attr_decl a in
|
||||
prefix 2 1 start parameters
|
||||
^^ group (nest 2 (break 1 ^^ string ": " ^^ nest 2 return_t ^^ string " is"))
|
||||
^^ group (nest 2 (pp_option (fun (_, d) -> break 1 ^^ string ": " ^^ nest 2 (pp_type_expr d)) ret_type ^^ string " is"))
|
||||
^^ body ^^ attr
|
||||
|
||||
and pp_parameters p = pp_nsepseq ";" pp_param_decl p
|
||||
@ -161,15 +164,13 @@ and pp_param_decl = function
|
||||
|
||||
and pp_param_const {value; _} =
|
||||
let {var; param_type; _} : param_const = value in
|
||||
let name = string ("const " ^ var.value) in
|
||||
let t_expr = pp_type_expr param_type
|
||||
in prefix 2 1 (name ^^ string " :") t_expr
|
||||
let name = string ("const " ^ var.value)
|
||||
in prefix 2 1 name @@ pp_option (fun (_,d) -> string ": " ^^ pp_type_expr d) param_type
|
||||
|
||||
and pp_param_var {value; _} =
|
||||
let {var; param_type; _} : param_var = value in
|
||||
let name = string ("var " ^ var.value) in
|
||||
let t_expr = pp_type_expr param_type
|
||||
in prefix 2 1 (name ^^ string " :") t_expr
|
||||
let name = string ("var " ^ var.value)
|
||||
in prefix 2 1 name @@ pp_option (fun (_,d) -> string ": " ^^ pp_type_expr d) param_type
|
||||
|
||||
and pp_block {value; _} =
|
||||
string "block {"
|
||||
@ -191,8 +192,7 @@ and pp_data_decl = function
|
||||
and pp_var_decl {value; _} =
|
||||
let {name; var_type; init; _} = value in
|
||||
let start = string ("var " ^ name.value) in
|
||||
let t_expr = pp_type_expr var_type in
|
||||
group (start ^/^ nest 2 (string ": " ^^ t_expr))
|
||||
group (start ^/^ pp_option (fun (_,d) -> nest 2 (string ": " ^^ pp_type_expr d)) var_type)
|
||||
^^ group (break 1 ^^ nest 2 (string ":= " ^^ pp_expr init))
|
||||
|
||||
and pp_instruction = function
|
||||
@ -330,19 +330,15 @@ and pp_for_loop = function
|
||||
| ForCollect l -> pp_for_collect l
|
||||
|
||||
and pp_for_int {value; _} =
|
||||
let {assign; bound; step; block; _} = value in
|
||||
let {binder; init; bound; step; block; _} = value in
|
||||
let step =
|
||||
match step with
|
||||
None -> empty
|
||||
| Some (_, e) -> prefix 2 1 (string " step") (pp_expr e) in
|
||||
prefix 2 1 (string "for") (pp_var_assign assign)
|
||||
prefix 2 1 (string "for") (prefix 2 1 (pp_ident binder ^^ string " :=") (pp_expr init))
|
||||
^^ prefix 2 1 (string " to") (pp_expr bound)
|
||||
^^ step ^^ hardline ^^ pp_block block
|
||||
|
||||
and pp_var_assign {value; _} =
|
||||
let {name; expr; _} = value in
|
||||
prefix 2 1 (pp_ident name ^^ string " :=") (pp_expr expr)
|
||||
|
||||
and pp_for_collect {value; _} =
|
||||
let {var; bind_to; collection; expr; block; _} = value in
|
||||
let binding =
|
||||
|
||||
@ -66,6 +66,19 @@
|
||||
(deps (:script_messages ../../../../vendors/ligo-utils/simple-utils/messages.sh) Parser.mly LexToken.mli ParToken.mly)
|
||||
(action (run %{script_messages} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly Parser.mly)))
|
||||
|
||||
(rule
|
||||
(targets Parser_msg.ml)
|
||||
(deps Parser.mly ParToken.mly Parser.msg)
|
||||
(action
|
||||
(with-stdout-to %{targets}
|
||||
(bash
|
||||
"menhir \
|
||||
--compile-errors Parser.msg \
|
||||
--external-tokens LexToken \
|
||||
--base Parser \
|
||||
ParToken.mly \
|
||||
Parser.mly"))))
|
||||
|
||||
;; Build of all the LIGO source file that cover all error states
|
||||
|
||||
(rule
|
||||
@ -75,27 +88,6 @@
|
||||
|
||||
;; Error messages
|
||||
|
||||
;; Generate error messages from scratch
|
||||
; (rule
|
||||
; (targets error.messages)
|
||||
; (deps Parser.mly ParToken.mly error.messages.checked-in)
|
||||
; (action
|
||||
; (with-stdout-to %{targets}
|
||||
; (bash
|
||||
; "menhir \
|
||||
; --unused-tokens \
|
||||
; --list-errors \
|
||||
; --table \
|
||||
; --strict \
|
||||
; --external-tokens LexToken.mli \
|
||||
; --base Parser.mly \
|
||||
; ParToken.mly \
|
||||
; Parser.mly
|
||||
; "
|
||||
; )
|
||||
; ))
|
||||
; )
|
||||
|
||||
(rule
|
||||
(targets error.messages)
|
||||
(mode (promote (until-clean) (only *)))
|
||||
@ -155,8 +147,6 @@
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(rule
|
||||
(targets ParErr.ml)
|
||||
(mode (promote (until-clean) (only *)))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -65,6 +65,19 @@
|
||||
(deps (:script_messages ../../../../vendors/ligo-utils/simple-utils/messages.sh) Parser.mly LexToken.mli ParToken.mly)
|
||||
(action (run %{script_messages} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly Parser.mly )))
|
||||
|
||||
(rule
|
||||
(targets Parser_msg.ml)
|
||||
(deps Parser.mly ParToken.mly Parser.msg)
|
||||
(action
|
||||
(with-stdout-to %{targets}
|
||||
(bash
|
||||
"menhir \
|
||||
--compile-errors Parser.msg \
|
||||
--external-tokens LexToken \
|
||||
--base Parser \
|
||||
ParToken.mly \
|
||||
Parser.mly"))))
|
||||
|
||||
;; Build of all the LIGO source file that cover all error states
|
||||
|
||||
(rule
|
||||
@ -72,28 +85,6 @@
|
||||
(deps (:script_cover ../../../../vendors/ligo-utils/simple-utils/cover.sh) Parser.mly LexToken.mli ParToken.mly Parser.msg Unlexer.exe)
|
||||
(action (run %{script_cover} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly --ext=religo --unlexer=./Unlexer.exe --messages=Parser.msg --dir=. --concatenate Parser.mly )))
|
||||
|
||||
;; Error messages
|
||||
;; Generate error messages from scratch
|
||||
; (rule
|
||||
; (targets error.messages)
|
||||
; (deps Parser.mly ParToken.mly error.messages.checked-in)
|
||||
; (action
|
||||
; (with-stdout-to %{targets}
|
||||
; (bash
|
||||
; "menhir \
|
||||
; --unused-tokens \
|
||||
; --list-errors \
|
||||
; --table \
|
||||
; --strict \
|
||||
; --external-tokens LexToken.mli \
|
||||
; --base Parser.mly \
|
||||
; ParToken.mly \
|
||||
; Parser.mly
|
||||
; "
|
||||
; )
|
||||
; ))
|
||||
; )
|
||||
|
||||
(rule
|
||||
(targets error.messages)
|
||||
(mode (promote (until-clean) (only *)))
|
||||
|
||||
@ -541,7 +541,7 @@ and compile_fun lamb' : (expr , abs_error) result =
|
||||
let aux ((var : Raw.variable) , ty_opt) =
|
||||
match var.value , ty_opt with
|
||||
| "storage" , None ->
|
||||
ok (var , t_variable "storage")
|
||||
ok (var , t_variable ~loc @@ Var.fresh ~name:"storage" ())
|
||||
| _ , None ->
|
||||
fail @@ untyped_fun_param var
|
||||
| _ , Some ty -> (
|
||||
|
||||
@ -10,32 +10,38 @@ type abs_error = [
|
||||
| `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_pattern_type of Raw.pattern
|
||||
| `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_unsupported_deep_list_pattern of Raw.pattern
|
||||
| `Concrete_pascaligo_unsupported_deep_tuple_pattern of (Raw.pattern, Raw.wild) Parser_shared.Utils.nsepseq Raw.par 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
|
||||
| `Concrete_pascaligo_recursive_fun of Location.t
|
||||
| `Concrete_pascaligo_block_attribute of Raw.block Region.reg
|
||||
]
|
||||
|
||||
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 untyped_recursive_fun loc = `Concrete_pascaligo_recursive_fun loc
|
||||
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 unsupported_deep_tuple_patterns t = `Concrete_pascaligo_unsupported_deep_tuple_pattern t
|
||||
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 block_start_with_attribute block = `Concrete_pascaligo_block_attribute block
|
||||
|
||||
let rec error_ppformat : display_format:string display_format ->
|
||||
Format.formatter -> abs_error -> unit =
|
||||
@ -51,7 +57,7 @@ let rec error_ppformat : display_format:string display_format ->
|
||||
| `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)
|
||||
Location.pp_lift @@ Raw.pattern_to_region pl
|
||||
| `Concrete_pascaligo_unsupported_tuple_pattern p ->
|
||||
Format.fprintf f
|
||||
"@[<hv>%a@The following tuple pattern is not supported yet:@\"%s\"@]"
|
||||
@ -76,7 +82,11 @@ let rec error_ppformat : display_format:string display_format ->
|
||||
| `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
|
||||
Location.pp_lift @@ Raw.pattern_to_region cons
|
||||
| `Concrete_pascaligo_unsupported_deep_tuple_pattern tuple ->
|
||||
Format.fprintf f
|
||||
"@[<hv>%a@Currently, nested tuple pattern is not suppoerted@]"
|
||||
Location.pp_lift @@ tuple.Region.region
|
||||
| `Concrete_pascaligo_only_constructors p ->
|
||||
Format.fprintf f
|
||||
"@[<hv>%a@Currently, only constructors are supported in patterns@]"
|
||||
@ -105,6 +115,14 @@ let rec error_ppformat : display_format:string display_format ->
|
||||
"@[<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
|
||||
| `Concrete_pascaligo_recursive_fun loc ->
|
||||
Format.fprintf f
|
||||
"@[<hv>%a@Untyped recursive functions are not supported yet@]"
|
||||
Location.pp loc
|
||||
| `Concrete_pascaligo_block_attribute block ->
|
||||
Format.fprintf f
|
||||
"@[<hv>%a@Attributes have to follow the declaration it is attached@]"
|
||||
Location.pp_lift @@ block.region
|
||||
)
|
||||
|
||||
|
||||
@ -125,9 +143,16 @@ let rec error_jsonformat : abs_error -> J.t = fun a ->
|
||||
("location", `String loc);
|
||||
("type", t ) ] in
|
||||
json_error ~stage ~content
|
||||
| `Concrete_pascaligo_recursive_fun loc ->
|
||||
let message = `String "Untyped recursive functions are not supported yet" in
|
||||
let loc = Format.asprintf "%a" Location.pp loc in
|
||||
let content = `Assoc [
|
||||
("message", message );
|
||||
("location", `String loc);] 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
|
||||
Location.pp_lift @@ Raw.pattern_to_region pl in
|
||||
let message = `String "Currently, only booleans, lists, options, and constructors are supported in patterns" in
|
||||
let content = `Assoc [
|
||||
("message", message );
|
||||
@ -172,7 +197,14 @@ let rec error_jsonformat : abs_error -> J.t = fun a ->
|
||||
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 loc = Format.asprintf "%a" Location.pp_lift @@ Raw.pattern_to_region cons in
|
||||
let content = `Assoc [
|
||||
("message", message );
|
||||
("location", `String loc);] in
|
||||
json_error ~stage ~content
|
||||
| `Concrete_pascaligo_unsupported_deep_tuple_pattern tuple ->
|
||||
let message = `String "Currently, nested tuple pattern is not supported" in
|
||||
let loc = Format.asprintf "%a" Location.pp_lift @@ tuple.Region.region in
|
||||
let content = `Assoc [
|
||||
("message", message );
|
||||
("location", `String loc);] in
|
||||
@ -225,3 +257,10 @@ let rec error_jsonformat : abs_error -> J.t = fun a ->
|
||||
("location", `String loc);
|
||||
("children", children) ] in
|
||||
json_error ~stage ~content
|
||||
| `Concrete_pascaligo_block_attribute block ->
|
||||
let message = Format.asprintf "Attributes have to follow the declaration it is attached" in
|
||||
let loc = Format.asprintf "%a" Location.pp_lift block.region in
|
||||
let content = `Assoc [
|
||||
("message", `String message );
|
||||
("location", `String loc); ] in
|
||||
json_error ~stage ~content
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,15 +1,14 @@
|
||||
(** Converts PascaLIGO programs to the Simplified Abstract Syntax Tree. *)
|
||||
|
||||
open Trace
|
||||
open Ast_imperative
|
||||
|
||||
module Raw = Parser.Pascaligo.AST
|
||||
module SMap = Map.String
|
||||
module AST = Ast_imperative
|
||||
module CST = Parser.Pascaligo.AST
|
||||
|
||||
(** Convert a concrete PascaLIGO expression AST to the imperative
|
||||
expression AST used by the compiler. *)
|
||||
val compile_expression : Raw.expr -> (expr , Errors_pascaligo.abs_error) result
|
||||
val compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result
|
||||
|
||||
(** Convert a concrete PascaLIGO program AST to the miperative program
|
||||
AST used by the compiler. *)
|
||||
val compile_program : Raw.ast -> (program, Errors_pascaligo.abs_error) result
|
||||
val compile_program : CST.ast -> (AST.program, Errors_pascaligo.abs_error) result
|
||||
|
||||
@ -97,8 +97,13 @@ let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a, 'err) re
|
||||
let ab = (expr1,expr2) in
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
| E_assign {variable=_;access_path=_;expression} ->
|
||||
let%bind res = self init' expression in
|
||||
| E_assign {variable=_;access_path;expression} ->
|
||||
let aux res a = match a with
|
||||
| Access_map e -> self res e
|
||||
| _ -> ok res
|
||||
in
|
||||
let%bind res = bind_fold_list aux init' access_path in
|
||||
let%bind res = self res expression in
|
||||
ok res
|
||||
| E_for {body; _} ->
|
||||
let%bind res = self init' body in
|
||||
@ -246,6 +251,13 @@ let rec map_expression : 'err exp_mapper -> expression -> (expression, 'err) res
|
||||
return @@ E_sequence {expr1;expr2}
|
||||
)
|
||||
| E_assign {variable;access_path;expression} -> (
|
||||
let aux a = match a with
|
||||
| Access_map e ->
|
||||
let%bind e = self e in
|
||||
ok @@ Access_map e
|
||||
| e -> ok @@ e
|
||||
in
|
||||
let%bind access_path = bind_map_list aux access_path in
|
||||
let%bind expression = self expression in
|
||||
return @@ E_assign {variable;access_path;expression}
|
||||
)
|
||||
@ -437,7 +449,14 @@ let rec fold_map_expression : ('a, 'err) fold_mapper -> 'a -> expression -> ('a
|
||||
ok (res, return @@ E_sequence {expr1;expr2})
|
||||
)
|
||||
| E_assign {variable;access_path;expression} ->
|
||||
let%bind (res, expression) = self init' expression in
|
||||
let aux res a = match a with
|
||||
| Access_map e ->
|
||||
let%bind (res,e) = self res e in
|
||||
ok @@ (res,Access_map e)
|
||||
| e -> ok @@ (res,e)
|
||||
in
|
||||
let%bind (res, access_path) = bind_fold_map_list aux init' access_path in
|
||||
let%bind (res, expression) = self res expression in
|
||||
ok (res, return @@ E_assign {variable;access_path;expression})
|
||||
| E_for {binder; start; final; increment; body} ->
|
||||
let%bind (res, body) = self init' body in
|
||||
|
||||
@ -7,4 +7,11 @@ let peephole_expression : expression -> (expression , self_ast_imperative_error)
|
||||
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 "None"; _} -> return @@ E_constant {cons_name=C_NONE ; arguments=[]}
|
||||
| E_matching {matchee;cases=Match_variant [((Constructor "None", _),none_expr);((Constructor "Some", some),some_expr)]}
|
||||
| E_matching {matchee;cases=Match_variant [((Constructor "Some", some),some_expr);((Constructor "None", _),none_expr)]}
|
||||
->
|
||||
let match_none = none_expr in
|
||||
let match_some = some,some_expr in
|
||||
let cases = Match_option {match_none;match_some} in
|
||||
return @@ E_matching {matchee;cases}
|
||||
| e -> return e
|
||||
|
||||
@ -122,7 +122,7 @@ let rec compile_expression : I.expression -> (O.expression , sugar_to_core_error
|
||||
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
|
||||
| I.Access_map k ->
|
||||
let%bind k = compile_expression k in
|
||||
ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s]
|
||||
ok @@ O.e_constant ?loc C_MAP_ADD [k;e;s]
|
||||
in
|
||||
let aux (s, e : O.expression * _) lst =
|
||||
let%bind s' = accessor ~loc:s.location s lst in
|
||||
|
||||
@ -20,25 +20,24 @@ let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_
|
||||
let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
|
||||
let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
|
||||
let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list, [t])
|
||||
let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
|
||||
let t_constant ?loc c : type_expression = make_t ?loc @@ T_constant c
|
||||
let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable n
|
||||
let t_variable_ez ?loc n : type_expression = t_variable ?loc @@ Var.of_name n
|
||||
|
||||
let t_record ?loc record : type_expression = make_t ?loc @@ T_record record
|
||||
let t_record_ez ?loc lst =
|
||||
let lst = List.mapi (fun i (k, v) -> (Label k, {field_type=v;field_decl_pos=i})) lst in
|
||||
let m = LMap.of_list lst in
|
||||
make_t ?loc @@ T_record (m:field_content label_map)
|
||||
let t_record ?loc m : type_expression =
|
||||
let lst = Map.String.to_kv_list m in
|
||||
t_record_ez ?loc lst
|
||||
let record = LMap.of_list lst in
|
||||
t_record ?loc (record:field_content label_map)
|
||||
|
||||
let t_tuple ?loc lst : type_expression = make_t ?loc @@ T_tuple lst
|
||||
let t_pair ?loc (a , b) : type_expression = t_tuple ?loc [a; b]
|
||||
|
||||
let ez_t_sum ?loc (lst:(string * type_expression) list) : type_expression =
|
||||
let t_sum ?loc sum : type_expression = make_t ?loc @@ T_sum sum
|
||||
let t_sum_ez ?loc (lst:(string * type_expression) list) : type_expression =
|
||||
let aux (prev,i) (k, v) = (CMap.add (Constructor k) {ctor_type=v;ctor_decl_pos=i} prev, i+1) in
|
||||
let (map,_) = List.fold_left aux (CMap.empty,0) lst in
|
||||
make_t ?loc @@ T_sum (map: ctor_content constructor_map)
|
||||
let t_sum ?loc m : type_expression =
|
||||
let lst = Map.String.to_kv_list m in
|
||||
ez_t_sum ?loc lst
|
||||
t_sum ?loc (map: ctor_content constructor_map)
|
||||
|
||||
let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst)
|
||||
let t_annoted ?loc ty str : type_expression = make_t ?loc @@ T_annoted (ty, str)
|
||||
@ -86,14 +85,13 @@ let e'_bytes b : expression_content option =
|
||||
let bytes = Hex.to_bytes (`Hex b) in
|
||||
Some (E_literal (Literal_bytes bytes))
|
||||
with _ -> None
|
||||
let e_bytes_hex ?loc b : expression option =
|
||||
let e_bytes_hex_ez ?loc b : expression option =
|
||||
match e'_bytes b with
|
||||
| Some e' -> Some (make_e ?loc e')
|
||||
| None -> None
|
||||
let e_bytes_raw ?loc (b: bytes) : expression =
|
||||
make_e ?loc @@ E_literal (Literal_bytes b)
|
||||
let e_bytes_string ?loc (s: string) : expression =
|
||||
make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
|
||||
let e_bytes_raw ?loc (b: bytes) : expression = make_e ?loc @@ E_literal (Literal_bytes b)
|
||||
let e_bytes_hex ?loc b : expression = e_bytes_raw ?loc @@ Hex.to_bytes b
|
||||
let e_bytes_string ?loc (s: string) : expression = e_bytes_hex ?loc @@ Hex.of_string s
|
||||
let e_some ?loc s : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
|
||||
let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
|
||||
let e_string_cat ?loc sl sr : expression = make_e ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
|
||||
@ -102,13 +100,18 @@ let e_binop ?loc name a b = make_e ?loc @@ E_constant {cons_name = name ; argum
|
||||
|
||||
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
|
||||
let e_variable ?loc v = make_e ?loc @@ E_variable v
|
||||
let e_variable_ez ?loc v = e_variable ?loc @@ Var.of_name v
|
||||
let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
|
||||
let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ E_lambda {binder; input_type; output_type; result}
|
||||
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
||||
let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline }
|
||||
let e_recursive_ez ?loc fun_name fun_type lambda = e_recursive ?loc (Var.of_name fun_name) fun_type lambda
|
||||
let e_let_in ?loc let_binder inline rhs let_result = make_e ?loc @@ E_let_in { let_binder; rhs ; let_result; inline }
|
||||
let e_let_in_ez ?loc binder ascr inline rhs let_result = e_let_in ?loc (Var.of_name binder, ascr) inline rhs let_result
|
||||
let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code}
|
||||
|
||||
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||
let e_true ?loc (): expression = e_constructor ?loc "true" @@ e_unit ?loc ()
|
||||
let e_false ?loc (): expression = e_constructor ?loc "false" @@ e_unit ?loc ()
|
||||
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
|
||||
|
||||
let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
|
||||
@ -132,26 +135,28 @@ let e_while ?loc condition body = make_e ?loc @@ E_while {condition; body}
|
||||
let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
|
||||
let e_for_each ?loc binder collection collection_type body = make_e ?loc @@ E_for_each {binder;collection;collection_type;body}
|
||||
|
||||
let e_for_ez ?loc binder start final increment body = e_for ?loc (Var.of_name binder) start final increment body
|
||||
let e_for_each_ez ?loc (b,bo) collection collection_type body = e_for_each ?loc (Var.of_name b, Option.map Var.of_name bo) collection collection_type body
|
||||
|
||||
let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit ())
|
||||
|
||||
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
||||
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
||||
Match_variant lst
|
||||
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
|
||||
e_matching ?loc a (ez_match_variant lst)
|
||||
|
||||
let e_matching_variant ?loc a lst = e_matching ?loc a @@ Match_variant lst
|
||||
let e_matching_record ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_record (lst,ty_opt, expr)
|
||||
let e_matching_tuple ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_tuple (lst,ty_opt, expr)
|
||||
let e_matching_variable ?loc m var ty_opt expr = e_matching ?loc m @@ Match_variable (var,ty_opt, expr)
|
||||
|
||||
let e_matching_tuple_ez ?loc m lst ty_opt expr =
|
||||
let lst = List.map Var.of_name lst in
|
||||
e_matching_tuple ?loc m lst ty_opt expr
|
||||
|
||||
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
||||
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
||||
Match_variant lst
|
||||
|
||||
let e_record ?loc map = make_e ?loc @@ E_record map
|
||||
let e_record_ez ?loc (lst : (string * expr) list) : expression =
|
||||
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
|
||||
make_e ?loc @@ E_record map
|
||||
let e_record ?loc map =
|
||||
let lst = Map.String.to_kv_list map in
|
||||
e_record_ez ?loc lst
|
||||
|
||||
|
||||
e_record ?loc map
|
||||
|
||||
let make_option_typed ?loc e t_opt =
|
||||
match t_opt with
|
||||
@ -175,8 +180,9 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
|
||||
|
||||
|
||||
|
||||
let e_assign ?loc variable access_path expression =
|
||||
make_e ?loc @@ E_assign {variable;access_path;expression}
|
||||
let e_assign ?loc variable access_path expression = make_e ?loc @@ E_assign {variable;access_path;expression}
|
||||
let e_assign_ez ?loc variable access_path expression = e_assign ?loc (Var.of_name variable) access_path expression
|
||||
|
||||
|
||||
let get_e_accessor = fun t ->
|
||||
match t with
|
||||
|
||||
@ -17,15 +17,17 @@ val t_key_hash : ?loc:Location.t -> unit -> type_expression
|
||||
val t_timestamp : ?loc:Location.t -> unit -> type_expression
|
||||
val t_signature : ?loc:Location.t -> unit -> type_expression
|
||||
val t_list : ?loc:Location.t -> type_expression -> type_expression
|
||||
val t_variable : ?loc:Location.t -> string -> type_expression
|
||||
val t_constant : ?loc:Location.t -> type_constant -> type_expression
|
||||
val t_variable : ?loc:Location.t -> type_variable -> type_expression
|
||||
val t_variable_ez : ?loc:Location.t -> string -> type_expression
|
||||
val t_pair : ?loc:Location.t -> ( type_expression * type_expression ) -> type_expression
|
||||
val t_tuple : ?loc:Location.t -> type_expression list -> type_expression
|
||||
|
||||
val t_record : ?loc:Location.t -> type_expression Map.String.t -> type_expression
|
||||
val t_record : ?loc:Location.t -> field_content label_map -> type_expression
|
||||
val t_record_ez : ?loc:Location.t -> (string * type_expression) list -> type_expression
|
||||
|
||||
val t_sum : ?loc:Location.t -> type_expression Map.String.t -> type_expression
|
||||
val ez_t_sum : ?loc:Location.t -> ( string * type_expression ) list -> type_expression
|
||||
val t_sum : ?loc:Location.t -> ctor_content constructor_map -> type_expression
|
||||
val t_sum_ez : ?loc:Location.t -> ( string * type_expression ) list -> type_expression
|
||||
|
||||
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
|
||||
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
|
||||
@ -65,8 +67,11 @@ val e_key_hash : ?loc:Location.t -> string -> expression
|
||||
val e_chain_id : ?loc:Location.t -> string -> expression
|
||||
val e_mutez_z : ?loc:Location.t -> Z.t -> expression
|
||||
val e_mutez : ?loc:Location.t -> int -> expression
|
||||
val e_true : ?loc:Location.t -> unit -> expression
|
||||
val e_false : ?loc:Location.t -> unit -> expression
|
||||
val e'_bytes : string -> expression_content option
|
||||
val e_bytes_hex : ?loc:Location.t -> string -> expression option
|
||||
val e_bytes_hex_ez : ?loc:Location.t -> string -> expression option
|
||||
val e_bytes_hex : ?loc:Location.t -> Hex.t -> expression
|
||||
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
|
||||
val e_bytes_string : ?loc:Location.t -> string -> expression
|
||||
|
||||
@ -78,21 +83,27 @@ val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> ex
|
||||
|
||||
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
|
||||
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
||||
val e_variable_ez : ?loc:Location.t -> string -> expression
|
||||
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
||||
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
|
||||
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
||||
val e_recursive_ez : ?loc:Location.t -> string -> type_expression -> lambda -> expression
|
||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
|
||||
val e_let_in_ez : ?loc:Location.t -> string -> type_expression option -> bool -> expression -> expression -> expression
|
||||
val e_raw_code : ?loc:Location.t -> string -> expression -> expression
|
||||
|
||||
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||
|
||||
val ez_match_variant : ((string * string ) * expression) list -> matching_expr
|
||||
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
||||
val e_matching_variant : ?loc:Location.t -> expression -> ((constructor' * expression_variable) * expression) list -> expression
|
||||
val e_matching_record : ?loc:Location.t -> expression -> (label * expression_variable) list -> type_expression list option -> expression -> expression
|
||||
val e_matching_tuple : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression
|
||||
val e_matching_variable: ?loc:Location.t -> expression -> expression_variable -> type_expression option -> expression -> expression
|
||||
|
||||
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
||||
val e_matching_tuple_ez: ?loc:Location.t -> expression -> string list -> type_expression list option -> expression -> expression
|
||||
|
||||
val e_record : ?loc:Location.t -> expr label_map -> expression
|
||||
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
|
||||
val e_accessor : ?loc:Location.t -> expression -> access list -> expression
|
||||
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
|
||||
@ -112,11 +123,15 @@ val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||
|
||||
val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression
|
||||
val e_assign_ez : ?loc:Location.t -> string -> access list -> expression -> expression
|
||||
|
||||
val e_while : ?loc:Location.t -> expression -> expression -> expression
|
||||
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression
|
||||
val e_for_each : ?loc:Location.t -> expression_variable * expression_variable option -> expression -> collect_type -> expression -> expression
|
||||
|
||||
val e_for_ez : ?loc:Location.t -> string -> expression -> expression -> expression -> expression -> expression
|
||||
val e_for_each_ez : ?loc:Location.t -> string * string option -> expression -> collect_type -> expression -> expression
|
||||
|
||||
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
|
||||
|
||||
val e_typed_none : ?loc:Location.t -> type_expression -> expression
|
||||
|
||||
@ -1,5 +1,59 @@
|
||||
open Types
|
||||
|
||||
open Memory_proto_alpha.Protocol.Alpha_context
|
||||
let assert_operation_eq (a: packed_internal_operation) (b: packed_internal_operation): unit option =
|
||||
let Internal_operation {source=sa; operation=oa; nonce=na} = a in
|
||||
let Internal_operation {source=sb; operation=ob; nonce=nb} = b in
|
||||
let assert_source_eq sa sb =
|
||||
let sa = Contract.to_b58check sa in
|
||||
let sb = Contract.to_b58check sb in
|
||||
if String.equal sa sb then Some () else None
|
||||
in
|
||||
let rec assert_param_eq (pa,pb) =
|
||||
let open Tezos_micheline.Micheline in
|
||||
match (pa, pb) with
|
||||
| Int (la, ia), Int (lb, ib) when la = lb && ia = ib -> Some ()
|
||||
| String (la, sa), String (lb, sb) when la = lb && sa = sb -> Some ()
|
||||
| Bytes (la, ba), Bytes (lb, bb) when la = lb && ba = bb -> Some ()
|
||||
| Prim (la, pa, nla, aa), Prim (lb, pb, nlb, ab) when la = lb && pa = pb ->
|
||||
let la = List.map assert_param_eq @@ List.combine nla nlb in
|
||||
let lb = List.map ( fun (sa,sb) ->
|
||||
if String.equal sa sb then Some () else None) @@
|
||||
List.combine aa ab
|
||||
in
|
||||
Option.map (fun _ -> ()) @@ Option.bind_list @@ la @ lb
|
||||
| Seq (la, nla), Seq (lb, nlb) when la = lb ->
|
||||
Option.map (fun _ -> ()) @@ Option.bind_list @@ List.map assert_param_eq @@
|
||||
List.combine nla nlb
|
||||
| _ -> None
|
||||
in
|
||||
let assert_operation_eq (type a b) (oa: a manager_operation) (ob: b manager_operation) =
|
||||
match (oa, ob) with
|
||||
| Reveal sa, Reveal sb when sa = sb -> Some ()
|
||||
| Reveal _, _ -> None
|
||||
| Transaction ta, Transaction tb ->
|
||||
let aa,pa,ea,da = ta.amount,ta.parameters,ta.entrypoint,ta.destination in
|
||||
let ab,pb,eb,db = tb.amount,tb.parameters,tb.entrypoint,tb.destination in
|
||||
Format.printf "amount : %b; p : %b, e: %b, d : %b\n" (aa=ab) (pa=pb) (ea=eb) (da=db) ;
|
||||
let (pa,pb) = Tezos_data_encoding.Data_encoding.(force_decode pa, force_decode pb) in
|
||||
Option.bind (fun _ -> Some ()) @@
|
||||
Option.bind_list [
|
||||
Option.bind (fun (pa,pb) -> assert_param_eq Tezos_micheline.Micheline.(root pa, root pb)) @@
|
||||
Option.bind_pair (pa,pb);
|
||||
if aa = ab && ea = eb && da = db then Some () else None ]
|
||||
| Transaction _, _ -> None
|
||||
| Origination _oa, Origination _ob -> Some ()
|
||||
| Origination _, _ -> None
|
||||
| Delegation da, Delegation db when da = db -> Some ()
|
||||
| Delegation _, _ -> None
|
||||
in
|
||||
let assert_nonce_eq na nb = if na = nb then Some () else None in
|
||||
Option.bind (fun _ -> Some ()) @@
|
||||
Option.bind_list [
|
||||
assert_source_eq sa sb;
|
||||
assert_operation_eq oa ob;
|
||||
assert_nonce_eq na nb]
|
||||
|
||||
let assert_literal_eq (a, b : literal * literal) : unit option =
|
||||
match (a, b) with
|
||||
| Literal_int a, Literal_int b when a = b -> Some ()
|
||||
@ -27,7 +81,7 @@ let assert_literal_eq (a, b : literal * literal) : unit option =
|
||||
| Literal_address a, Literal_address b when a = b -> Some ()
|
||||
| Literal_address _, Literal_address _ -> None
|
||||
| Literal_address _, _ -> None
|
||||
| Literal_operation _, Literal_operation _ -> None
|
||||
| Literal_operation opa, Literal_operation opb -> assert_operation_eq opa opb
|
||||
| Literal_operation _, _ -> None
|
||||
| Literal_signature a, Literal_signature b when a = b -> Some ()
|
||||
| Literal_signature _, Literal_signature _ -> None
|
||||
|
||||
@ -130,6 +130,57 @@ let constant ppf : constant' -> unit = function
|
||||
| C_CONVERT_FROM_RIGHT_COMB -> fprintf ppf "CONVERT_FROM_RIGHT_COMB"
|
||||
| C_CONVERT_FROM_LEFT_COMB -> fprintf ppf "CONVERT_FROM_LEFT_COMB"
|
||||
|
||||
let operation ppf (o : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation) : unit =
|
||||
let print_option f ppf o =
|
||||
match o with
|
||||
Some (s) -> fprintf ppf "%a" f s
|
||||
| None -> fprintf ppf "None"
|
||||
in
|
||||
let open Tezos_micheline.Micheline in
|
||||
let rec prim ppf (node : (_,Memory_proto_alpha.Protocol.Alpha_context.Script.prim) node)= match node with
|
||||
| Int (l , i) -> fprintf ppf "Int (%i, %a)" l Z.pp_print i
|
||||
| String (l , s) -> fprintf ppf "String (%i, %s)" l s
|
||||
| Bytes (l, b) -> fprintf ppf "B (%i, %s)" l (Bytes.to_string b)
|
||||
| Prim (l , p , nl, a) -> fprintf ppf "P (%i, %s, %a, %a)" l
|
||||
(Memory_proto_alpha.Protocol.Michelson_v1_primitives.string_of_prim p)
|
||||
(list_sep_d prim) nl
|
||||
(list_sep_d (fun ppf s -> fprintf ppf "%s" s)) a
|
||||
| Seq (l, nl) -> fprintf ppf "S (%i, %a)" l
|
||||
(list_sep_d prim) nl
|
||||
in
|
||||
let l ppf (l: Memory_proto_alpha.Protocol.Alpha_context.Script.lazy_expr) =
|
||||
let oo = Tezos_data_encoding.Data_encoding.force_decode l in
|
||||
match oo with
|
||||
Some o -> fprintf ppf "%a" prim (Tezos_micheline.Micheline.root o)
|
||||
| None -> fprintf ppf "Fail decoding"
|
||||
in
|
||||
|
||||
let op ppf (type a) : a Memory_proto_alpha.Protocol.Alpha_context.manager_operation -> unit = function
|
||||
| Reveal (s: Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key.t) ->
|
||||
fprintf ppf "R %a" Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key.pp s
|
||||
| Transaction {amount; parameters; entrypoint; destination} ->
|
||||
fprintf ppf "T {%a; %a; %s; %a}"
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.pp amount
|
||||
l parameters
|
||||
entrypoint
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Contract.pp destination
|
||||
|
||||
| Origination {delegate; script; credit; preorigination} ->
|
||||
fprintf ppf "O {%a; %a; %a; %a}"
|
||||
(print_option Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key_hash.pp) delegate
|
||||
l script.code
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.pp credit
|
||||
(print_option Memory_proto_alpha.Protocol.Alpha_context.Contract.pp) preorigination
|
||||
|
||||
| Delegation so ->
|
||||
fprintf ppf "D %a" (print_option Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key_hash.pp) so
|
||||
in
|
||||
let Internal_operation {source;operation;nonce} = o in
|
||||
fprintf ppf "{source: %s; operation: %a; nonce: %i"
|
||||
(Memory_proto_alpha.Protocol.Alpha_context.Contract.to_b58check source)
|
||||
op operation
|
||||
nonce
|
||||
|
||||
let literal ppf (l : literal) =
|
||||
match l with
|
||||
| Literal_unit -> fprintf ppf "unit"
|
||||
@ -141,7 +192,7 @@ let literal ppf (l : literal) =
|
||||
| Literal_string s -> fprintf ppf "%a" Ligo_string.pp s
|
||||
| Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
|
||||
| Literal_address s -> fprintf ppf "@%S" s
|
||||
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
|
||||
| Literal_operation o -> fprintf ppf "Operation(%a)" operation o
|
||||
| Literal_key s -> fprintf ppf "key %s" s
|
||||
| Literal_key_hash s -> fprintf ppf "key_hash %s" s
|
||||
| Literal_signature s -> fprintf ppf "Signature %s" s
|
||||
|
||||
203
src/test/basic_multisig_tests.ml
Normal file
203
src/test/basic_multisig_tests.ml
Normal file
@ -0,0 +1,203 @@
|
||||
open Trace
|
||||
open Test_helpers
|
||||
|
||||
let file = "./contracts/basic_multisig/multisig.ligo"
|
||||
let mfile = "./contracts/basic_multisig/multisig.mligo"
|
||||
let refile = "./contracts/basic_multisig/multisig.religo"
|
||||
|
||||
let type_file f s =
|
||||
let%bind typed,state = Ligo.Compile.Utils.type_file f s (Contract "main") in
|
||||
ok @@ (typed,state)
|
||||
|
||||
let get_program f st =
|
||||
let s = ref None in
|
||||
fun () -> match !s with
|
||||
| Some s -> ok s
|
||||
| None -> (
|
||||
let%bind program = type_file f st in
|
||||
s := Some program ;
|
||||
ok program
|
||||
)
|
||||
|
||||
let compile_main f s () =
|
||||
let%bind typed_prg,_ = type_file f s 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_imperative
|
||||
|
||||
let init_storage threshold counter pkeys =
|
||||
let keys = List.map
|
||||
(fun el ->
|
||||
let (_,pk_str,_) = str_keys el in
|
||||
e_key @@ pk_str)
|
||||
pkeys in
|
||||
e_record_ez [
|
||||
("id" , e_string "MULTISIG" ) ;
|
||||
("counter" , e_nat counter ) ;
|
||||
("threshold" , e_nat threshold) ;
|
||||
("auth" , e_typed_list keys (t_key ())) ;
|
||||
]
|
||||
|
||||
let (first_owner , first_contract) =
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let id = List.nth dummy_environment.identities 0 in
|
||||
let kt = id.implicit_contract in
|
||||
Protocol.Alpha_context.Contract.to_b58check kt , kt
|
||||
|
||||
|
||||
let op_list =
|
||||
let open Memory_proto_alpha.Protocol.Alpha_context in
|
||||
let source : Contract.t = first_contract in
|
||||
let%bind operation =
|
||||
let parameters : Script.lazy_expr = Script.unit_parameter in
|
||||
let entrypoint = "default" in
|
||||
let open Proto_alpha_utils in
|
||||
let%bind destination =
|
||||
Trace.trace_alpha_tzresult (fun _ -> Main_errors.test_internal __LOC__) @@
|
||||
Contract.of_b58check "tz1PpDGHRXFQq3sYDuH8EpLWzPm5PFpe1sLE"
|
||||
in
|
||||
ok @@ Transaction {amount=Tez.zero; parameters; entrypoint; destination} in
|
||||
ok @@ (e_typed_list [e_literal (Literal_operation (Internal_operation {source;operation;nonce=0}))] (t_operation ()))
|
||||
let empty_payload = e_unit ()
|
||||
|
||||
let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode
|
||||
Tezos_base__TzPervasives.Chain_id.b58check_encoding
|
||||
Tezos_base__TzPervasives.Chain_id.zero
|
||||
|
||||
(* sign the message 'msg' with 'keys', if 'is_valid'=false the providid signature will be incorrect *)
|
||||
let params counter payload keys is_validl f s =
|
||||
let%bind program,_ = get_program f s () in
|
||||
let aux = fun acc (key,is_valid) ->
|
||||
let (_,_pk,sk) = key in
|
||||
let (pkh,_,_) = str_keys key in
|
||||
let msg = e_tuple
|
||||
[ payload ;
|
||||
e_nat counter ;
|
||||
e_string (if is_valid then "MULTISIG" else "XX") ;
|
||||
chain_id_zero ] in
|
||||
let%bind signature = sign_message program msg sk in
|
||||
ok @@ (e_pair (e_key_hash pkh) (e_signature signature))::acc in
|
||||
let%bind signed_msgs = Trace.bind_fold_list aux [] (List.rev @@ List.combine keys is_validl) in
|
||||
ok @@ e_record_ez [
|
||||
("counter" , e_nat counter ) ;
|
||||
("payload" , payload) ;
|
||||
("signatures" , e_typed_list signed_msgs (t_pair (t_key_hash (),t_signature ())) ) ;
|
||||
]
|
||||
|
||||
(* Provide one valid signature when the threshold is two of two keys *)
|
||||
let not_enough_1_of_2 f s () =
|
||||
let%bind program = get_program f s () in
|
||||
let exp_failwith = "Not enough signatures passed the check" in
|
||||
let keys = gen_keys () in
|
||||
let%bind test_params = params 0 empty_payload [keys] [true] f s in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender:first_contract () in
|
||||
let%bind () = expect_string_failwith
|
||||
program ~options "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in
|
||||
ok ()
|
||||
|
||||
let unmatching_counter f s () =
|
||||
let%bind program = get_program f s () in
|
||||
let exp_failwith = "Counters does not match" in
|
||||
let keys = gen_keys () in
|
||||
let%bind test_params = params 1 empty_payload [keys] [true] f s in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in
|
||||
ok ()
|
||||
|
||||
(* Provide one invalid signature (correct key but incorrect signature)
|
||||
when the threshold is one of one key *)
|
||||
let invalid_1_of_1 f s () =
|
||||
let%bind program = get_program f s () in
|
||||
let exp_failwith = "Invalid signature" in
|
||||
let keys = [gen_keys ()] in
|
||||
let%bind test_params = params 0 empty_payload keys [false] f s in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in
|
||||
ok ()
|
||||
|
||||
(* Provide one valid signature when the threshold is one of one key *)
|
||||
let valid_1_of_1 f s () =
|
||||
let%bind program = get_program f s () in
|
||||
let%bind op_list = op_list in
|
||||
let keys = gen_keys () in
|
||||
let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
|
||||
(fun n ->
|
||||
let%bind params = params n empty_payload [keys] [true] f s in
|
||||
ok @@ e_pair params (init_storage 1 n [keys])
|
||||
)
|
||||
(fun n ->
|
||||
ok @@ e_pair op_list (init_storage 1 (n+1) [keys])
|
||||
) in
|
||||
ok ()
|
||||
|
||||
(* Provive two valid signatures when the threshold is two of three keys *)
|
||||
let valid_2_of_3 f s () =
|
||||
let%bind program = get_program f s () in
|
||||
let%bind op_list = op_list in
|
||||
let param_keys = [gen_keys (); gen_keys ()] in
|
||||
let st_keys = param_keys @ [gen_keys ()] in
|
||||
let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
|
||||
(fun n ->
|
||||
let%bind params = params n empty_payload param_keys [true;true] f s in
|
||||
ok @@ e_pair params (init_storage 2 n st_keys)
|
||||
)
|
||||
(fun n ->
|
||||
ok @@ e_pair op_list (init_storage 2 (n+1) st_keys)
|
||||
) in
|
||||
ok ()
|
||||
|
||||
(* Provide one invalid signature and two valid signatures when the threshold is two of three keys *)
|
||||
let invalid_3_of_3 f s () =
|
||||
let%bind program = get_program f s () in
|
||||
let valid_keys = [gen_keys() ; gen_keys()] in
|
||||
let invalid_key = gen_keys () in
|
||||
let param_keys = valid_keys @ [invalid_key] in
|
||||
let st_keys = valid_keys @ [gen_keys ()] in
|
||||
let%bind test_params = params 0 empty_payload param_keys [false;true;true] f s in
|
||||
let exp_failwith = "Invalid signature" in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in
|
||||
ok ()
|
||||
|
||||
(* Provide two valid signatures when the threshold is three of three keys *)
|
||||
let not_enough_2_of_3 f s () =
|
||||
let%bind program = get_program f s() in
|
||||
let valid_keys = [gen_keys() ; gen_keys()] in
|
||||
let st_keys = gen_keys () :: valid_keys in
|
||||
let%bind test_params = params 0 empty_payload (valid_keys) [true;true] f s in
|
||||
let exp_failwith = "Not enough signatures passed the check" in
|
||||
let%bind () = expect_string_failwith
|
||||
program "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in
|
||||
ok ()
|
||||
|
||||
let main = test_suite "Basic Multisig" [
|
||||
test "compile" (compile_main file "pascaligo");
|
||||
test "unmatching_counter" (unmatching_counter file "pascaligo");
|
||||
test "valid_1_of_1" (valid_1_of_1 file "pascaligo");
|
||||
test "invalid_1_of_1" (invalid_1_of_1 file "pascaligo");
|
||||
test "not_enough_signature" (not_enough_1_of_2 file "pascaligo");
|
||||
test "valid_2_of_3" (valid_2_of_3 file "pascaligo");
|
||||
test "invalid_3_of_3" (invalid_3_of_3 file "pascaligo");
|
||||
test "not_enough_2_of_3" (not_enough_2_of_3 file "pascaligo");
|
||||
test "compile (mligo)" (compile_main mfile "cameligo");
|
||||
test "unmatching_counter (mligo)" (unmatching_counter mfile "cameligo");
|
||||
test "valid_1_of_1 (mligo)" (valid_1_of_1 mfile "cameligo");
|
||||
test "invalid_1_of_1 (mligo)" (invalid_1_of_1 mfile "cameligo");
|
||||
test "not_enough_signature (mligo)" (not_enough_1_of_2 mfile "cameligo");
|
||||
test "valid_2_of_3 (mligo)" (valid_2_of_3 mfile "cameligo");
|
||||
test "invalid_3_of_3 (mligo)" (invalid_3_of_3 mfile "cameligo");
|
||||
test "not_enough_2_of_3 (mligo)" (not_enough_2_of_3 mfile "cameligo");
|
||||
test "compile (religo)" (compile_main refile "reasonligo");
|
||||
test "unmatching_counter (religo)" (unmatching_counter refile "reasonligo");
|
||||
test "valid_1_of_1 (religo)" (valid_1_of_1 refile "reasonligo");
|
||||
test "invalid_1_of_1 (religo)" (invalid_1_of_1 refile "reasonligo");
|
||||
test "not_enough_signature (religo)" (not_enough_1_of_2 refile "reasonligo");
|
||||
test "valid_2_of_3 (religo)" (valid_2_of_3 refile "reasonligo");
|
||||
test "invalid_3_of_3 (religo)" (invalid_3_of_3 refile "reasonligo");
|
||||
test "not_enough_2_of_3 (religo)" (not_enough_2_of_3 refile "reasonligo");
|
||||
]
|
||||
5
src/test/contracts/basic_multisig/config.ligo
Normal file
5
src/test/contracts/basic_multisig/config.ligo
Normal file
@ -0,0 +1,5 @@
|
||||
type c_counter_type is nat
|
||||
type c_payload_type is unit
|
||||
|
||||
const c_address : address =
|
||||
("tz1PpDGHRXFQq3sYDuH8EpLWzPm5PFpe1sLE": address)
|
||||
5
src/test/contracts/basic_multisig/config.mligo
Normal file
5
src/test/contracts/basic_multisig/config.mligo
Normal file
@ -0,0 +1,5 @@
|
||||
type c_counter_type = nat
|
||||
type c_payload_type = unit
|
||||
|
||||
let c_address : address =
|
||||
("tz1PpDGHRXFQq3sYDuH8EpLWzPm5PFpe1sLE": address)
|
||||
71
src/test/contracts/basic_multisig/multisig.ligo
Normal file
71
src/test/contracts/basic_multisig/multisig.ligo
Normal file
@ -0,0 +1,71 @@
|
||||
#include "config.ligo"
|
||||
|
||||
// storage type
|
||||
|
||||
type counter is c_counter_type
|
||||
type threshold is c_counter_type
|
||||
type authorized_keys is list (key)
|
||||
|
||||
type storage is
|
||||
record [
|
||||
id : string;
|
||||
counter : counter;
|
||||
threshold : threshold;
|
||||
auth : authorized_keys
|
||||
]
|
||||
|
||||
// I/O types
|
||||
|
||||
type payload is c_payload_type
|
||||
type signatures is list (key_hash * signature)
|
||||
|
||||
type parameter is
|
||||
record [
|
||||
counter : counter;
|
||||
payload : payload;
|
||||
signatures : signatures
|
||||
]
|
||||
|
||||
type return is list (operation) * storage
|
||||
|
||||
|
||||
function main (const p : parameter; const s : storage) : return is
|
||||
block {
|
||||
|
||||
var payload: payload := p.payload;
|
||||
|
||||
|
||||
if p.counter =/= s.counter then
|
||||
failwith ("Counters does not match")
|
||||
else {
|
||||
const packed_payload : bytes =
|
||||
Bytes.pack ((payload, p.counter, s.id, Tezos.chain_id));
|
||||
var valid : nat := 0n;
|
||||
|
||||
var pkh_sigs : signatures := p.signatures;
|
||||
for key in list s.auth block {
|
||||
case pkh_sigs of
|
||||
nil -> skip
|
||||
| pkh_sig # tl -> block {
|
||||
if pkh_sig.0 = Crypto.hash_key (key) then block {
|
||||
pkh_sigs := tl;
|
||||
if Crypto.check (key, pkh_sig.1, packed_payload)
|
||||
then valid := valid + 1n
|
||||
else failwith ("Invalid signature")
|
||||
}
|
||||
else skip
|
||||
}
|
||||
end
|
||||
};
|
||||
|
||||
if valid < s.threshold then
|
||||
failwith ("Not enough signatures passed the check")
|
||||
else s.counter := s.counter + 1n
|
||||
};
|
||||
const contract_opt : option (contract(payload)) = Tezos.get_contract_opt(c_address);
|
||||
var op : list(operation) := nil;
|
||||
case contract_opt of
|
||||
| Some (c) -> op := list [Tezos.transaction (payload, 0tez, c)]
|
||||
| None -> failwith ("Contract not found")
|
||||
end;
|
||||
} with (op, s)
|
||||
65
src/test/contracts/basic_multisig/multisig.mligo
Normal file
65
src/test/contracts/basic_multisig/multisig.mligo
Normal file
@ -0,0 +1,65 @@
|
||||
#include "config.mligo"
|
||||
|
||||
// storage type
|
||||
|
||||
type counter = c_counter_type
|
||||
type threshold = c_counter_type
|
||||
type authorized_keys = key list
|
||||
|
||||
type storage = {
|
||||
id : string;
|
||||
counter : counter;
|
||||
threshold : threshold;
|
||||
auth : authorized_keys
|
||||
}
|
||||
|
||||
// I/O types
|
||||
|
||||
type payload = c_payload_type
|
||||
type signatures = (key_hash * signature) list
|
||||
|
||||
type parameter = {
|
||||
counter : counter;
|
||||
payload : payload;
|
||||
signatures : signatures
|
||||
}
|
||||
|
||||
type return = operation list * storage
|
||||
|
||||
|
||||
let main (p, s : parameter * storage) : return =
|
||||
let payload : payload = p.payload in
|
||||
let s =
|
||||
if p.counter <> s.counter then
|
||||
(failwith "Counters does not match" : storage)
|
||||
else
|
||||
let packed_payload : bytes =
|
||||
Bytes.pack (payload, p.counter, s.id, Tezos.chain_id) in
|
||||
let valid : nat = 0n in
|
||||
let keys : authorized_keys = s.auth in
|
||||
let aux =
|
||||
fun (vk, pkh_sig: (nat * authorized_keys)*(key_hash * signature)) ->
|
||||
let valid, keys = vk in
|
||||
match keys with
|
||||
| [] -> vk
|
||||
| key::keys ->
|
||||
if pkh_sig.0 = Crypto.hash_key key
|
||||
then
|
||||
let valid =
|
||||
if Crypto.check key pkh_sig.1 packed_payload
|
||||
then valid + 1n
|
||||
else (failwith "Invalid signature" : nat)
|
||||
in valid, keys
|
||||
else valid, keys in
|
||||
let valid, keys =
|
||||
List.fold aux p.signatures (valid, keys) in
|
||||
if valid < s.threshold then
|
||||
(failwith ("Not enough signatures passed the check") : storage)
|
||||
else {s with counter = s.counter + 1n}
|
||||
in
|
||||
let contract_opt : payload contract option = Tezos.get_contract_opt(c_address) in
|
||||
let op = match contract_opt with
|
||||
Some (c) -> [Tezos.transaction payload 0tez c]
|
||||
| None -> (failwith ("Contract not found") : operation list)
|
||||
in
|
||||
op, s
|
||||
74
src/test/contracts/basic_multisig/multisig.religo
Normal file
74
src/test/contracts/basic_multisig/multisig.religo
Normal file
@ -0,0 +1,74 @@
|
||||
#include "config.mligo"
|
||||
|
||||
// storage type
|
||||
|
||||
type counter = c_counter_type
|
||||
type threshold = c_counter_type
|
||||
type authorized_keys = list (key);
|
||||
|
||||
type storage = {
|
||||
id : string,
|
||||
counter : counter,
|
||||
threshold : threshold,
|
||||
auth : authorized_keys
|
||||
};
|
||||
|
||||
// I/O types
|
||||
|
||||
type payload = c_payload_type
|
||||
type dummy = (key_hash,signature);
|
||||
type signatures = list ((key_hash,signature)); /* Waiting to be fixed */
|
||||
|
||||
type parameter = {
|
||||
counter : counter,
|
||||
payload : payload,
|
||||
signatures : signatures
|
||||
};
|
||||
|
||||
type return = (list (operation),storage);
|
||||
|
||||
let main = ((p, s): (parameter, storage)) : return =>
|
||||
{
|
||||
let payload : payload = p.payload;
|
||||
let s =
|
||||
if (p.counter != s.counter) {
|
||||
(failwith ("Counters does not match") : storage);
|
||||
} else {
|
||||
let packed_payload : bytes =
|
||||
Bytes.pack ((payload, p.counter, s.id, Tezos.chain_id));
|
||||
let valid : nat = 0n;
|
||||
let keys : authorized_keys = s.auth;
|
||||
let aux = ((vk, pkh_sig) :
|
||||
((nat, authorized_keys), (key_hash, signature)))
|
||||
: (nat, authorized_keys) => {
|
||||
let (valid, keys) = vk;
|
||||
switch (keys) {
|
||||
| [] => vk;
|
||||
| [key, ...keys] =>
|
||||
if (pkh_sig[0] == Crypto.hash_key (key)) {
|
||||
let valid =
|
||||
if (Crypto.check (key, pkh_sig[1], packed_payload)) {
|
||||
valid + 1n;
|
||||
}
|
||||
else { (failwith ("Invalid signature") : nat) };
|
||||
(valid, keys);
|
||||
}
|
||||
else { (valid, keys); };
|
||||
};
|
||||
};
|
||||
let (valid, keys) =
|
||||
List.fold (aux, p.signatures, (valid, keys));
|
||||
if (valid < s.threshold) {
|
||||
(failwith ("Not enough signatures passed the check") : storage);
|
||||
}
|
||||
else {
|
||||
{...s,counter : s.counter + 1n};
|
||||
};
|
||||
};
|
||||
let contract_opt : option (contract (payload)) = Tezos.get_contract_opt(c_address);
|
||||
let op = switch (contract_opt) {
|
||||
| Some (c) => [Tezos.transaction(payload, 0tez, c)]
|
||||
| None => (failwith ("Contract not found") : list (operation))
|
||||
};
|
||||
(op,s)
|
||||
};
|
||||
@ -6,6 +6,7 @@
|
||||
simple-utils
|
||||
ligo
|
||||
alcotest
|
||||
tezos-utils
|
||||
tezos-crypto
|
||||
)
|
||||
(preprocess
|
||||
|
||||
@ -410,13 +410,13 @@ let string_arithmetic_religo () : (unit, _) result =
|
||||
|
||||
let bytes_arithmetic () : (unit, _) result =
|
||||
let%bind program = type_file "./contracts/bytes_arithmetic.ligo" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in
|
||||
let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex "7070" in
|
||||
let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex "" in
|
||||
let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex "ff7a7aff" in
|
||||
let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex "7a7a" in
|
||||
let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex "ba" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f007070" in
|
||||
let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "7070" in
|
||||
let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "" in
|
||||
let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "ff7a7aff" in
|
||||
let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "7a7a" in
|
||||
let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "ba" in
|
||||
let%bind () = expect_eq program "concat_op" foo foototo in
|
||||
let%bind () = expect_eq program "concat_op" empty toto in
|
||||
let%bind () = expect_eq program "slice_op" tata at in
|
||||
@ -454,8 +454,8 @@ let comparable_mligo () : (unit, _) result =
|
||||
|
||||
let crypto () : (unit, _) result =
|
||||
let%bind program = type_file "./contracts/crypto.ligo" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f007070" in
|
||||
let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foo in
|
||||
let%bind () = expect_eq_core program "hasherman512" foo b1 in
|
||||
let%bind b2 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foototo in
|
||||
@ -468,8 +468,8 @@ let crypto () : (unit, _) result =
|
||||
|
||||
let crypto_mligo () : (unit, _) result =
|
||||
let%bind program = mtype_file "./contracts/crypto.mligo" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f007070" in
|
||||
let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foo in
|
||||
let%bind () = expect_eq_core program "hasherman512" foo b1 in
|
||||
let%bind b2 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foototo in
|
||||
@ -482,8 +482,8 @@ let crypto_mligo () : (unit, _) result =
|
||||
|
||||
let crypto_religo () : (unit, _) result =
|
||||
let%bind program = retype_file "./contracts/crypto.religo" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f007070" in
|
||||
let%bind b1 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foo in
|
||||
let%bind () = expect_eq_core program "hasherman512" foo b1 in
|
||||
let%bind b2 = Test_helpers.run_typed_program_with_imperative_input program "hasherman512" foototo in
|
||||
@ -496,13 +496,13 @@ let crypto_religo () : (unit, _) result =
|
||||
|
||||
let bytes_arithmetic_mligo () : (unit, _) result =
|
||||
let%bind program = mtype_file "./contracts/bytes_arithmetic.mligo" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in
|
||||
let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex "7070" in
|
||||
let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex "" in
|
||||
let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex "ff7a7aff" in
|
||||
let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex "7a7a" in
|
||||
let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex "ba" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f007070" in
|
||||
let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "7070" in
|
||||
let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "" in
|
||||
let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "ff7a7aff" in
|
||||
let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "7a7a" in
|
||||
let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "ba" in
|
||||
let%bind () = expect_eq program "concat_op" foo foototo in
|
||||
let%bind () = expect_eq program "concat_op" empty toto in
|
||||
let%bind () = expect_eq program "slice_op" tata at in
|
||||
@ -516,13 +516,13 @@ let bytes_arithmetic_mligo () : (unit, _) result =
|
||||
|
||||
let bytes_arithmetic_religo () : (unit, _) result =
|
||||
let%bind program = retype_file "./contracts/bytes_arithmetic.religo" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex "0f007070" in
|
||||
let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex "7070" in
|
||||
let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex "" in
|
||||
let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex "ff7a7aff" in
|
||||
let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex "7a7a" in
|
||||
let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex "ba" in
|
||||
let%bind foo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f00" in
|
||||
let%bind foototo = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "0f007070" in
|
||||
let%bind toto = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "7070" in
|
||||
let%bind empty = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "" in
|
||||
let%bind tata = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "ff7a7aff" in
|
||||
let%bind at = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "7a7a" in
|
||||
let%bind ba = trace_option (test_internal __LOC__) @@ e_bytes_hex_ez "ba" in
|
||||
let%bind () = expect_eq program "concat_op" foo foototo in
|
||||
let%bind () = expect_eq program "concat_op" empty toto in
|
||||
let%bind () = expect_eq program "slice_op" tata at in
|
||||
|
||||
@ -13,6 +13,7 @@ let () =
|
||||
Id_tests.main ;
|
||||
Id_tests_p.main ;
|
||||
Id_tests_r.main ;
|
||||
Basic_multisig_tests.main;
|
||||
Multisig_tests.main ;
|
||||
Multisig_v2_tests.main ;
|
||||
Replaceable_id_tests.main ;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user