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

Improve error messages in ast_typed/combinators.ml

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-01-06 20:09:24 +01:00 committed by Suzanne Dupéron
parent e67e2098c2
commit 1863cf324b
3 changed files with 164 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -104,4 +104,5 @@ let%expect_test _ =
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog' |} ] ;
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
[%expect {| ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[profile -> bytes , owner -> address , controller -> address] |}] ;

72
src/stages/ast_typed/combinators.ml
View File

@ -1,6 +1,28 @@
open Trace
open Types
module Errors = struct
let not_a_x_expression expected_expression actual_expression () =
let message () =
Format.asprintf "Expected a %s expression but got a %a expression"
expected_expression
PP.expression actual_expression in
error (thunk "Expected a different expression") message
let not_a_x_type expected_type actual_type () =
let message () =
Format.asprintf "Expected the type %s but got the type %a"
expected_type
PP.type_value actual_type in
error (thunk "Expected a different type") message
let declaration_not_found expected_declaration () =
let message () =
Format.asprintf "Could not find a declaration with the name %s"
expected_declaration in
error (thunk "No declaration with the given name") message
end
let make_t type_value' simplified = { type_value' ; simplified }
let make_a_e ?(location = Location.generated) expression type_annotation environment = {
expression ;
@ -61,102 +83,102 @@ let get_expression (x:annotated_expression) = x.expression
let get_lambda e : _ result = match e with
| E_lambda l -> ok l
| _ -> simple_fail "not a lambda"
| _ -> fail @@ Errors.not_a_x_expression "lambda" e ()
let get_lambda_with_type e =
match (e.expression , e.type_annotation.type_value') with
| E_lambda l , T_arrow (i,o) -> ok (l , (i,o))
| _ -> simple_fail "not a lambda with functional type"
| _ -> fail @@ Errors.not_a_x_expression "lambda with functional type" e.expression ()
let get_t_bool (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_bool) -> ok ()
| _ -> simple_fail "not a bool"
| _ -> fail @@ Errors.not_a_x_type "bool" t ()
let get_t_int (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_int) -> ok ()
| _ -> simple_fail "not a int"
| _ -> fail @@ Errors.not_a_x_type "int" t ()
let get_t_nat (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_nat) -> ok ()
| _ -> simple_fail "not a nat"
| _ -> fail @@ Errors.not_a_x_type "nat" t ()
let get_t_unit (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_unit) -> ok ()
| _ -> simple_fail "not a unit"
| _ -> fail @@ Errors.not_a_x_type "unit" t ()
let get_t_mutez (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_mutez) -> ok ()
| _ -> simple_fail "not a tez"
| _ -> fail @@ Errors.not_a_x_type "tez" t ()
let get_t_bytes (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_bytes) -> ok ()
| _ -> simple_fail "not a bytes"
| _ -> fail @@ Errors.not_a_x_type "bytes" t ()
let get_t_string (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_string) -> ok ()
| _ -> simple_fail "not a string"
| _ -> fail @@ Errors.not_a_x_type "string" t ()
let get_t_contract (t:type_value) : type_value result = match t.type_value' with
| T_operator (TC_contract x) -> ok x
| _ -> simple_fail "not a contract"
| _ -> fail @@ Errors.not_a_x_type "contract" t ()
let get_t_option (t:type_value) : type_value result = match t.type_value' with
| T_operator (TC_option o) -> ok o
| _ -> simple_fail "not a option"
| _ -> fail @@ Errors.not_a_x_type "option" t ()
let get_t_list (t:type_value) : type_value result = match t.type_value' with
| T_operator (TC_list l) -> ok l
| _ -> simple_fail "not a list"
| _ -> fail @@ Errors.not_a_x_type "list" t ()
let get_t_set (t:type_value) : type_value result = match t.type_value' with
| T_operator (TC_set s) -> ok s
| _ -> simple_fail "not a set"
| _ -> fail @@ Errors.not_a_x_type "set" t ()
let get_t_key (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_key) -> ok ()
| _ -> simple_fail "not a key"
| _ -> fail @@ Errors.not_a_x_type "key" t ()
let get_t_signature (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_signature) -> ok ()
| _ -> simple_fail "not a signature"
| _ -> fail @@ Errors.not_a_x_type "signature" t ()
let get_t_key_hash (t:type_value) : unit result = match t.type_value' with
| T_constant (TC_key_hash) -> ok ()
| _ -> simple_fail "not a key_hash"
| _ -> fail @@ Errors.not_a_x_type "key_hash" t ()
let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
| T_tuple lst -> ok lst
| _ -> simple_fail "not a tuple"
| _ -> fail @@ Errors.not_a_x_type "tuple" t ()
let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_value' with
| T_tuple lst ->
let%bind () =
trace_strong (simple_error "not a pair") @@
trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@
Assert.assert_list_size lst 2 in
ok List.(nth lst 0 , nth lst 1)
| _ -> simple_fail "not a tuple"
| _ -> fail @@ Errors.not_a_x_type "pair (tuple with two elements)" t ()
let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
| T_arrow (a,r) -> ok (a,r)
| _ -> simple_fail "not a function"
| _ -> fail @@ Errors.not_a_x_type "function" t ()
let get_t_sum (t:type_value) : type_value constructor_map result = match t.type_value' with
| T_sum m -> ok m
| _ -> simple_fail "not a sum"
| _ -> fail @@ Errors.not_a_x_type "sum" t ()
let get_t_record (t:type_value) : type_value label_map result = match t.type_value' with
| T_record m -> ok m
| _ -> simple_fail "not a record type"
| _ -> fail @@ Errors.not_a_x_type "record" t ()
let get_t_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with
| T_operator (TC_map (k,v)) -> ok (k, v)
| _ -> simple_fail "get: not a map"
| _ -> fail @@ Errors.not_a_x_type "map" t ()
let get_t_big_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with
| T_operator (TC_big_map (k,v)) -> ok (k, v)
| _ -> simple_fail "get: not a big_map"
| _ -> fail @@ Errors.not_a_x_type "big_map" t ()
let get_t_map_key : type_value -> type_value result = fun t ->
let%bind (key , _) = get_t_map t in
@ -303,5 +325,5 @@ let get_declaration_by_name : program -> string -> declaration result = fun p na
match declaration with
| Declaration_constant (d , _) -> d.name = Var.of_name name
in
trace_option (simple_error "no declaration with given name") @@
trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p

115
src/test/contracts/negative/id.mligo Normal file
View File

@ -0,0 +1,115 @@
type id = int
type id_details = {
owner: address;
controller: address;
profile: bytes;
}
(* The prices kept in storage can be changed by bakers, though they should only be
adjusted down over time, not up. *)
type storage = (id, id_details) big_map * int * (tez * tez)
(** Preliminary thoughts on ids:
I very much like the simplicity of http://gurno.com/adam/mne/.
5 three letter words means you have a 15 character identity, not actually more
annoying than an IP address and a lot more memorable than the raw digits. This
can be stored as a single integer which is then translated into the corresponding
series of 5 words.
I in general like the idea of having a 'skip' mechanism, but it does need to cost
something so people don't eat up the address space. 256 ^ 5 means you have a lot
of address space, but if people troll by skipping a lot that could be eaten up.
Should probably do some napkin calculations for how expensive skipping needs to
be to deter people from doing it just to chew up address space.
*)
let buy (parameter, storage: (bytes * address option) * storage) =
let void: unit = assert (amount = storage.2.0) in
let profile, initial_controller = parameter in
let identities, last_id, prices = storage in
let controller: address =
match initial_controller with
| Some addr -> addr
| None -> sender
in
let new_id: id = last_id + 1 in
let new_id_details: id_details = {
owner = sender ;
controller = controller ;
profile = profile ;
}
in
let updated_identities: (id, id_details) big_map =
Big_map.update new_id new_id_details identities
in
([]: instruction), (updated_identities, new_id, prices)
let update_owner (parameter, storage: (id * address) * storage) =
let id, new_owner = parameter in
let identities, last_id, prices = storage in
let current_id_details = Bip_map.find_opt id identities in
let is_allowed: bool =
if sender = current_id_details.owner
then true
else failwith "You are not the owner of the ID " ^ (string_of_int id)
in
let updated_id_details = {
owner = new_owner;
controller = current_id_details.controller;
profile = current_id_details.profile;
}
in
let updated_identities = Big_map.update id updated_id_details identities in
([]: instruction), (updated_identities, last_id, prices)
let update_details (parameter, storage: (id * bytes option * address option) * storage) =
let id, new_profile, new_controller = parameter in
let identities, last_id, prices = storage in
let current_id_details = Big_map.find_opt id identities in
let is_allowed: bool =
if
match current_id_details with
| Some id_details -> (sender = id_details.controller) || (sender = id_details.owner)
| None -> failwith ("No such ID " + id)
then true
else failwith ("You are not the owner or controller of the ID " ^ id)
in
let owner: address = current_id_details.owner in
let profile: bytes =
match new_profile with
| None -> (* Default *) current_id_details.profile
| Some new_profile -> new_profile
in
let controller: address =
match new_controller with
| None -> (* Default *) current_id_details.controller
| Some new_controller -> new_controller
in
let updated_id_details = {
owner = owner;
controller = controller;
profile = profile;
}
in
let updated_identities = Big_map.update id updated_id_details identities in
([]: instruction), (updated_identities, last_id, prices)
(* Let someone skip the next identity so nobody has to take one that's undesirable *)
let skip (p,s: unit * storage) =
let void: unit = assert (amount = storage.2.1) in
let identities, last_id, prices = storage in
([]: instruction), (identities, last_id + 1, prices)
let whois_id (query, storage: id * storage) =
let identities, last_id, _ = storage in
let result: (unit -> id_details) =
let id_details: id_details =
begin
match Big_map.find_opt query identities with
| Some details -> details
| None -> failwith "This ID doesn't exist in the system."
end
in (fun (x: unit) -> id_details)
in ([result]: instruction), storage