Commit eb583794 authored by Alain Mebsout's avatar Alain Mebsout Committed by Benjamin Canou

Michelson: propagate variable annotations inside pairs in stack type

Also check that tyoe annotated constants are correct, but don't produce annotated constants when unparsing.
parent fcd9b610
......@@ -297,6 +297,7 @@ assert_storage $contract_dir/if_some.tz '"?"' 'None' '""'
assert_storage $contract_dir/set_car.tz '(Pair "hello" 0)' '"world"' '(Pair "world" 0)'
assert_storage $contract_dir/set_car.tz '(Pair "hello" 0)' '"abc"' '(Pair "abc" 0)'
assert_storage $contract_dir/set_car.tz '(Pair "hello" 0)' '""' '(Pair "" 0)'
assert_fails $client run program $contract_dir/set_car.tz on storage '(Pair %wrong %field "hello" 0)' Unit and input '""'
assert_storage $contract_dir/set_cdr.tz '(Pair "hello" 0)' '1' '(Pair "hello" 1)'
assert_storage $contract_dir/set_cdr.tz '(Pair "hello" 500)' '3' '(Pair "hello" 3)'
......
......@@ -19,9 +19,9 @@ let default_steps_annot = Some (`Var_annot "steps")
let default_source_annot = Some (`Var_annot "source")
let default_self_annot = Some (`Var_annot "self")
let default_arg_annot = Some (`Var_annot "arg")
let default_param_annot = Some (`Var_annot "parameter")
let default_storage_annot = Some (`Var_annot "storage")
let default_param_annot = Some (`Field_annot "parameter")
let default_storage_annot = Some (`Field_annot "storage")
let default_car_annot = Some (`Field_annot "car")
let default_cdr_annot = Some (`Field_annot "cdr")
let default_contract_annot = Some (`Field_annot "contract")
......@@ -54,10 +54,10 @@ let field_to_var_annot : field_annot option -> var_annot option =
| None -> None
| Some (`Field_annot s) -> Some (`Var_annot s)
let type_to_field_annot : type_annot option -> field_annot option =
let type_to_var_annot : type_annot option -> var_annot option =
function
| None -> None
| Some (`Type_annot s) -> Some (`Field_annot s)
| Some (`Type_annot s) -> Some (`Var_annot s)
let var_to_field_annot : var_annot option -> field_annot option =
function
......@@ -206,6 +206,16 @@ let parse_type_annot
error_unexpected_annot loc fields >>? fun () ->
get_one_annot loc types
let parse_type_field_annot
: int -> string list -> (type_annot option * field_annot option) tzresult
= fun loc annot ->
parse_annots loc annot >>?
classify_annot loc >>? fun (vars, types, fields) ->
error_unexpected_annot loc vars >>? fun () ->
get_one_annot loc types >>? fun t ->
get_one_annot loc fields >|? fun f ->
(t, f)
let parse_composed_type_annot
: int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult
= fun loc annot ->
......@@ -217,10 +227,24 @@ let parse_composed_type_annot
(t, f1, f2)
let check_const_type_annot
: int -> string list -> type_annot option -> unit tzresult Lwt.t
= fun loc annot expected_annot ->
: int -> string list -> type_annot option -> field_annot option list -> unit tzresult Lwt.t
= fun loc annot expected_name expected_fields ->
Lwt.return
(parse_type_annot loc annot >>? merge_type_annot expected_annot >|? fun _ -> ())
(parse_composed_type_annot loc annot >>? fun (ty_name, field1, field2) ->
merge_type_annot expected_name ty_name >>? fun _ ->
match expected_fields, field1, field2 with
| [], Some _, _ | [], _, Some _ | [_], Some _, Some _ ->
(* Too many annotations *)
error (Unexpected_annotation loc)
| _ :: _ :: _ :: _, _, _ | [_], None, Some _ ->
error (Unexpected_annotation loc)
| [], None, None -> ok ()
| [ f1; f2 ], _, _ ->
merge_field_annot f1 field1 >>? fun _ ->
merge_field_annot f2 field2 >|? fun _ -> ()
| [ f1 ], _, None ->
merge_field_annot f1 field1 >|? fun _ -> ()
)
let parse_field_annot
: int -> string list -> field_annot option tzresult
......
......@@ -19,9 +19,9 @@ val default_steps_annot : var_annot option
val default_source_annot : var_annot option
val default_self_annot : var_annot option
val default_arg_annot : var_annot option
val default_param_annot : var_annot option
val default_storage_annot : var_annot option
val default_param_annot : field_annot option
val default_storage_annot : field_annot option
val default_car_annot : field_annot option
val default_cdr_annot : field_annot option
val default_contract_annot : field_annot option
......@@ -46,7 +46,7 @@ val unparse_field_annot : field_annot option -> string list
(** Convertions functions between different annotation kinds *)
val field_to_var_annot : field_annot option -> var_annot option
val type_to_field_annot : type_annot option -> field_annot option
val type_to_var_annot : type_annot option -> var_annot option
val var_to_field_annot : var_annot option -> field_annot option
(** Replace an annotation by its default value if it is [None] *)
......@@ -82,18 +82,25 @@ val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t
(** Parse a type annotation only. *)
val parse_type_annot : int -> string list -> type_annot option tzresult
(** Parse a field annotation only. *)
val parse_field_annot :
int -> string list -> field_annot option tzresult
(** Parse an annotation for composed types, of the form
[:ty_name %field] in any order. *)
val parse_type_field_annot :
int -> string list -> (type_annot option * field_annot option) tzresult
(** Parse an annotation for composed types, of the form
[:ty_name %field1 %field2] in any order. *)
val parse_composed_type_annot :
int -> string list ->
(type_annot option * field_annot option * field_annot option) tzresult
(** Check that type annotations are consistent *)
(** Check that type annotations on constants are consistent *)
val check_const_type_annot :
int -> string list -> type_annot option -> unit tzresult Lwt.t
int -> string list -> type_annot option -> field_annot option list ->
unit tzresult Lwt.t
(** Extract and remove a field annotation from a node *)
val extract_field_annot :
......
......@@ -78,7 +78,10 @@ and 'ty ty =
| Timestamp_t : type_annot option -> Script_timestamp.t ty
| Address_t : type_annot option -> Contract.t ty
| Bool_t : type_annot option -> bool ty
| Pair_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) pair ty
| Pair_t :
('a ty * field_annot option * var_annot option) *
('b ty * field_annot option * var_annot option) *
type_annot option -> ('a, 'b) pair ty
| Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) union ty
| Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
| Option_t : ('v ty * field_annot option) * field_annot option * type_annot option -> 'v option ty
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment