map tests

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]

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

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 ;

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"

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 ;

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 ->

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}