From f19f3fd78584cc2082551b20e924c604175e1461 Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 30 Mar 2019 18:25:50 +0000 Subject: [PATCH] map tests --- src/lib_utils/x_tezos_micheline.ml | 5 +++++ src/ligo/ast_typed.ml | 18 +++++++++++++++- src/ligo/contracts/map.ligo | 4 ++-- src/ligo/mini_c.ml | 34 ++++++++++++++++++++++++++++-- src/ligo/test/integration_tests.ml | 16 +++++++++++++- src/ligo/transpiler.ml | 19 +++++++++++++---- src/ligo/typer.ml | 3 ++- 7 files changed, 88 insertions(+), 11 deletions(-) diff --git a/src/lib_utils/x_tezos_micheline.ml b/src/lib_utils/x_tezos_micheline.ml index 5ad1fba6e..8e4c74fca 100644 --- a/src/lib_utils/x_tezos_micheline.ml +++ b/src/lib_utils/x_tezos_micheline.ml @@ -40,6 +40,11 @@ module Michelson = struct let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_drop = prim I_DROP + let i_if a b = prim ~children:[a;b] I_IF + let i_if_none a b = prim ~children:[a;b] I_IF_NONE + let i_failwith = prim I_FAILWITH + let i_assert_some = i_if_none (seq []) (seq [i_push_unit ; i_failwith]) + let dip code : michelson = prim ~children:[seq [code]] I_DIP let i_unpair = seq [i_dup ; i_car ; dip i_cdr] let i_unpiar = seq [i_dup ; i_cdr ; dip i_car] diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 2e19cf379..cc9279ae4 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -372,7 +372,23 @@ let rec assert_value_eq (a, b: (value*value)) : unit result = match (a.expressio | Record _, _ -> simple_fail "comparing record with other stuff" - | _, _ -> simple_fail "not a value" + | Map lsta, Map lstb -> ( + let%bind lst = generic_try (simple_error "maps of different lengths") + (fun () -> + let lsta' = List.sort compare lsta in + let lstb' = List.sort compare lstb in + List.combine lsta' lstb') in + let aux = fun ((ka, va), (kb, vb)) -> + let%bind _ = assert_value_eq (ka, kb) in + let%bind _ = assert_value_eq (va, vb) in + ok () in + let%bind _all = bind_map_list aux lst in + ok () + ) + | Map _, _ -> + simple_fail "comparing map with other stuff" + + | _, _ -> simple_fail "comparing not a value" let merge_annotation (a:type_value option) (b:type_value option) : type_value result = match a, b with diff --git a/src/ligo/contracts/map.ligo b/src/ligo/contracts/map.ligo index 896317631..0d779e0f9 100644 --- a/src/ligo/contracts/map.ligo +++ b/src/ligo/contracts/map.ligo @@ -5,10 +5,10 @@ const fb : foobar = map 42 -> 0 ; end -function get (const m : foobar) : int is +function get (const m : foobar) : option(int) is begin skip - end with m[42] + m[23] + end with m[42] const bm : foobar = map 144 -> 23 ; diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index d38a95a9f..09b283b8a 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -57,6 +57,7 @@ type value = [ | `Right of value | `Some of value | `None + | `Map of (value * value) list (* | `Macro of anon_macro ... The future. *) | `Function of anon_function ] @@ -152,7 +153,7 @@ module PP = struct let environment ppf (x:environment) = fprintf ppf "Env[%a]" (list_sep environment_small) x - let rec value ppf : value -> _ = function + let rec value ppf : value -> unit = function | `Bool b -> fprintf ppf "%b" b | `Int n -> fprintf ppf "%d" n | `Nat n -> fprintf ppf "%d" n @@ -165,6 +166,10 @@ module PP = struct | `Function x -> function_ ppf x.content | `None -> fprintf ppf "None" | `Some s -> fprintf ppf "Some (%a)" value s + | `Map m -> fprintf ppf "Map[%a]" (list_sep value_assoc) m + + and value_assoc ppf : (value * value) -> unit = fun (a, b) -> + fprintf ppf "%a -> %a" value a value b and expression ppf ((e, _, _):expression) = match e with | Var v -> fprintf ppf "%s" v @@ -652,6 +657,8 @@ module Translate_program = struct | "EQ" -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_EQ] | "UPDATE" -> ok @@ simple_ternary @@ prim I_UPDATE | "SOME" -> ok @@ simple_unary @@ prim I_SOME + | "GET_FORCE" -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some] + | "GET" -> ok @@ simple_binary @@ prim I_GET | x -> simple_fail @@ "predicate \"" ^ x ^ "\" doesn't exist" and translate_value (v:value) : michelson result = match v with @@ -673,6 +680,10 @@ module Translate_program = struct | `Some s -> let%bind s' = translate_value s in ok @@ prim ~children:[s'] D_Some + | `Map lst -> + let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in + let aux (a, b) = prim ~children:[a;b] D_Elt in + ok @@ seq @@ List.map aux lst' and translate_function ({capture;content}:anon_function) : michelson result = let {capture_type } = content in @@ -827,7 +838,7 @@ module Translate_program = struct let%bind schema_michelson = Environment.to_michelson_type env in ok @@ Format.asprintf "expression : %a\ncode : %a\nschema type : %a\noutput type : %a" - PP.expression (expr', ty, env) + PP.expression expr Michelson.pp code Michelson.pp schema_michelson Michelson.pp output_type @@ -1011,6 +1022,21 @@ module Translate_ir = struct | (Option_t ((o_ty, _), _, _)), Some s -> let%bind s' = translate_value @@ Ex_typed_value (o_ty, s) in ok @@ `Some s' + | (Map_t (k_cty, v_ty, _)), m -> + let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in + let lst = + let aux k v acc = (k, v) :: acc in + let lst = Script_ir_translator.map_fold aux m [] in + List.rev lst in + let%bind lst' = + let aux (k, v) = + let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in + let%bind v' = translate_value (Ex_typed_value (v_ty, v)) in + ok (k', v') + in + bind_map_list aux lst + in + ok @@ `Map lst' | _ -> simple_fail "this value can't be transpiled back yet" end @@ -1099,6 +1125,10 @@ module Combinators = struct | `Some s -> ok (Some s) | _ -> simple_fail "not an option" + let get_map (v:value) = match v with + | `Map lst -> ok lst + | _ -> simple_fail "not a map" + let get_t_option (v:type_value) = match v with | `Option t -> ok t | _ -> simple_fail "not an option" diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 39253dbf6..6904d1031 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -181,6 +181,20 @@ let map () : unit result = let expect = ez [(23, 0) ; (42, 0)] in AST_Typed.assert_value_eq (expect, result) in + let%bind _get = trace (simple_error "get") @@ + let aux n = + let input = ez [(23, n) ; (42, 4)] in + let%bind result = easy_run_typed "get" program input in + let expect = AST_Typed.Combinators.(a_some @@ a_int 4) in + AST_Typed.assert_value_eq (expect, result) + in + bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3] + in + let%bind _bigmap = trace (simple_error "bigmap") @@ + let%bind result = easy_evaluate_typed "bm" program in + let expect = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in + AST_Typed.assert_value_eq (expect, result) + in ok () let condition () : unit result = @@ -292,7 +306,7 @@ let main = "Integration (End to End)", [ test "record" record ; test "tuple" tuple ; test "option" option ; - (* test "map" map ; *) + test "map" map ; test "multiple parameters" multiple_parameters ; test "condition" condition ; test "matching" matching ; diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index b5cec2734..3713c2c23 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -223,17 +223,18 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express | Lambda l -> translate_lambda env l tv | Map m -> let%bind (src, dst) = Mini_c.Combinators.get_t_map tv in - let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev kv -> + let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) -> let%bind prev' = prev in - let%bind (k', v') = bind_map_pair (translate_annotated_expression env) kv in + let%bind (k', v') = + let v' = a_some v in + bind_map_pair (translate_annotated_expression env) (k, v') in return (Predicate ("UPDATE", [k' ; v' ; prev']), tv) in let init = return (Empty_map (src, dst), tv) in List.fold_left aux init m | LookUp dsi -> let%bind (ds', i') = bind_map_pair f dsi in - return (Predicate ("GET", [ds' ; i']), tv) - + return (Predicate ("GET", [i' ; ds']), tv) and translate_lambda_shallow env l tv = let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in @@ -405,6 +406,16 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression let%bind s' = untranspile s o in ok (a_some s') ) + | Type_constant ("map", [k_ty;v_ty]) -> ( + let%bind lst = get_map v in + let%bind lst' = + let aux = fun (k, v) -> + let%bind k' = untranspile k k_ty in + let%bind v' = untranspile v v_ty in + ok (k', v') in + bind_map_list aux lst in + return (Map lst') + ) | Type_constant _ -> simple_fail "unknown type_constant" | Type_sum m -> diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 829943d4d..d1994102d 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -380,7 +380,8 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an let%bind (ds, ind) = bind_map_pair (type_annotated_expression e) dsi in let%bind (src, dst) = get_t_map ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in - let%bind type_annotation = check dst in + let dst_opt = make_t_option dst in + let%bind type_annotation = check dst_opt in ok O.{expression = LookUp (ds, ind) ; type_annotation}