From 985eff44a9a96f6ef90106ed881d779f2f5b1e3b Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 10 Jun 2019 09:58:16 +0000 Subject: [PATCH] more keywords ; add support for sets ; remove assert from keywords --- src/ast_simplified/PP.ml | 2 + src/ast_simplified/combinators.ml | 5 ++ src/ast_simplified/misc.ml | 17 +++++- src/ast_simplified/types.ml | 2 + src/ast_typed/PP.ml | 2 + src/ast_typed/combinators.ml | 5 ++ src/ast_typed/misc.ml | 13 +++++ src/ast_typed/misc_smart.ml | 3 ++ src/ast_typed/types.ml | 2 + src/compiler/compiler_program.ml | 12 ++--- src/compiler/compiler_type.ml | 8 +++ src/compiler/uncompiler.ml | 5 ++ src/contracts/vote.mligo | 54 +++++++++++++++++++ src/meta_michelson/contract.ml | 1 + src/mini_c/PP.ml | 3 ++ src/mini_c/combinators.ml | 4 ++ src/mini_c/types.ml | 3 ++ src/operators/operators.ml | 11 ++++ src/parser/ligodity.ml | 13 +++++ src/test/test.ml | 1 + src/test/vote_tests.ml | 31 +++++++++++ src/transpiler/transpiler.ml | 11 ++++ src/typer/typer.ml | 27 ++++++++++ vendors/ligo-utils/tezos-utils/x_michelson.ml | 1 + 24 files changed, 227 insertions(+), 9 deletions(-) create mode 100644 src/contracts/vote.mligo create mode 100644 src/test/vote_tests.ml diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index e136988d2..07277c664 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -24,6 +24,7 @@ let literal ppf (l:literal) = match l with | Literal_bool b -> fprintf ppf "%b" b | Literal_int 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_string s -> fprintf ppf "%S" s | 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_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_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_lambda {binder;input_type;output_type;result} -> fprintf ppf "lambda (%a:%a) : %a return %a" diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index 690c9dfcb..5702dafc7 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -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_map key value = (T_constant ("map", [key ; value])) +let t_set key = (T_constant ("set", [key])) 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_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_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_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) @@ -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_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_set ?loc lst : expression = Location.wrap ?loc @@ E_set 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_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a) @@ -90,6 +93,8 @@ let e_typed_list ?loc lst t = e_annotation ?loc (e_list lst) (t_list t) 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) (input_type : type_expression option) diff --git a/src/ast_simplified/misc.ml b/src/ast_simplified/misc.ml index c857b8072..5cb679187 100644 --- a/src/ast_simplified/misc.ml +++ b/src/ast_simplified/misc.ml @@ -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 _, Literal_nat _ -> fail @@ different_literals "different nats" 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 _, Literal_tez _ -> fail @@ different_literals "different tezs" 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 _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b - let rec assert_value_eq (a, b: (expression * expression )) : unit result = let error_content () = Format.asprintf "\n@[- %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 _, _ -> 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) | (_a' , E_annotation (b , _)) -> assert_value_eq (a , b) | (E_variable _, _) | (E_lambda _, _) diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index 4693546b8..3eb0990cb 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -60,6 +60,7 @@ and expression' = (* Data Structures *) | E_map of (expr * expr) list | E_list of expr list + | E_set of expr list | E_look_up of (expr * expr) (* Matching *) | E_matching of (expr * matching_expr) @@ -90,6 +91,7 @@ and literal = | Literal_string of string | Literal_bytes of bytes | Literal_address of string + | Literal_timestamp of int | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation and 'a matching = diff --git a/src/ast_typed/PP.ml b/src/ast_typed/PP.ml index 4c2122fa8..3e8edf30c 100644 --- a/src/ast_typed/PP.ml +++ b/src/ast_typed/PP.ml @@ -43,6 +43,7 @@ and expression ppf (e:expression) : unit = | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m | E_map m -> fprintf ppf "map[@; @[%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m | E_list m -> fprintf ppf "list[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m + | E_set m -> fprintf ppf "set[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i | E_matching (ae, 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_int 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_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index 5dc82ee9d..1b4a1926c 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -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_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_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_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 | _ -> 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 | T_constant ("key", []) -> ok () | _ -> simple_fail "not a key" diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index 077f00c0a..091531789 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -155,6 +155,7 @@ module Free_variables = struct | E_record_accessor (a, _) -> self a | E_tuple_accessor (a, _) -> self a | 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_look_up (a , b) -> unions @@ List.map self [ a ; b ] | 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 _, Literal_nat _ -> fail @@ different_literals "different nats" 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 _, Literal_tez _ -> fail @@ different_literals "different tezs" 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 _, _ -> 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_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _) | (E_record_accessor _, _) diff --git a/src/ast_typed/misc_smart.ml b/src/ast_typed/misc_smart.ml index 2c56ad89c..0d0e8cd02 100644 --- a/src/ast_typed/misc_smart.ml +++ b/src/ast_typed/misc_smart.ml @@ -77,6 +77,9 @@ module Captured_variables = struct | E_list lst -> let%bind lst' = bind_map_list self lst in ok @@ unions lst' + | E_set lst -> + let%bind lst' = bind_map_list self lst in + ok @@ unions lst' | E_map m -> let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in ok @@ unions lst' diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index a1bfd46d3..65524fde8 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -100,6 +100,7 @@ and expression = (* Data Structures *) | E_map of (ae * ae) list | E_list of ae list + | E_set of ae list | E_look_up of (ae * ae) (* Advanced *) | E_matching of (ae * matching_expr) @@ -116,6 +117,7 @@ and literal = | Literal_bool of bool | Literal_int of int | Literal_nat of int + | Literal_timestamp of int | Literal_tez of int | Literal_string of string | Literal_bytes of bytes diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index ee6a1bab9..bae56f546 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -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_int 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_string s -> ok @@ string 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 ; 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) -> let module L = Logger.Stateful() in let%bind lst' = @@ -279,6 +272,9 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_make_empty_list t -> let%bind t' = Compiler_type.type_ t in 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 -> let%bind o' = Compiler_type.type_ o in return @@ i_none o' diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 18ea463cf..2632f2bd8 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -35,6 +35,7 @@ module Ty = struct | T_pair _ -> fail (not_comparable "pair") | T_map _ -> fail (not_comparable "map") | T_list _ -> fail (not_comparable "list") + | T_set _ -> fail (not_comparable "set") | T_option _ -> fail (not_comparable "option") | T_contract _ -> fail (not_comparable "contract") @@ -82,6 +83,10 @@ module Ty = struct | T_list t -> let%bind (Ex_ty t') = type_ t in 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 -> let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty Contract_types.(option t') @@ -142,6 +147,9 @@ let rec type_ : type_value -> O.michelson result = | T_list t -> let%bind t' = type_ t in 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 -> let%bind o' = type_ o in ok @@ O.prim ~children:[o'] O.T_option diff --git a/src/compiler/uncompiler.ml b/src/compiler/uncompiler.ml index ebf9f4028..81dc39967 100644 --- a/src/compiler/uncompiler.ml +++ b/src/compiler/uncompiler.ml @@ -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") @@ Alpha_context.Script_int.to_int n in 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 -> let%bind n = generic_try (simple_error "too big to fit an int") @@ diff --git a/src/contracts/vote.mligo b/src/contracts/vote.mligo new file mode 100644 index 000000000..3b4a4a857 --- /dev/null +++ b/src/contracts/vote.mligo @@ -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 diff --git a/src/meta_michelson/contract.ml b/src/meta_michelson/contract.ml index 7e38869c9..a9174a098 100644 --- a/src/meta_michelson/contract.ml +++ b/src/meta_michelson/contract.ml @@ -267,6 +267,7 @@ module Types = struct let key = Key_t None let list a = List_t (a, None) + let set a = Set_t (a, None) let assert_list = function | List_t (a, _) -> a | _ -> assert false diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 51867e490..7840565e1 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -27,6 +27,7 @@ let rec type_ ppf : type_value -> _ = function | 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_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_contract(t) -> fprintf ppf "contract(%a)" type_ t | T_deep_closure(c, arg, ret) -> @@ -45,6 +46,7 @@ let rec value ppf : value -> unit = function | D_operation _ -> fprintf ppf "operation[...bytes]" | D_int 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_unit -> fprintf ppf " " | 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_make_empty_map _ -> fprintf ppf "map[]" | E_make_empty_list _ -> fprintf ppf "list[]" + | E_make_empty_set _ -> fprintf ppf "set[]" | 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_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index 670d63e5f..a5ed136b0 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -82,6 +82,10 @@ let get_t_list (t:type_value) = match t with | T_list t -> ok t | _ -> 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 | D_left b -> ok b | _ -> simple_fail "not a left" diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 6e5bb4906..424763612 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -16,6 +16,7 @@ type type_value = | T_base of type_base | T_map of (type_value * type_value) | T_list of type_value + | T_set of type_value | T_contract of type_value | T_option of type_value @@ -35,6 +36,7 @@ type value = | D_unit | D_bool of bool | D_nat of int + | D_timestamp of int | D_tez of int | D_int of int | D_string of string @@ -64,6 +66,7 @@ and expression' = | E_variable of var_name | E_make_empty_map of (type_value * type_value) | E_make_empty_list of type_value + | E_make_empty_set of type_value | E_make_none of type_value | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) diff --git a/src/operators/operators.ml b/src/operators/operators.ml index c4ed39de0..1ccb179d2 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -118,6 +118,17 @@ module Simplify = struct ("Bytes.slice", "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.size", "SIZE") ; ("String.slice", "SLICE") ; diff --git a/src/parser/ligodity.ml b/src/parser/ligodity.ml index fba239b59..b56d63ea2 100644 --- a/src/parser/ligodity.ml +++ b/src/parser/ligodity.ml @@ -34,6 +34,19 @@ let parse_file (source: string) : AST.t result = in 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 -> let start = Lexing.lexeme_start_p lexbuf in let end_ = Lexing.lexeme_end_p lexbuf in diff --git a/src/test/test.ml b/src/test/test.ml index e07209be2..05db3980f 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -51,6 +51,7 @@ let () = Typer_tests.main ; Heap_tests.main ; Coase_tests.main ; + Vote_tests.main ; Bin_tests.main ; ] ; () diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml new file mode 100644 index 000000000..3fd337ab0 --- /dev/null +++ b/src/test/vote_tests.ml @@ -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 ; *) + ] diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 724a32b32..e61f98ec6 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -181,6 +181,7 @@ let rec translate_literal : AST.literal -> value = fun l -> match l with | Literal_bool b -> D_bool b | Literal_int n -> D_int n | Literal_nat n -> D_nat n + | Literal_timestamp n -> D_timestamp n | Literal_tez n -> D_tez n | Literal_bytes s -> D_bytes 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 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 -> ( let%bind (src, dst) = trace_strong (corner_case ~loc:__LOC__ "not a map") @@ diff --git a/src/typer/typer.ml b/src/typer/typer.ml index a3f0f0140..fc0d9abef 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -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 ()) | E_literal (Literal_nat n) -> 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) -> return (E_literal (Literal_tez n)) (t_tez ()) | 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 ()) in 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 -> let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in let%bind tv = @@ -752,6 +775,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_unit -> ok Literal_unit | Literal_bool b -> ok (Literal_bool b) | Literal_nat n -> ok (Literal_nat n) + | Literal_timestamp n -> ok (Literal_timestamp n) | Literal_tez n -> ok (Literal_tez n) | Literal_int n -> ok (Literal_int n) | 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 -> let%bind lst' = bind_map_list untype_expression lst in 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 -> let%bind (a , b) = bind_map_pair untype_expression dsi in return (e_look_up a b) diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 5222abd63..462a40b63 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -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_none ty = prim ~children:[ty] I_NONE 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_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP