more keywords ; add support for sets ; remove assert from keywords

This commit is contained in:
Galfour 2019-06-10 09:58:16 +00:00
parent f4fc06ce72
commit 985eff44a9
24 changed files with 227 additions and 9 deletions

View File

@ -24,6 +24,7 @@ let literal ppf (l:literal) = match l with
| Literal_bool b -> fprintf ppf "%b" b | Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n | Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n | Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_tez n -> fprintf ppf "%dtz" n | Literal_tez n -> fprintf ppf "%dtz" n
| Literal_string s -> fprintf ppf "%S" s | Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
@ -41,6 +42,7 @@ let rec expression ppf (e:expression) = match Location.unwrap e with
| E_record m -> fprintf ppf "record[%a]" (smap_sep_d expression) m | E_record m -> fprintf ppf "record[%a]" (smap_sep_d expression) m
| E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_list lst -> fprintf ppf "list[%a]" (list_sep_d expression) lst | E_list lst -> fprintf ppf "list[%a]" (list_sep_d expression) lst
| E_set lst -> fprintf ppf "set[%a]" (list_sep_d expression) lst
| E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" expression ds expression ind | E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder;input_type;output_type;result} -> | E_lambda {binder;input_type;output_type;result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" fprintf ppf "lambda (%a:%a) : %a return %a"

View File

@ -32,6 +32,7 @@ let ez_t_sum (lst:(string * type_expression) list) : type_expression =
let t_function param result : type_expression = T_function (param, result) let t_function param result : type_expression = T_function (param, result)
let t_map key value = (T_constant ("map", [key ; value])) let t_map key value = (T_constant ("map", [key ; value]))
let t_set key = (T_constant ("set", [key]))
let make_name (s : string) : name = s let make_name (s : string) : name = s
@ -40,6 +41,7 @@ let e_literal ?loc l : expression = Location.wrap ?loc @@ E_literal l
let e_unit ?loc () : expression = Location.wrap ?loc @@ E_literal (Literal_unit) let e_unit ?loc () : expression = Location.wrap ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_int n) let e_int ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_nat n) let e_nat ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bool b) let e_bool ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_string s) let e_string ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_address s) let e_address ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_address s)
@ -51,6 +53,7 @@ let e_some ?loc s : expression = Location.wrap ?loc @@ E_constant ("SOME", [s])
let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", []) let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", [])
let e_map_add ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old]) let e_map_add ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old])
let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst
let e_set ?loc lst : expression = Location.wrap ?loc @@ E_set lst
let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst
let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b] let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b]
let e_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a) let e_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a)
@ -91,6 +94,8 @@ let e_typed_list ?loc lst t =
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_lambda ?loc (binder : string) let e_lambda ?loc (binder : string)
(input_type : type_expression option) (input_type : type_expression option)
(output_type : type_expression option) (output_type : type_expression option)

View File

@ -42,6 +42,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_nat a, Literal_nat b when a = b -> ok () | Literal_nat a, Literal_nat b when a = b -> ok ()
| Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b
| Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b
| Literal_timestamp a, Literal_timestamp b when a = b -> ok ()
| Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b
| Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b
| Literal_tez a, Literal_tez b when a = b -> ok () | Literal_tez a, Literal_tez b when a = b -> ok ()
| Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b
| Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b
@ -59,7 +62,6 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b
| Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
let rec assert_value_eq (a, b: (expression * expression )) : unit result = let rec assert_value_eq (a, b: (expression * expression )) : unit result =
let error_content () = let error_content () =
Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b
@ -143,6 +145,19 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
) )
| E_list _, _ -> | E_list _, _ ->
simple_fail "comparing list with other stuff" simple_fail "comparing list with other stuff"
| E_set lsta, E_set lstb -> (
let lsta' = List.sort (compare) lsta in
let lstb' = List.sort (compare) lstb in
let%bind lst =
generic_try (simple_error "set of different lengths")
(fun () -> List.combine lsta' lstb') in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_set _, _ ->
simple_fail "comparing set with other stuff"
| (E_annotation (a , _) , _b') -> assert_value_eq (a , b) | (E_annotation (a , _) , _b') -> assert_value_eq (a , b)
| (_a' , E_annotation (b , _)) -> assert_value_eq (a , b) | (_a' , E_annotation (b , _)) -> assert_value_eq (a , b)
| (E_variable _, _) | (E_lambda _, _) | (E_variable _, _) | (E_lambda _, _)

View File

@ -60,6 +60,7 @@ and expression' =
(* Data Structures *) (* Data Structures *)
| E_map of (expr * expr) list | E_map of (expr * expr) list
| E_list of expr list | E_list of expr list
| E_set of expr list
| E_look_up of (expr * expr) | E_look_up of (expr * expr)
(* Matching *) (* Matching *)
| E_matching of (expr * matching_expr) | E_matching of (expr * matching_expr)
@ -90,6 +91,7 @@ and literal =
| Literal_string of string | Literal_string of string
| Literal_bytes of bytes | Literal_bytes of bytes
| Literal_address of string | Literal_address of string
| Literal_timestamp of int
| Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
and 'a matching = and 'a matching =

View File

@ -43,6 +43,7 @@ and expression ppf (e:expression) : unit =
| E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m
| E_map m -> fprintf ppf "map[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m | E_map m -> fprintf ppf "map[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
| E_list m -> fprintf ppf "list[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m | E_list m -> fprintf ppf "list[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
| E_set m -> fprintf ppf "set[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
| E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
| E_matching (ae, m) -> | E_matching (ae, m) ->
fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
@ -68,6 +69,7 @@ and literal ppf (l:literal) : unit =
| Literal_bool b -> fprintf ppf "%b" b | Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n | Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n | Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_tez n -> fprintf ppf "%dtz" n | Literal_tez n -> fprintf ppf "%dtz" n
| Literal_string s -> fprintf ppf "%s" s | Literal_string s -> fprintf ppf "%s" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b

View File

@ -27,6 +27,7 @@ let t_unit ?s () : type_value = make_t (T_constant ("unit", [])) s
let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s
let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s
let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s
let t_set t ?s () : type_value = make_t (T_constant ("set", [t])) s
let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s
let t_pair a b ?s () = t_tuple [a ; b] ?s () let t_pair a b ?s () = t_tuple [a ; b] ?s ()
@ -95,6 +96,10 @@ let get_t_list (t:type_value) : type_value result = match t.type_value' with
| T_constant ("list", [o]) -> ok o | T_constant ("list", [o]) -> ok o
| _ -> simple_fail "not a list" | _ -> simple_fail "not a list"
let get_t_set (t:type_value) : type_value result = match t.type_value' with
| T_constant ("set", [o]) -> ok o
| _ -> simple_fail "not a set"
let get_t_key (t:type_value) : unit result = match t.type_value' with let get_t_key (t:type_value) : unit result = match t.type_value' with
| T_constant ("key", []) -> ok () | T_constant ("key", []) -> ok ()
| _ -> simple_fail "not a key" | _ -> simple_fail "not a key"

View File

@ -155,6 +155,7 @@ module Free_variables = struct
| E_record_accessor (a, _) -> self a | E_record_accessor (a, _) -> self a
| E_tuple_accessor (a, _) -> self a | E_tuple_accessor (a, _) -> self a
| E_list lst -> unions @@ List.map self lst | E_list lst -> unions @@ List.map self lst
| E_set lst -> unions @@ List.map self lst
| E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
| E_look_up (a , b) -> unions @@ List.map self [ a ; b ] | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
| E_matching (a , cs) -> union (self a) (matching_expression b cs) | E_matching (a , cs) -> union (self a) (matching_expression b cs)
@ -344,6 +345,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_nat a, Literal_nat b when a = b -> ok () | Literal_nat a, Literal_nat b when a = b -> ok ()
| Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b
| Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b
| Literal_timestamp a, Literal_timestamp b when a = b -> ok ()
| Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b
| Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b
| Literal_tez a, Literal_tez b when a = b -> ok () | Literal_tez a, Literal_tez b when a = b -> ok ()
| Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b
| Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b
@ -443,6 +447,15 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
) )
| E_list _, _ -> | E_list _, _ ->
fail @@ different_values_because_different_types "list vs. non-list" a b fail @@ different_values_because_different_types "list vs. non-list" a b
| E_set lsta, E_set lstb -> (
let%bind lst =
generic_try (different_size_values "sets of different lengths" a b)
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_set _, _ ->
fail @@ different_values_because_different_types "set vs. non-set" a b
| (E_literal _, _) | (E_variable _, _) | (E_application _, _) | (E_literal _, _) | (E_variable _, _) | (E_application _, _)
| (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _) | (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _)
| (E_record_accessor _, _) | (E_record_accessor _, _)

View File

@ -77,6 +77,9 @@ module Captured_variables = struct
| E_list lst -> | E_list lst ->
let%bind lst' = bind_map_list self lst in let%bind lst' = bind_map_list self lst in
ok @@ unions lst' ok @@ unions lst'
| E_set lst ->
let%bind lst' = bind_map_list self lst in
ok @@ unions lst'
| E_map m -> | E_map m ->
let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in
ok @@ unions lst' ok @@ unions lst'

View File

@ -100,6 +100,7 @@ and expression =
(* Data Structures *) (* Data Structures *)
| E_map of (ae * ae) list | E_map of (ae * ae) list
| E_list of ae list | E_list of ae list
| E_set of ae list
| E_look_up of (ae * ae) | E_look_up of (ae * ae)
(* Advanced *) (* Advanced *)
| E_matching of (ae * matching_expr) | E_matching of (ae * matching_expr)
@ -116,6 +117,7 @@ and literal =
| Literal_bool of bool | Literal_bool of bool
| Literal_int of int | Literal_int of int
| Literal_nat of int | Literal_nat of int
| Literal_timestamp of int
| Literal_tez of int | Literal_tez of int
| Literal_string of string | Literal_string of string
| Literal_bytes of bytes | Literal_bytes of bytes

View File

@ -62,6 +62,7 @@ let rec translate_value (v:value) : michelson result = match v with
| D_bool b -> ok @@ prim (if b then D_True else D_False) | D_bool b -> ok @@ prim (if b then D_True else D_False)
| D_int n -> ok @@ int (Z.of_int n) | D_int n -> ok @@ int (Z.of_int n)
| D_nat n -> ok @@ int (Z.of_int n) | D_nat n -> ok @@ int (Z.of_int n)
| D_timestamp n -> ok @@ int (Z.of_int n)
| D_tez n -> ok @@ int (Z.of_int n) | D_tez n -> ok @@ int (Z.of_int n)
| D_string s -> ok @@ string s | D_string s -> ok @@ string s
| D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s) | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s)
@ -226,14 +227,6 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
i_drop ; i_drop ;
b' ; b' ;
] ]
(* | E_sequence_drop (a , b) ->
* let%bind (a' , env_a) = translate_expression a env in
* let%bind (b' , env_b) = translate_expression b env_a in
* return ~end_env:env_b @@ seq [
* a' ;
* i_drop ;
* b' ;
* ] *)
| E_constant(str, lst) -> | E_constant(str, lst) ->
let module L = Logger.Stateful() in let module L = Logger.Stateful() in
let%bind lst' = let%bind lst' =
@ -279,6 +272,9 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
| E_make_empty_list t -> | E_make_empty_list t ->
let%bind t' = Compiler_type.type_ t in let%bind t' = Compiler_type.type_ t in
return @@ i_nil t' return @@ i_nil t'
| E_make_empty_set t ->
let%bind t' = Compiler_type.type_ t in
return @@ i_empty_set t'
| E_make_none o -> | E_make_none o ->
let%bind o' = Compiler_type.type_ o in let%bind o' = Compiler_type.type_ o in
return @@ i_none o' return @@ i_none o'

View File

@ -35,6 +35,7 @@ module Ty = struct
| T_pair _ -> fail (not_comparable "pair") | T_pair _ -> fail (not_comparable "pair")
| T_map _ -> fail (not_comparable "map") | T_map _ -> fail (not_comparable "map")
| T_list _ -> fail (not_comparable "list") | T_list _ -> fail (not_comparable "list")
| T_set _ -> fail (not_comparable "set")
| T_option _ -> fail (not_comparable "option") | T_option _ -> fail (not_comparable "option")
| T_contract _ -> fail (not_comparable "contract") | T_contract _ -> fail (not_comparable "contract")
@ -82,6 +83,10 @@ module Ty = struct
| T_list t -> | T_list t ->
let%bind (Ex_ty t') = type_ t in let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(list t') ok @@ Ex_ty Contract_types.(list t')
| T_set t -> (
let%bind (Ex_comparable_ty t') = comparable_type t in
ok @@ Ex_ty Contract_types.(set t')
)
| T_option t -> | T_option t ->
let%bind (Ex_ty t') = type_ t in let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(option t') ok @@ Ex_ty Contract_types.(option t')
@ -142,6 +147,9 @@ let rec type_ : type_value -> O.michelson result =
| T_list t -> | T_list t ->
let%bind t' = type_ t in let%bind t' = type_ t in
ok @@ O.prim ~children:[t'] O.T_list ok @@ O.prim ~children:[t'] O.T_list
| T_set t ->
let%bind t' = type_ t in
ok @@ O.prim ~children:[t'] O.T_set
| T_option o -> | T_option o ->
let%bind o' = type_ o in let%bind o' = type_ o in
ok @@ O.prim ~children:[o'] O.T_option ok @@ O.prim ~children:[o'] O.T_option

View File

@ -29,6 +29,11 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result =
trace_option (simple_error "too big to fit an int") @@ trace_option (simple_error "too big to fit an int") @@
Alpha_context.Script_int.to_int n in Alpha_context.Script_int.to_int n in
ok @@ D_nat n ok @@ D_nat n
| (Timestamp_t _), n ->
let n =
Z.to_int @@
Alpha_context.Script_timestamp.to_zint n in
ok @@ D_timestamp n
| (Mutez_t _), n -> | (Mutez_t _), n ->
let%bind n = let%bind n =
generic_try (simple_error "too big to fit an int") @@ generic_try (simple_error "too big to fit an int") @@

54
src/contracts/vote.mligo Normal file
View File

@ -0,0 +1,54 @@
type storage = {
title : string ;
candidates : (string , int) map ;
voters : address set ;
beginning_time : timestamp ;
finish_time : timestamp ;
}
type init_action = (string * timestamp * timestamp)
type action =
| Vote of string
| Init of (string * timestamp * timestamp)
let init (init_params : init_action) (_ : storage) =
let (title , s , t) = init_params in
let candidates = Map [
("Yes" , 0) ;
("No" , 0)
] in
(
([] : operation list),
{
title = title ;
candidates = candidates ;
voters = (Set [] : address set) ;
beginning_time = s ;
finish_time = t ;
}
)
let vote (parameter : string) (storage : storage) =
let now = Current.time () in
assert (now >= storage.beginning_time && storage.finish_time < now) ;
let addr = Current.source () in
assert (not Set.mem addr storage.voters) ;
let x = Map.find parameter storage.candidates in
(
([] : operation list),
{
title = storage.title ;
candidates = Map.update parameter (Some (x + 1)) storage.candidates ;
voters = Set.add addr storage.voters ;
beginning_time = storage.beginning_time ;
finish_time = storage.finish_time ;
}
)
)
let main (action : action) (storage : storage) =
match action with
| Vote p -> vote p storage
| Init ps -> init ps storage

View File

@ -267,6 +267,7 @@ module Types = struct
let key = Key_t None let key = Key_t None
let list a = List_t (a, None) let list a = List_t (a, None)
let set a = Set_t (a, None)
let assert_list = function let assert_list = function
| List_t (a, _) -> a | List_t (a, _) -> a
| _ -> assert false | _ -> assert false

View File

@ -27,6 +27,7 @@ let rec type_ ppf : type_value -> _ = function
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v
| T_list(t) -> fprintf ppf "list(%a)" type_ t | T_list(t) -> fprintf ppf "list(%a)" type_ t
| T_set(t) -> fprintf ppf "set(%a)" type_ t
| T_option(o) -> fprintf ppf "option(%a)" type_ o | T_option(o) -> fprintf ppf "option(%a)" type_ o
| T_contract(t) -> fprintf ppf "contract(%a)" type_ t | T_contract(t) -> fprintf ppf "contract(%a)" type_ t
| T_deep_closure(c, arg, ret) -> | T_deep_closure(c, arg, ret) ->
@ -45,6 +46,7 @@ let rec value ppf : value -> unit = function
| D_operation _ -> fprintf ppf "operation[...bytes]" | D_operation _ -> fprintf ppf "operation[...bytes]"
| D_int n -> fprintf ppf "%d" n | D_int n -> fprintf ppf "%d" n
| D_nat n -> fprintf ppf "+%d" n | D_nat n -> fprintf ppf "+%d" n
| D_timestamp n -> fprintf ppf "+%d" n
| D_tez n -> fprintf ppf "%dtz" n | D_tez n -> fprintf ppf "%dtz" n
| D_unit -> fprintf ppf " " | D_unit -> fprintf ppf " "
| D_string s -> fprintf ppf "\"%s\"" s | D_string s -> fprintf ppf "\"%s\"" s
@ -73,6 +75,7 @@ and expression' ppf (e:expression') = match e with
| E_literal v -> fprintf ppf "%a" value v | E_literal v -> fprintf ppf "%a" value v
| E_make_empty_map _ -> fprintf ppf "map[]" | E_make_empty_map _ -> fprintf ppf "map[]"
| E_make_empty_list _ -> fprintf ppf "list[]" | E_make_empty_list _ -> fprintf ppf "list[]"
| E_make_empty_set _ -> fprintf ppf "set[]"
| E_make_none _ -> fprintf ppf "none" | E_make_none _ -> fprintf ppf "none"
| E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b | E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s

View File

@ -82,6 +82,10 @@ let get_t_list (t:type_value) = match t with
| T_list t -> ok t | T_list t -> ok t
| _ -> simple_fail "not a type list" | _ -> simple_fail "not a type list"
let get_t_set (t:type_value) = match t with
| T_set t -> ok t
| _ -> simple_fail "not a type set"
let get_left (v:value) = match v with let get_left (v:value) = match v with
| D_left b -> ok b | D_left b -> ok b
| _ -> simple_fail "not a left" | _ -> simple_fail "not a left"

View File

@ -16,6 +16,7 @@ type type_value =
| T_base of type_base | T_base of type_base
| T_map of (type_value * type_value) | T_map of (type_value * type_value)
| T_list of type_value | T_list of type_value
| T_set of type_value
| T_contract of type_value | T_contract of type_value
| T_option of type_value | T_option of type_value
@ -35,6 +36,7 @@ type value =
| D_unit | D_unit
| D_bool of bool | D_bool of bool
| D_nat of int | D_nat of int
| D_timestamp of int
| D_tez of int | D_tez of int
| D_int of int | D_int of int
| D_string of string | D_string of string
@ -64,6 +66,7 @@ and expression' =
| E_variable of var_name | E_variable of var_name
| E_make_empty_map of (type_value * type_value) | E_make_empty_map of (type_value * type_value)
| E_make_empty_list of type_value | E_make_empty_list of type_value
| E_make_empty_set of type_value
| E_make_none of type_value | E_make_none of type_value
| E_if_bool of expression * expression * expression | E_if_bool of expression * expression * expression
| E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_none of expression * expression * ((var_name * type_value) * expression)

View File

@ -118,6 +118,17 @@ module Simplify = struct
("Bytes.slice", "SLICE") ; ("Bytes.slice", "SLICE") ;
("Bytes.sub", "SLICE") ; ("Bytes.sub", "SLICE") ;
("Set.mem" , "SET_MEM") ;
("Set.empty" , "SET_EMPTY") ;
("Set.add" , "SET_ADD") ;
("Set.remove" , "SET_REMOVE") ;
("Map.find_opt" , "MAP_FIND_OPT") ;
("Map.find" , "MAP_FIND") ;
("Map.update" , "MAP_UPDATE") ;
("Map.add" , "MAP_ADD") ;
("Map.remove" , "MAP_REMOVE") ;
("String.length", "SIZE") ; ("String.length", "SIZE") ;
("String.size", "SIZE") ; ("String.size", "SIZE") ;
("String.slice", "SLICE") ; ("String.slice", "SLICE") ;

View File

@ -34,6 +34,19 @@ let parse_file (source: string) : AST.t result =
in in
simple_error str simple_error str
) )
| Lexer.Error err -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Lexer error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
(err.value)
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname source
in
simple_error str
)
| exn -> | exn ->
let start = Lexing.lexeme_start_p lexbuf in let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in let end_ = Lexing.lexeme_end_p lexbuf in

View File

@ -51,6 +51,7 @@ let () =
Typer_tests.main ; Typer_tests.main ;
Heap_tests.main ; Heap_tests.main ;
Coase_tests.main ; Coase_tests.main ;
Vote_tests.main ;
Bin_tests.main ; Bin_tests.main ;
] ; ] ;
() ()

31
src/test/vote_tests.ml Normal file
View File

@ -0,0 +1,31 @@
open Trace
open Ligo.Run
open Test_helpers
let get_program =
let s = ref None in
fun () -> match !s with
| Some s -> ok s
| None -> (
let%bind program = type_file "cameligo" "./contracts/vote.mligo" in
s := Some program ;
ok program
)
open Ast_simplified
let dummy_storage = ez_e_record [
("title" , e_string "dummy") ;
("candidates" , e_typed_map [] t_string t_int) ;
("voters" , e_typed_set [] t_address) ;
("beginning_time" , e_timestamp 0) ;
("finish_time" , e_timestamp 0) ;
]
let init_vote () =
let%bind _program = get_program () in
ok ()
let main = test_suite "Vote" [
(* test "type" init_vote ; *)
]

View File

@ -181,6 +181,7 @@ let rec translate_literal : AST.literal -> value = fun l -> match l with
| Literal_bool b -> D_bool b | Literal_bool b -> D_bool b
| Literal_int n -> D_int n | Literal_int n -> D_int n
| Literal_nat n -> D_nat n | Literal_nat n -> D_nat n
| Literal_timestamp n -> D_timestamp n
| Literal_tez n -> D_tez n | Literal_tez n -> D_tez n
| Literal_bytes s -> D_bytes s | Literal_bytes s -> D_bytes s
| Literal_string s -> D_string s | Literal_string s -> D_string s
@ -362,6 +363,16 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (init : expression) = return @@ E_make_empty_list t in let%bind (init : expression) = return @@ E_make_empty_list t in
bind_fold_list aux init lst' bind_fold_list aux init lst'
) )
| E_set lst -> (
let%bind t =
trace_strong (corner_case ~loc:__LOC__ "not a set") @@
Mini_c.Combinators.get_t_set tv in
let%bind lst' = bind_map_list (translate_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur ->
return @@ E_constant ("CONS", [cur ; prev]) in
let%bind (init : expression) = return @@ E_make_empty_set t in
bind_fold_list aux init lst'
)
| E_map m -> ( | E_map m -> (
let%bind (src, dst) = let%bind (src, dst) =
trace_strong (corner_case ~loc:__LOC__ "not a map") @@ trace_strong (corner_case ~loc:__LOC__ "not a map") @@

View File

@ -416,6 +416,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
return (E_literal (Literal_int n)) (t_int ()) return (E_literal (Literal_int n)) (t_int ())
| E_literal (Literal_nat n) -> | E_literal (Literal_nat n) ->
return (E_literal (Literal_nat n)) (t_nat ()) return (E_literal (Literal_nat n)) (t_nat ())
| E_literal (Literal_timestamp n) ->
return (E_literal (Literal_timestamp n)) (t_timestamp ())
| E_literal (Literal_tez n) -> | E_literal (Literal_tez n) ->
return (E_literal (Literal_tez n)) (t_tez ()) return (E_literal (Literal_tez n)) (t_tez ())
| E_literal (Literal_address s) -> | E_literal (Literal_address s) ->
@ -501,6 +503,27 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
ok (t_list ty ()) ok (t_list ty ())
in in
return (E_list lst') tv return (E_list lst') tv
| E_set lst ->
let%bind lst' = bind_map_list (type_expression e) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
ok (Some c') in
let%bind init = match tv_opt with
| None -> ok None
| Some ty ->
let%bind ty' = get_t_set ty in
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_annotation lst' in
trace_option (needs_annotation ae "empty set") opt in
ok (t_set ty ())
in
return (E_set lst') tv
| E_map lst -> | E_map lst ->
let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in
let%bind tv = let%bind tv =
@ -752,6 +775,7 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_unit -> ok Literal_unit | Literal_unit -> ok Literal_unit
| Literal_bool b -> ok (Literal_bool b) | Literal_bool b -> ok (Literal_bool b)
| Literal_nat n -> ok (Literal_nat n) | Literal_nat n -> ok (Literal_nat n)
| Literal_timestamp n -> ok (Literal_timestamp n)
| Literal_tez n -> ok (Literal_tez n) | Literal_tez n -> ok (Literal_tez n)
| Literal_int n -> ok (Literal_int n) | Literal_int n -> ok (Literal_int n)
| Literal_string s -> ok (Literal_string s) | Literal_string s -> ok (Literal_string s)
@ -803,6 +827,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_list lst -> | E_list lst ->
let%bind lst' = bind_map_list untype_expression lst in let%bind lst' = bind_map_list untype_expression lst in
return (e_list lst') return (e_list lst')
| E_set lst ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_set lst')
| E_look_up dsi -> | E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b) return (e_look_up a b)

View File

@ -47,6 +47,7 @@ let i_push_unit = i_push t_unit d_unit
let i_push_string str = i_push t_string (string str) let i_push_string str = i_push t_string (string str)
let i_none ty = prim ~children:[ty] I_NONE let i_none ty = prim ~children:[ty] I_NONE
let i_nil ty = prim ~children:[ty] I_NIL let i_nil ty = prim ~children:[ty] I_NIL
let i_empty_set ty = prim ~children:[ty] I_EMPTY_SET
let i_some = prim I_SOME let i_some = prim I_SOME
let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA
let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP